perldoc.pm

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

    }
    close PFUNC                or die "Can't open $perlfunc: $!";

    return;
}

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

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

    my $found = 0;
    my %found_in;
    my $search_key = $self->opt_q;
    
    my $rx = eval { qr/$search_key/ }
     or die <<EOD;
Invalid regular expression '$search_key' given as -q pattern:
$@
Did you mean \\Q$search_key ?

EOD

    local $_;
    foreach my $file (@$found_things) {
        die "invalid file spec: $!" if $file =~ /[<>|]/;
        open(INFAQ, "<", $file)  # XXX 5.6ism
         or die "Can't read-open $file: $!\nAborting";
        while (<INFAQ>) {
            if ( m/^=head2\s+.*(?:$search_key)/i ) {
                $found = 1;
                push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
            }
            elsif (/^=head[12]/) {
                $found = 0;
            }
            next unless $found;
            push @$pod, $_;
        }
        close(INFAQ);
    }
    die("No documentation for perl FAQ keyword `$search_key' found\n")
     unless @$pod;

    return;
}


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

sub render_findings {
  # Return the filename to open

  my($self, $found_things) = @_;

  my $formatter_class = $self->{'formatter_class'}
   || die "No formatter class set!?";
  my $formatter = $formatter_class->can('new')
    ? $formatter_class->new
    : $formatter_class
  ;

  if(! @$found_things) {
    die "Nothing found?!";
    # should have been caught before here
  } elsif(@$found_things > 1) {
    warn 
     "Perldoc is only really meant for reading one document at a time.\n",
     "So these parameters are being ignored: ",
     join(' ', @$found_things[1 .. $#$found_things] ),
     "\n"
  }

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

  # Set formatter options:
  if( ref $formatter ) {
    foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
      my($switch, $value, $silent_fail) = @$f;
      if( $formatter->can($switch) ) {
        eval { $formatter->$switch( defined($value) ? $value : () ) };
        warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
         if $@;
      } else {
        if( $silent_fail or $switch =~ m/^__/s ) {
          DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
        } else {
          warn "$formatter_class doesn't recognize the $switch switch.\n";
        }
      }
    }
  }
  
  $self->{'output_is_binary'} =
    $formatter->can('write_with_binmode') && $formatter->write_with_binmode;

  my ($out_fh, $out) = $self->new_output_file(
    ( $formatter->can('output_extension') && $formatter->output_extension )
     || undef,
    $self->useful_filename_bit,
  );

  # Now, finally, do the formatting!
  {
    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 formatting!
    }
          
    eval {  $formatter->parse_from_file( $file, $out_fh )  };
  }
  
  warn "Error while formatting with $formatter_class:\n $@\n" if $@;
  DEBUG > 2 and print "Back from formatting with $formatter_class\n";

  close $out_fh 
   or warn "Can't close $out: $!\n(Did $formatter already close it?)";
  sleep 0; sleep 0; sleep 0;
   # Give the system a few timeslices to meditate on the fact
   # that the output file does in fact exist and is closed.
  
  $self->unlink_if_temp_file($file);

  unless( -s $out ) {
    if( $formatter->can( 'if_zero_length' ) ) {
      # Basically this is just a hook for Pod::Simple::Checker; since
      # what other class could /happily/ format an input file with Pod
      # as a 0-length output file?
      $formatter->if_zero_length( $file, $out, $out_fh );
    } else {
      warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
    }
  }

  DEBUG and print "Finished writing to $out.\n";
  return($out, $formatter) if wantarray;
  return $out;
}

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

sub unlink_if_temp_file {
  # Unlink the specified file IFF it's in the list of temp files.
  # Really only used in the case of -f / -q things when we can
  #  throw away the dynamically generated source pod file once
  #  we've formatted it.
  #
  my($self, $file) = @_;
  return unless defined $file and length $file;
  
  my $temp_file_list = $self->{'temp_file_list'} || return;
  if(grep $_ eq $file, @$temp_file_list) {
    $self->aside("Unlinking $file\n");
    unlink($file) or warn "Odd, couldn't unlink $file: $!";
  } else {
    DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
  }
  return;
}

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

