perldoc.pm

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

require 5;
use 5.006;  # we use some open(X, "<", $y) syntax 
package Pod::Perldoc;
use strict;
use warnings;
use Config '%Config';

use Fcntl;    # for sysopen
use File::Spec::Functions qw(catfile catdir splitdir);

use vars qw($VERSION @Pagers $Bindir $Pod2man
  $Temp_Files_Created $Temp_File_Lifetime
);
$VERSION = '3.14_02';
#..........................................................................

BEGIN {  # Make a DEBUG constant very first thing...
  unless(defined &DEBUG) {
    if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
      eval("sub DEBUG () {$1}");
      die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
    } else {
      *DEBUG = sub () {0};
    }
  }
}

use Pod::Perldoc::GetOptsOO; # uses the DEBUG.

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

sub TRUE  () {1}
sub FALSE () {return}

BEGIN {
 *IS_VMS     = $^O eq 'VMS'     ? \&TRUE : \&FALSE unless defined &IS_VMS;
 *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
 *IS_Dos     = $^O eq 'dos'     ? \&TRUE : \&FALSE unless defined &IS_Dos;
 *IS_OS2     = $^O eq 'os2'     ? \&TRUE : \&FALSE unless defined &IS_OS2;
 *IS_Cygwin  = $^O eq 'cygwin'  ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
 *IS_Linux   = $^O eq 'linux'   ? \&TRUE : \&FALSE unless defined &IS_Linux;
 *IS_HPUX    = $^O =~ m/hpux/   ? \&TRUE : \&FALSE unless defined &IS_HPUX;
}

$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
  # If it's older than five days, it's quite unlikely
  #  that anyone's still looking at it!!
  # (Currently used only by the MSWin cleanup routine)


#..........................................................................
{ my $pager = $Config{'pager'};
  push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
}
$Bindir  = $Config{'scriptdirexp'};
$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );

# End of class-init stuff
#
###########################################################################
#
# Option accessors...

foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdUL}) {
  no strict 'refs';
  *$subname = do{ use strict 'refs';  sub () { shift->_elem($subname, @_) } };
}

# And these are so that GetOptsOO knows they take options:
sub opt_f_with { shift->_elem('opt_f', @_) }
sub opt_q_with { shift->_elem('opt_q', @_) }
sub opt_d_with { shift->_elem('opt_d', @_) }
sub opt_L_with { shift->_elem('opt_L', @_) }

sub opt_w_with { # Specify an option for the formatter subclass
  my($self, $value) = @_;
  if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
    my $option = $1;
    my $option_value = defined($2) ? $2 : "TRUE";
    $option =~ tr/\-/_/s;  # tolerate "foo-bar" for "foo_bar"
    $self->add_formatter_option( $option, $option_value );
  } else {
    warn "\"$value\" isn't a good formatter option name.  I'm ignoring it!\n";
  }
  return;
}

sub opt_M_with { # specify formatter class name(s)
  my($self, $classes) = @_;
  return unless defined $classes and length $classes;
  DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
  my @classes_to_add;
  foreach my $classname (split m/[,;]+/s, $classes) {
    next unless $classname =~ m/\S/;
    if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
      # A mildly restrictive concept of what modulenames are valid.
      push @classes_to_add, $1; # untaint
    } else {
      warn "\"$classname\" isn't a valid classname.  Ignoring.\n";
    }
  }
  
  unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
  
  DEBUG > 3 and print(
    "Adding @classes_to_add to the list of formatter classes, "
    . "making them @{ $self->{'formatter_classes'} }.\n"
  );
  
  return;
}

