perldoc.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

  my $good_class_found;
  foreach my $c (@class_list) {
    DEBUG > 4 and print "Trying to load $c...\n";
    if($class_loaded{$c}) {
      DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
      $good_class_found = $c;
      last;
    }
    
    if($class_seen{$c}) {
      DEBUG > 4 and print
       "I've tried $c before, and it's no good.  Skipping.\n";
      next;
    }
    
    $class_seen{$c} = 1;
    
    if( $c->can('parse_from_file') ) {
      DEBUG > 4 and print
       "Interesting, the formatter class $c is already loaded!\n";
      
    } elsif(
      (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
       # the alway case-insensitive fs's
      and $class_seen{lc("~$c")}++
    ) {
      DEBUG > 4 and print
       "We already used something quite like \"\L$c\E\", so no point using $c\n";
      # This avoids redefining the package.
    } else {
      DEBUG > 4 and print "Trying to eval 'require $c'...\n";

      local $^W = $^W;
      if(DEBUG() or $self->opt_v) {
        # feh, let 'em see it
      } else {
        $^W = 0;
        # The average user just has no reason to be seeing
        #  $^W-suppressable warnings from the the require!
      }

      eval "require $c";
      if($@) {
        DEBUG > 4 and print "Couldn't load $c: $!\n";
        next;
      }
    }
    
    if( $c->can('parse_from_file') ) {
      DEBUG > 4 and print "Settling on $c\n";
      my $v = $c->VERSION;
      $v = ( defined $v and length $v ) ? " version $v" : '';
      $self->aside("Formatter class $c$v successfully loaded!\n");
      $good_class_found = $c;
      last;
    } else {
      DEBUG > 4 and print "Class $c isn't a formatter?!  Skipping.\n";
    }
  }
  
  die "Can't find any loadable formatter class in @class_list?!\nAborting"
    unless $good_class_found;
  
  $self->{'formatter_class'} = $good_class_found;
  $self->aside("Will format with the class $good_class_found\n");
  
  return;
}

}
#..........................................................................

sub formatter_sanity_check {
  my $self = shift;
  my $formatter_class = $self->{'formatter_class'}
   || die "NO FORMATTER CLASS YET!?";
  
  if(!$self->opt_T # so -T can FORCE sending to STDOUT
    and $formatter_class->can('is_pageable')
    and !$formatter_class->is_pageable
    and !$formatter_class->can('page_for_perldoc')
  ) {
    my $ext =
     ($formatter_class->can('output_extension')
       && $formatter_class->output_extension
     ) || '';
    $ext = ".$ext" if length $ext;
    
    die
       "When using Perldoc to format with $formatter_class, you have to\n"
     . "specify -T or -dsomefile$ext\n"
     . "See `perldoc perldoc' for more information on those switches.\n"
    ;
  }
}

#..........................................................................

sub render_and_page {
    my($self, $found_list) = @_;
    
    $self->maybe_generate_dynamic_pod($found_list);

    my($out, $formatter) = $self->render_findings($found_list);
    
    if($self->opt_d) {
      printf "Perldoc (%s) output saved to %s\n",
        $self->{'formatter_class'} || ref($self),
        $out;
      print "But notice that it's 0 bytes long!\n" unless -s $out;
      
      
    } elsif(  # Allow the formatter to "page" itself, if it wants.
      $formatter->can('page_for_perldoc')
      and do {
        $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
        if( $formatter->page_for_perldoc($out, $self) ) {
          $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
          1;
        } else {
          $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
          '';
        }
      }
    ) {
      # Do nothing, since the formatter has "paged" it for itself.
    
    } else {
      # Page it normally (internally)
      
      if( -s $out ) {  # Usual case:
        $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
        
      } else {
        # Odd case:
        $self->aside("Skipping $out (from $$found_list[0] "
         . "via $$self{'formatter_class'}) as it is 0-length.\n");
         
        push @{ $self->{'temp_file_list'} }, $out;
        $self->unlink_if_temp_file($out);
      }
    }
    
    $self->after_rendering();  # any extra cleanup or whatever
    
    return;
}