sub MSWin_temp_cleanup {

  # Nothing particularly MSWin-specific in here, but I don't know if any
  # other OS needs its temp dir policed like MSWin does!
 
  my $self = shift;

  my $tempdir = $ENV{'TEMP'};
  return unless defined $tempdir and length $tempdir
   and -e $tempdir and -d _ and -w _;

  $self->aside(
   "Considering whether any old files of mine in $tempdir need unlinking.\n"
  );

  opendir(TMPDIR, $tempdir) || return;
  my @to_unlink;
  
  my $limit = time() - $Temp_File_Lifetime;
  
  DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
   ($limit) x 2;
  
  my $filespec;
  
  while(defined($filespec = readdir(TMPDIR))) {
    if(
     $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
    ) {
      if( hex($1) < $limit ) {
        push @to_unlink, "$tempdir/$filespec";
        $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
      } else {
        DEBUG > 5 and
         printf "  $tempdir/$filespec is too recent (after %x)\n", $limit;
      }
    } else {
      DEBUG > 5 and
       print "  $tempdir/$filespec doesn't look like a perldoc temp file.\n";
    }
  }
  closedir(TMPDIR);
  $self->aside(sprintf "Unlinked %s items of mine in %s\n",
    scalar(unlink(@to_unlink)),
    $tempdir
  );
  return;
}

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

sub MSWin_perldoc_tempfile {
  my($self, $suffix, $infix) = @_;

  my $tempdir = $ENV{'TEMP'};
  return unless defined $tempdir and length $tempdir
   and -e $tempdir and -d _ and -w _;

  my $spec;
  
  do {
    $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
      # Yes, we embed the create-time in the filename!
      $tempdir,
      $infix || 'x',
      time(),
      $$,
      defined( &Win32::GetTickCount )
        ? (Win32::GetTickCount() & 0xff)
        : int(rand 256)
       # Under MSWin, $$ values get reused quickly!  So if we ran
       # perldoc foo and then perldoc bar before there was time for
       # time() to increment time."_$$" would likely be the same
       # for each process!  So we tack on the tick count's lower
       # bits (or, in a pinch, rand)
      ,
      $suffix || 'txt';
    ;
  } while( -e $spec );

  my $counter = 0;
  
  while($counter < 50) {
    my $fh;
    # If we are running before perl5.6.0, we can't autovivify
    if ($] < 5.006) {
      require Symbol;
      $fh = Symbol::gensym();
    }
    DEBUG > 3 and print "About to try making temp file $spec\n";
    return($fh, $spec) if open($fh, ">", $spec);    # XXX 5.6ism
    $self->aside("Can't create temp file $spec: $!\n");
  }

  $self->aside("Giving up on making a temp file!\n");
  die "Can't make a tempfile!?";
}

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


sub after_rendering {
  my $self = $_[0];
  $self->after_rendering_VMS     if IS_VMS;
  $self->after_rendering_MSWin32 if IS_MSWin32;
  $self->after_rendering_Dos     if IS_Dos;
  $self->after_rendering_OS2     if IS_OS2;
  return;
}

sub after_rendering_VMS      { return }
sub after_rendering_Dos      { return }
sub after_rendering_OS2      { return }

sub after_rendering_MSWin32  {
  shift->MSWin_temp_cleanup() if $Temp_Files_Created;
}

#..........................................................................
#	:	:	:	:	:	:	:	:	:
#..........................................................................