sub opt_V { # report version and exit
  print join '',
    "Perldoc v$VERSION, under perl v$] for $^O",

    (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
     ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
    
    (chr(65) eq 'A') ? () : " (non-ASCII)",
    
    "\n",
  ;
  exit;
}

sub opt_t { # choose plaintext as output format
  my $self = shift;
  $self->opt_o_with('text')  if @_ and $_[0];
  return $self->_elem('opt_t', @_);
}

sub opt_u { # choose raw pod as output format
  my $self = shift;
  $self->opt_o_with('pod')  if @_ and $_[0];
  return $self->_elem('opt_u', @_);
}

sub opt_n_with {
  # choose man as the output format, and specify the proggy to run
  my $self = shift;
  $self->opt_o_with('man')  if @_ and $_[0];
  $self->_elem('opt_n', @_);
}

sub opt_o_with { # "o" for output format
  my($self, $rest) = @_;
  return unless defined $rest and length $rest;
  if($rest =~ m/^(\w+)$/s) {
    $rest = $1; #untaint
  } else {
    warn "\"$rest\" isn't a valid output format.  Skipping.\n";
    return;
  }
  
  $self->aside("Noting \"$rest\" as desired output format...\n");
  
  # Figure out what class(es) that could actually mean...
  
  my @classes;
  foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
    # Messy but smart:
    foreach my $stem (
      $rest,  # Yes, try it first with the given capitalization
      "\L$rest", "\L\u$rest", "\U$rest" # And then try variations

    ) {
      push @classes, $prefix . $stem;
      #print "Considering $prefix$stem\n";
    }
    
    # Tidier, but misses too much:
    #push @classes, $prefix . ucfirst(lc($rest));
  }
  $self->opt_M_with( join ";", @classes );
  return;
}

###########################################################################
# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %

sub run {  # to be called by the "perldoc" executable
  my $class = shift;
  if(DEBUG > 3) {
    print "Parameters to $class\->run:\n";
    my @x = @_;
    while(@x) {
      $x[1] = '<undef>'  unless defined $x[1];
      $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
      print "  [$x[0]] => [$x[1]]\n";
      splice @x,0,2;
    }
    print "\n";
  }
  return $class -> new(@_) -> process() || 0;
}

# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
###########################################################################

sub new {  # yeah, nothing fancy
  my $class = shift;
  my $new = bless {@_}, (ref($class) || $class);
  DEBUG > 1 and print "New $class object $new\n";
  $new->init();
  $new;
}

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

sub aside {  # If we're in -v or DEBUG mode, say this.
  my $self = shift;
  if( DEBUG or $self->opt_v ) {
    my $out = join( '',
      DEBUG ? do {
        my $callsub = (caller(1))[3];
        my $package = quotemeta(__PACKAGE__ . '::');
        $callsub =~ s/^$package/'/os;
         # the o is justified, as $package really won't change.
        $callsub . ": ";
      } : '',
      @_,
    );
    if(DEBUG) { print $out } else { print STDERR $out }
  }
  return;
}

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