#..........................................................................

sub options_reading {
    my $self = shift;
    
    if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
      require Text::ParseWords;
      $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
      # Yes, appends to the beginning
      unshift @{ $self->{'args'} },
        Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
      ;
      DEBUG > 1 and print "  Args now: @{$self->{'args'}}\n\n";
    } else {
      DEBUG > 1 and print "  Okay, no PERLDOC setting in ENV.\n";
    }

    DEBUG > 1
     and print "  Args right before switch processing: @{$self->{'args'}}\n";

    Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
     or return $self->usage;

    DEBUG > 1
     and print "  Args after switch processing: @{$self->{'args'}}\n";

    return $self->usage if $self->opt_h;
  
    return;
}

#..........................................................................

sub options_processing {
    my $self = shift;
    
    if ($self->opt_X) {
        my $podidx = "$Config{'archlib'}/pod.idx";
        $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
        $self->{'podidx'} = $podidx;
    }

    $self->{'output_to_stdout'} = 1  if  $self->opt_T or ! -t STDOUT;

    $self->options_sanity;

    $self->opt_n("nroff") unless $self->opt_n;
    $self->add_formatter_option( '__nroffer' => $self->opt_n );

    # Adjust for using translation packages
    $self->add_translator($self->opt_L) if $self->opt_L;

    return;
}

#..........................................................................

sub options_sanity {
    my $self = shift;

    # The opts-counting stuff interacts quite badly with
    # the $ENV{"PERLDOC"} stuff.  I.e., if I have $ENV{"PERLDOC"}
    # set to -t, and I specify -u on the command line, I don't want
    # to be hectored at that -u and -t don't make sense together.

    #my $opts = grep $_ && 1, # yes, the count of the set ones
    #  $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
    #;
    #
    #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
    
    
    # Any sanity-checking need doing here?
    
    # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} 
    if( $self->opt_f or $self->opt_q ) { 
	$self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
	warn 
	    "Perldoc is only really meant for reading one word at a time.\n",
	    "So these parameters are being ignored: ",
	    join(' ', @{$self->{'args'}}),
	    "\n"
		if @{$self->{'args'}}
    }
    return;
}

#..........................................................................

sub grand_search_init {
    my($self, $pages, @found) = @_;

    foreach (@$pages) {
        if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
            my $searchfor = catfile split '::', $_;
            $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
            local $_;
            while (<PODIDX>) {
                chomp;
                push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
            }
            close(PODIDX)            or die "Can't close $$self{'podidx'}: $!";
            next;
        }

        $self->aside( "Searching for $_\n" );

        if ($self->opt_F) {
            next unless -r;
            push @found, $_ if $self->opt_m or $self->containspod($_);
            next;
        }

        my @searchdirs;

        # prepend extra search directories (including language specific)
        push @searchdirs, @{ $self->{'extra_search_dirs'} };

        # We must look both in @INC for library modules and in $bindir
        # for executables, like h2xs or perldoc itself.
        push @searchdirs, ($self->{'bindir'}, @INC);
        unless ($self->opt_m) {
            if (IS_VMS) {
                my($i,$trn);
                for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
                    push(@searchdirs,$trn);
                }
                push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
            }
            else {
                push(@searchdirs, grep(-d, split($Config{path_sep},
                                                 $ENV{'PATH'})));
            }
        }
        my @files = $self->searchfor(0,$_,@searchdirs);
        if (@files) {
            $self->aside( "Found as @files\n" );
        }
        else {
            # no match, try recursive search
            @searchdirs = grep(!/^\.\z/s,@INC);
            @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
            if (@files) {
                $self->aside( "Loosely found as @files\n" );
            }
            else {
                print STDERR "No " .
                    ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
                if ( @{ $self->{'found'} } ) {
                    print STDERR "However, try\n";
                    for my $dir (@{ $self->{'found'} }) {
                        opendir(DIR, $dir) or die "opendir $dir: $!";
                        while (my $file = readdir(DIR)) {
                            next if ($file =~ /^\./s);
                            $file =~ s/\.(pm|pod)\z//;  # XXX: badfs
                            print STDERR "\tperldoc $_\::$file\n";
                        }
                        closedir(DIR)    or die "closedir $dir: $!";
                    }
                }
            }
        }
        push(@found,@files);
    }
    return @found;
}