sub minus_f_nocase {   # i.e., do like -f, but without regard to case

     my($self, $dir, $file) = @_;
     my $path = catfile($dir,$file);
     return $path if -f $path and -r _;

     if(!$self->opt_i
        or IS_VMS or IS_MSWin32
        or IS_Dos or IS_OS2
     ) {
        # On a case-forgiving file system, or if case is important,
	#  that is it, all we can do.
	warn "Ignored $path: unreadable\n" if -f _;
	return '';
     }
     
     local *DIR;
     my @p = ($dir);
     my($p,$cip);
     foreach $p (splitdir $file){
	my $try = catfile @p, $p;
        $self->aside("Scrutinizing $try...\n");
	stat $try;
 	if (-d _) {
 	    push @p, $p;
	    if ( $p eq $self->{'target'} ) {
		my $tmp_path = catfile @p;
		my $path_f = 0;
		for (@{ $self->{'found'} }) {
		    $path_f = 1 if $_ eq $tmp_path;
		}
		push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
		$self->aside( "Found as $tmp_path but directory\n" );
	    }
 	}
	elsif (-f _ && -r _) {
 	    return $try;
 	}
	elsif (-f _) {
	    warn "Ignored $try: unreadable\n";
 	}
	elsif (-d catdir(@p)) {  # at least we see the containing directory!
 	    my $found = 0;
 	    my $lcp = lc $p;
 	    my $p_dirspec = catdir(@p);
 	    opendir DIR, $p_dirspec  or die "opendir $p_dirspec: $!";
 	    while(defined( $cip = readdir(DIR) )) {
 		if (lc $cip eq $lcp){
 		    $found++;
 		    last; # XXX stop at the first? what if there's others?
 		}
 	    }
 	    closedir DIR  or die "closedir $p_dirspec: $!";
 	    return "" unless $found;

 	    push @p, $cip;
 	    my $p_filespec = catfile(@p);
 	    return $p_filespec if -f $p_filespec and -r _;
	    warn "Ignored $p_filespec: unreadable\n" if -f _;
 	}
     }
     return "";
}

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

sub pagers_guessing {
    my $self = shift;

    my @pagers;
    push @pagers, $self->pagers;
    $self->{'pagers'} = \@pagers;

    if (IS_MSWin32) {
        push @pagers, qw( more< less notepad );
        unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
    }
    elsif (IS_VMS) {
        push @pagers, qw( most more less type/page );
    }
    elsif (IS_Dos) {
        push @pagers, qw( less.exe more.com< );
        unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
    }
    else {
        if (IS_OS2) {
          unshift @pagers, 'less', 'cmd /c more <';
        }
        push @pagers, qw( more less pg view cat );
        unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
    }

    if (IS_Cygwin) {
        if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
            unshift @pagers, '/usr/bin/less -isrR';
        }
    }

    unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
    
    return;   
}

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

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

    # Security note:
    # Don't ever just pass this off to anything like MSWin's "start.exe",
    # since we might be calling on a .pl file, and we wouldn't want that
    # to actually /execute/ the file that we just want to page thru!
    # Also a consideration if one were to use a web browser as a pager;
    # doing so could trigger the browser's MIME mapping for whatever
    # it thinks .pm/.pl/whatever is.  Probably just a (useless and
    # annoying) "Save as..." dialog, but potentially executing the file
    # in question -- particularly in the case of MSIE and it's, ahem,
    # occasionally hazy distinction between OS-local extension
    # associations, and browser-specific MIME mappings.

    if ($self->{'output_to_stdout'}) {
        $self->aside("Sending unpaged output to STDOUT.\n");
	local $_;
	my $any_error = 0;
        foreach my $output (@found) {
	    unless( open(TMP, "<", $output) ) {    # XXX 5.6ism
	      warn("Can't open $output: $!");
	      $any_error = 1;
	      next;
	    }
	    while (<TMP>) {
	        print or die "Can't print to stdout: $!";
	    } 
	    close TMP  or die "Can't close while $output: $!";
	    $self->unlink_if_temp_file($output);
	}
	return $any_error; # successful
    }

    foreach my $pager ( $self->pagers ) {
        $self->aside("About to try calling $pager @found\n");
        if (system($pager, @found) == 0) {
            $self->aside("Yay, it worked.\n");
            return 0;
        }
        $self->aside("That didn't work.\n");
        
        # Odd -- when it fails, under Win32, this seems to neither
        #  return with a fail nor return with a success!!
        #  That's discouraging!
    }

    $self->aside(
      sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
      join(' ', @found),
      join(' ', $self->pagers),
    );
    
    if (IS_VMS) { 
        DEBUG > 1 and print "Bailing out in a VMSish way.\n";
        eval q{
            use vmsish qw(status exit); 
            exit $?;
            1;