sub usage {
  my $self = shift;
  warn "@_\n" if @_;
  
  # Erase evidence of previous errors (if any), so exit status is simple.
  $! = 0;
  
  die <<EOF;
perldoc [options] PageName|ModuleName|ProgramName...
perldoc [options] -f BuiltinFunction
perldoc [options] -q FAQRegex

Options:
    -h   Display this help message
    -V   report version
    -r   Recursive search (slow)
    -i   Ignore case
    -t   Display pod using pod2text instead of pod2man and nroff
             (-t is the default on win32 unless -n is specified)
    -u   Display unformatted pod text
    -m   Display module's file in its entirety
    -n   Specify replacement for nroff
    -l   Display the module's file name
    -F   Arguments are file names, not modules
    -v   Verbosely describe what's going on
    -T   Send output to STDOUT without any pager
    -d output_filename_to_send_to
    -o output_format_name
    -M FormatterModuleNameToUse
    -w formatter_option:option_value
    -L translation_code   Choose doc translation (if any)
    -X   use index if present (looks for pod.idx at $Config{archlib})
    -q   Search the text of questions (not answers) in perlfaq[1-9]

PageName|ModuleName...
         is the name of a piece of documentation that you want to look at. You
         may either give a descriptive name of the page (as in the case of
         `perlfunc') the name of a module, either like `Term::Info' or like
         `Term/Info', or the name of a program, like `perldoc'.

BuiltinFunction
         is the name of a perl function.  Will extract documentation from
         `perlfunc'.

FAQRegex
         is a regex. Will search perlfaq[1-9] for and extract any
         questions that match.

Any switches in the PERLDOC environment variable will be used before the
command line arguments.  The optional pod index file contains a list of
filenames, one per line.
                                                       [Perldoc v$VERSION]
EOF

}

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

sub usage_brief {
  my $me = $0;		# Editing $0 is unportable

  $me =~ s,.*[/\\],,; # get basename
  
  die <<"EOUSAGE";
Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
       $me -f PerlFunc
       $me -q FAQKeywords

The -h option prints more help.  Also try "perldoc perldoc" to get
acquainted with the system.                        [Perldoc v$VERSION]
EOUSAGE

}

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

sub pagers { @{ shift->{'pagers'} } } 

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

sub _elem {  # handy scalar meta-accessor: shift->_elem("foo", @_)
  if(@_ > 2) { return  $_[0]{ $_[1] } = $_[2]  }
  else       { return  $_[0]{ $_[1] }          }
}
#..........................................................................
###########################################################################
#
# Init formatter switches, and start it off with __bindir and all that
# other stuff that ToMan.pm needs.
#

sub init {
  my $self = shift;

  # Make sure creat()s are neither too much nor too little
  eval { umask(0077) };   # doubtless someone has no mask

  $self->{'args'}              ||= \@ARGV;
  $self->{'found'}             ||= [];
  $self->{'temp_file_list'}    ||= [];
  
  
  $self->{'target'} = undef;

  $self->init_formatter_class_list;

  $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
  $self->{'bindir' } = $Bindir   unless exists $self->{'bindir'};
  $self->{'pod2man'} = $Pod2man  unless exists $self->{'pod2man'};

  push @{ $self->{'formatter_switches'} = [] }, (
   # Yeah, we could use a hashref, but maybe there's some class where options
   # have to be ordered; so we'll use an arrayref.

     [ '__bindir'  => $self->{'bindir' } ],
     [ '__pod2man' => $self->{'pod2man'} ],
  );

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

  $self->{'translators'} = [];
  $self->{'extra_search_dirs'} = [];

  return;
}

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

sub init_formatter_class_list {
  my $self = shift;
  $self->{'formatter_classes'} ||= [];

  # Remember, no switches have been read yet, when
  # we've started this routine.

  $self->opt_M_with('Pod::Perldoc::ToPod');   # the always-there fallthru
  $self->opt_o_with('text');
  $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
       || !($ENV{TERM} && (
              ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
           ));

  return;
}

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

sub process {
    # if this ever returns, its retval will be used for exit(RETVAL)

    my $self = shift;
    DEBUG > 1 and print "  Beginning process.\n";
    DEBUG > 1 and print "  Args: @{$self->{'args'}}\n\n";
    if(DEBUG > 3) {
        print "Object contents:\n";
        my @x = %$self;
        while(@x) {
            $x[1] = '<undef>'  unless defined $x[1];
            $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
            print "  [$x[0]] => [$x[1]]\n";
            splice @x,0,2;
        }
        print "\n";
    }

    # TODO: make it deal with being invoked as various different things
    #  such as perlfaq".
  
    return $self->usage_brief  unless  @{ $self->{'args'} };
    $self->pagers_guessing;
    $self->options_reading;
    $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
    $self->drop_privs_maybe;
    $self->options_processing;
    
    # Hm, we have @pages and @found, but we only really act on one
    # file per call, with the exception of the opt_q hack, and with
    # -l things

    $self->aside("\n");

    my @pages;
    $self->{'pages'} = \@pages;
    if(    $self->opt_f) { @pages = ("perlfunc")               }
    elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
    else                 { @pages = @{$self->{'args'}};
                           # @pages = __FILE__
                           #  if @pages == 1 and $pages[0] eq 'perldoc';
                         }

    return $self->usage_brief  unless  @pages;

    $self->find_good_formatter_class();
    $self->formatter_sanity_check();

    $self->maybe_diddle_INC();
      # for when we're apparently in a module or extension directory
    
    my @found = $self->grand_search_init(\@pages);
    exit (IS_VMS ? 98962 : 1) unless @found;
    
    if ($self->opt_l) {
        DEBUG and print "We're in -l mode, so byebye after this:\n";
        print join("\n", @found), "\n";
        return;
    }

    $self->tweak_found_pathnames(\@found);
    $self->assert_closing_stdout;
    return $self->page_module_file(@found)  if  $self->opt_m;
    DEBUG > 2 and print "Found: [@found]\n";

    return $self->render_and_page(\@found);
}

#..........................................................................
{

my( %class_seen, %class_loaded );
sub find_good_formatter_class {
  my $self = $_[0];
  my @class_list = @{ $self->{'formatter_classes'} || [] };
  die "WHAT?  Nothing in the formatter class list!?" unless @class_list;