#..........................................................................

sub maybe_generate_dynamic_pod {
    my($self, $found_things) = @_;
    my @dynamic_pod;
    
    $self->search_perlfunc($found_things, \@dynamic_pod)  if  $self->opt_f;
    
    $self->search_perlfaqs($found_things, \@dynamic_pod)  if  $self->opt_q;

    if( ! $self->opt_f and ! $self->opt_q ) {
        DEBUG > 4 and print "That's a non-dynamic pod search.\n";
    } elsif ( @dynamic_pod ) {
        $self->aside("Hm, I found some Pod from that search!\n");
        my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
        
        push @{ $self->{'temp_file_list'} }, $buffer;
         # I.e., it MIGHT be deleted at the end.
        
	my $in_list = $self->opt_f;

        print $buffd "=over 8\n\n" if $in_list;
        print $buffd @dynamic_pod  or die "Can't print $buffer: $!";
        print $buffd "=back\n"     if $in_list;

        close $buffd        or die "Can't close $buffer: $!";
        
        @$found_things = $buffer;
          # Yes, so found_things never has more than one thing in
          #  it, by time we leave here
        
        $self->add_formatter_option('__filter_nroff' => 1);

    } else {
        @$found_things = ();
        $self->aside("I found no Pod from that search!\n");
    }

    return;
}

#..........................................................................

sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
  my $self = shift;
  push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;

  DEBUG > 3 and printf "Formatter switches now: [%s]\n",
   join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  
  return;
}

#.........................................................................

sub pod_dirs { # @dirs = pod_dirs($translator);
    my $tr = shift;
    return $tr->pod_dirs if $tr->can('pod_dirs');
    
    my $mod = ref $tr || $tr;
    $mod =~ s|::|/|g;
    $mod .= '.pm';

    my $dir = $INC{$mod};
    $dir =~ s/\.pm\z//;
    return $dir;
}

#.........................................................................

sub add_translator { # $self->add_translator($lang);
    my $self = shift;
    for my $lang (@_) {
        my $pack = 'POD2::' . uc($lang);
        eval "require $pack";
        if ( $@ ) {
            # XXX warn: non-installed translator package
        } else {
            push @{ $self->{'translators'} }, $pack;
            push @{ $self->{'extra_search_dirs'} }, pod_dirs($pack);
            # XXX DEBUG
        }
    }
    return;
}

#..........................................................................

sub search_perlfunc {
    my($self, $found_things, $pod) = @_;

    DEBUG > 2 and print "Search: @$found_things\n";

    my $perlfunc = shift @$found_things;
    open(PFUNC, "<", $perlfunc)               # "Funk is its own reward"
        or die("Can't open $perlfunc: $!");

    # Functions like -r, -e, etc. are listed under `-X'.
    my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
                        ? '(?:I<)?-X' : quotemeta($self->opt_f) ;

    DEBUG > 2 and
     print "Going to perlfunc-scan for $search_re in $perlfunc\n";

    my $re = 'Alphabetical Listing of Perl Functions';
    if ( $self->opt_L ) {
        my $tr = $self->{'translators'}->[0];
        $re =  $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
    }

    # Skip introduction
    local $_;
    while (<PFUNC>) {
        last if /^=head2 $re/;
    }

    # Look for our function
    my $found = 0;
    my $inlist = 0;
    while (<PFUNC>) {  # "The Mothership Connection is here!"
        if ( m/^=item\s+$search_re\b/ )  {
            $found = 1;
        }
        elsif (/^=item/) {
            last if $found > 1 and not $inlist;
        }
        next unless $found;
        if (/^=over/) {
            ++$inlist;
        }
        elsif (/^=back/) {
            --$inlist;
        }
        push @$pod, $_;
        ++$found if /^\w/;        # found descriptive text
    }
    if (!@$pod) {
        die sprintf
          "No documentation for perl function `%s' found\n",
          $self->opt_f
        ;