home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Perldoc.pm < prev    next >
Text File  |  2005-01-27  |  53KB  |  1,749 lines
  1.  
  2. require 5;
  3. use 5.006;  # we use some open(X, "<", $y) syntax 
  4. package Pod::Perldoc;
  5. use strict;
  6. use warnings;
  7. use Config '%Config';
  8.  
  9. use Fcntl;    # for sysopen
  10. use File::Spec::Functions qw(catfile catdir splitdir);
  11.  
  12. use vars qw($VERSION @Pagers $Bindir $Pod2man
  13.   $Temp_Files_Created $Temp_File_Lifetime
  14. );
  15. $VERSION = '3.13';
  16. #..........................................................................
  17.  
  18. BEGIN {  # Make a DEBUG constant very first thing...
  19.   unless(defined &DEBUG) {
  20.     if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
  21.       eval("sub DEBUG () {$1}");
  22.       die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
  23.     } else {
  24.       *DEBUG = sub () {0};
  25.     }
  26.   }
  27. }
  28.  
  29. use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
  30.  
  31. #..........................................................................
  32.  
  33. sub TRUE  () {1}
  34. sub FALSE () {return}
  35.  
  36. BEGIN {
  37.  *IS_VMS     = $^O eq 'VMS'     ? \&TRUE : \&FALSE unless defined &IS_VMS;
  38.  *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
  39.  *IS_Dos     = $^O eq 'dos'     ? \&TRUE : \&FALSE unless defined &IS_Dos;
  40.  *IS_OS2     = $^O eq 'os2'     ? \&TRUE : \&FALSE unless defined &IS_OS2;
  41.  *IS_Cygwin  = $^O eq 'cygwin'  ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
  42.  *IS_Linux   = $^O eq 'linux'   ? \&TRUE : \&FALSE unless defined &IS_Linux;
  43.  *IS_HPUX    = $^O =~ m/hpux/   ? \&TRUE : \&FALSE unless defined &IS_HPUX;
  44. }
  45.  
  46. $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
  47.   # If it's older than five days, it's quite unlikely
  48.   #  that anyone's still looking at it!!
  49.   # (Currently used only by the MSWin cleanup routine)
  50.  
  51.  
  52. #..........................................................................
  53. { my $pager = $Config{'pager'};
  54.   push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
  55. }
  56. $Bindir  = $Config{'scriptdirexp'};
  57. $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
  58.  
  59. # End of class-init stuff
  60. #
  61. ###########################################################################
  62. #
  63. # Option accessors...
  64.  
  65. foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) {
  66.   no strict 'refs';
  67.   *$subname = do{ use strict 'refs';  sub () { shift->_elem($subname, @_) } };
  68. }
  69.  
  70. # And these are so that GetOptsOO knows they take options:
  71. sub opt_f_with { shift->_elem('opt_f', @_) }
  72. sub opt_q_with { shift->_elem('opt_q', @_) }
  73. sub opt_d_with { shift->_elem('opt_d', @_) }
  74.  
  75. sub opt_w_with { # Specify an option for the formatter subclass
  76.   my($self, $value) = @_;
  77.   if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
  78.     my $option = $1;
  79.     my $option_value = defined($2) ? $2 : "TRUE";
  80.     $option =~ tr/\-/_/s;  # tolerate "foo-bar" for "foo_bar"
  81.     $self->add_formatter_option( $option, $option_value );
  82.   } else {
  83.     warn "\"$value\" isn't a good formatter option name.  I'm ignoring it!\n";
  84.   }
  85.   return;
  86. }
  87.  
  88. sub opt_M_with { # specify formatter class name(s)
  89.   my($self, $classes) = @_;
  90.   return unless defined $classes and length $classes;
  91.   DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
  92.   my @classes_to_add;
  93.   foreach my $classname (split m/[,;]+/s, $classes) {
  94.     next unless $classname =~ m/\S/;
  95.     if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
  96.       # A mildly restrictive concept of what modulenames are valid.
  97.       push @classes_to_add, $1; # untaint
  98.     } else {
  99.       warn "\"$classname\" isn't a valid classname.  Ignoring.\n";
  100.     }
  101.   }
  102.   
  103.   unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
  104.   
  105.   DEBUG > 3 and print(
  106.     "Adding @classes_to_add to the list of formatter classes, "
  107.     . "making them @{ $self->{'formatter_classes'} }.\n"
  108.   );
  109.   
  110.   return;
  111. }
  112.  
  113. sub opt_V { # report version and exit
  114.   print join '',
  115.     "Perldoc v$VERSION, under perl v$] for $^O",
  116.  
  117.     (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
  118.      ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
  119.     
  120.     (chr(65) eq 'A') ? () : " (non-ASCII)",
  121.     
  122.     "\n",
  123.   ;
  124.   exit;
  125. }
  126.  
  127. sub opt_t { # choose plaintext as output format
  128.   my $self = shift;
  129.   $self->opt_o_with('text')  if @_ and $_[0];
  130.   return $self->_elem('opt_t', @_);
  131. }
  132.  
  133. sub opt_u { # choose raw pod as output format
  134.   my $self = shift;
  135.   $self->opt_o_with('pod')  if @_ and $_[0];
  136.   return $self->_elem('opt_u', @_);
  137. }
  138.  
  139. sub opt_n_with {
  140.   # choose man as the output format, and specify the proggy to run
  141.   my $self = shift;
  142.   $self->opt_o_with('man')  if @_ and $_[0];
  143.   $self->_elem('opt_n', @_);
  144. }
  145.  
  146. sub opt_o_with { # "o" for output format
  147.   my($self, $rest) = @_;
  148.   return unless defined $rest and length $rest;
  149.   if($rest =~ m/^(\w+)$/s) {
  150.     $rest = $1; #untaint
  151.   } else {
  152.     warn "\"$rest\" isn't a valid output format.  Skipping.\n";
  153.     return;
  154.   }
  155.   
  156.   $self->aside("Noting \"$rest\" as desired output format...\n");
  157.   
  158.   # Figure out what class(es) that could actually mean...
  159.   
  160.   my @classes;
  161.   foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
  162.     # Messy but smart:
  163.     foreach my $stem (
  164.       $rest,  # Yes, try it first with the given capitalization
  165.       "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
  166.  
  167.     ) {
  168.       push @classes, $prefix . $stem;
  169.       #print "Considering $prefix$stem\n";
  170.     }
  171.     
  172.     # Tidier, but misses too much:
  173.     #push @classes, $prefix . ucfirst(lc($rest));
  174.   }
  175.   $self->opt_M_with( join ";", @classes );
  176.   return;
  177. }
  178.  
  179. ###########################################################################
  180. # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
  181.  
  182. sub run {  # to be called by the "perldoc" executable
  183.   my $class = shift;
  184.   if(DEBUG > 3) {
  185.     print "Parameters to $class\->run:\n";
  186.     my @x = @_;
  187.     while(@x) {
  188.       $x[1] = '<undef>'  unless defined $x[1];
  189.       $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
  190.       print "  [$x[0]] => [$x[1]]\n";
  191.       splice @x,0,2;
  192.     }
  193.     print "\n";
  194.   }
  195.   return $class -> new(@_) -> process() || 0;
  196. }
  197.  
  198. # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
  199. ###########################################################################
  200.  
  201. sub new {  # yeah, nothing fancy
  202.   my $class = shift;
  203.   my $new = bless {@_}, (ref($class) || $class);
  204.   DEBUG > 1 and print "New $class object $new\n";
  205.   $new->init();
  206.   $new;
  207. }
  208.  
  209. #..........................................................................
  210.  
  211. sub aside {  # If we're in -v or DEBUG mode, say this.
  212.   my $self = shift;
  213.   if( DEBUG or $self->opt_v ) {
  214.     my $out = join( '',
  215.       DEBUG ? do {
  216.         my $callsub = (caller(1))[3];
  217.         my $package = quotemeta(__PACKAGE__ . '::');
  218.         $callsub =~ s/^$package/'/os;
  219.          # the o is justified, as $package really won't change.
  220.         $callsub . ": ";
  221.       } : '',
  222.       @_,
  223.     );
  224.     if(DEBUG) { print $out } else { print STDERR $out }
  225.   }
  226.   return;
  227. }
  228.  
  229. #..........................................................................
  230.  
  231. sub usage {
  232.   my $self = shift;
  233.   warn "@_\n" if @_;
  234.   
  235.   # Erase evidence of previous errors (if any), so exit status is simple.
  236.   $! = 0;
  237.   
  238.   die <<EOF;
  239. perldoc [options] PageName|ModuleName|ProgramName...
  240. perldoc [options] -f BuiltinFunction
  241. perldoc [options] -q FAQRegex
  242.  
  243. Options:
  244.     -h   Display this help message
  245.     -V   report version
  246.     -r   Recursive search (slow)
  247.     -i   Ignore case
  248.     -t   Display pod using pod2text instead of pod2man and nroff
  249.              (-t is the default on win32 unless -n is specified)
  250.     -u     Display unformatted pod text
  251.     -m   Display module's file in its entirety
  252.     -n   Specify replacement for nroff
  253.     -l   Display the module's file name
  254.     -F   Arguments are file names, not modules
  255.     -v     Verbosely describe what's going on
  256.     -T   Send output to STDOUT without any pager
  257.     -d output_filename_to_send_to
  258.     -o output_format_name
  259.     -M FormatterModuleNameToUse
  260.     -w formatter_option:option_value
  261.     -X     use index if present (looks for pod.idx at $Config{archlib})
  262.     -q   Search the text of questions (not answers) in perlfaq[1-9]
  263.  
  264. PageName|ModuleName...
  265.          is the name of a piece of documentation that you want to look at. You
  266.          may either give a descriptive name of the page (as in the case of
  267.          `perlfunc') the name of a module, either like `Term::Info' or like
  268.          `Term/Info', or the name of a program, like `perldoc'.
  269.  
  270. BuiltinFunction
  271.          is the name of a perl function.  Will extract documentation from
  272.          `perlfunc'.
  273.  
  274. FAQRegex
  275.          is a regex. Will search perlfaq[1-9] for and extract any
  276.          questions that match.
  277.  
  278. Any switches in the PERLDOC environment variable will be used before the
  279. command line arguments.  The optional pod index file contains a list of
  280. filenames, one per line.
  281.                                                        [Perldoc v$VERSION]
  282. EOF
  283.  
  284. }
  285.  
  286. #..........................................................................
  287.  
  288. sub usage_brief {
  289.   my $me = $0;        # Editing $0 is unportable
  290.  
  291.   $me =~ s,.*[/\\],,; # get basename
  292.   
  293.   die <<"EOUSAGE";
  294. 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] [-F] [-X] PageName|ModuleName|ProgramName
  295.        $me -f PerlFunc
  296.        $me -q FAQKeywords
  297.  
  298. The -h option prints more help.  Also try "perldoc perldoc" to get
  299. acquainted with the system.                        [Perldoc v$VERSION]
  300. EOUSAGE
  301.  
  302. }
  303.  
  304. #..........................................................................
  305.  
  306. sub pagers { @{ shift->{'pagers'} } } 
  307.  
  308. #..........................................................................
  309.  
  310. sub _elem {  # handy scalar meta-accessor: shift->_elem("foo", @_)
  311.   if(@_ > 2) { return  $_[0]{ $_[1] } = $_[2]  }
  312.   else       { return  $_[0]{ $_[1] }          }
  313. }
  314. #..........................................................................
  315. ###########################################################################
  316. #
  317. # Init formatter switches, and start it off with __bindir and all that
  318. # other stuff that ToMan.pm needs.
  319. #
  320.  
  321. sub init {
  322.   my $self = shift;
  323.  
  324.   # Make sure creat()s are neither too much nor too little
  325.   eval { umask(0077) };   # doubtless someone has no mask
  326.  
  327.   $self->{'args'}              ||= \@ARGV;
  328.   $self->{'found'}             ||= [];
  329.   $self->{'temp_file_list'}    ||= [];
  330.   
  331.   
  332.   $self->{'target'} = undef;
  333.  
  334.   $self->init_formatter_class_list;
  335.  
  336.   $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
  337.   $self->{'bindir' } = $Bindir   unless exists $self->{'bindir'};
  338.   $self->{'pod2man'} = $Pod2man  unless exists $self->{'pod2man'};
  339.  
  340.   push @{ $self->{'formatter_switches'} = [] }, (
  341.    # Yeah, we could use a hashref, but maybe there's some class where options
  342.    # have to be ordered; so we'll use an arrayref.
  343.  
  344.      [ '__bindir'  => $self->{'bindir' } ],
  345.      [ '__pod2man' => $self->{'pod2man'} ],
  346.   );
  347.  
  348.   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
  349.    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  350.  
  351.   return;
  352. }
  353.  
  354. #..........................................................................
  355.  
  356. sub init_formatter_class_list {
  357.   my $self = shift;
  358.   $self->{'formatter_classes'} ||= [];
  359.  
  360.   # Remember, no switches have been read yet, when
  361.   # we've started this routine.
  362.  
  363.   $self->opt_M_with('Pod::Perldoc::ToPod');   # the always-there fallthru
  364.   $self->opt_o_with('text');
  365.   $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
  366.        || !($ENV{TERM} && (
  367.               ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
  368.            ));
  369.  
  370.   return;
  371. }
  372.  
  373. #..........................................................................
  374.  
  375. sub process {
  376.     # if this ever returns, its retval will be used for exit(RETVAL)
  377.  
  378.     my $self = shift;
  379.     DEBUG > 1 and print "  Beginning process.\n";
  380.     DEBUG > 1 and print "  Args: @{$self->{'args'}}\n\n";
  381.     if(DEBUG > 3) {
  382.         print "Object contents:\n";
  383.         my @x = %$self;
  384.         while(@x) {
  385.             $x[1] = '<undef>'  unless defined $x[1];
  386.             $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
  387.             print "  [$x[0]] => [$x[1]]\n";
  388.             splice @x,0,2;
  389.         }
  390.         print "\n";
  391.     }
  392.  
  393.     # TODO: make it deal with being invoked as various different things
  394.     #  such as perlfaq".
  395.   
  396.     return $self->usage_brief  unless  @{ $self->{'args'} };
  397.     $self->pagers_guessing;
  398.     $self->options_reading;
  399.     $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
  400.     $self->drop_privs_maybe;
  401.     $self->options_processing;
  402.     
  403.     # Hm, we have @pages and @found, but we only really act on one
  404.     # file per call, with the exception of the opt_q hack, and with
  405.     # -l things
  406.  
  407.     $self->aside("\n");
  408.  
  409.     my @pages;
  410.     $self->{'pages'} = \@pages;
  411.     if(    $self->opt_f) { @pages = ("perlfunc")               }
  412.     elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
  413.     else                 { @pages = @{$self->{'args'}};
  414.                            # @pages = __FILE__
  415.                            #  if @pages == 1 and $pages[0] eq 'perldoc';
  416.                          }
  417.  
  418.     return $self->usage_brief  unless  @pages;
  419.  
  420.     $self->find_good_formatter_class();
  421.     $self->formatter_sanity_check();
  422.  
  423.     $self->maybe_diddle_INC();
  424.       # for when we're apparently in a module or extension directory
  425.     
  426.     my @found = $self->grand_search_init(\@pages);
  427.     exit (IS_VMS ? 98962 : 1) unless @found;
  428.     
  429.     if ($self->opt_l) {
  430.         DEBUG and print "We're in -l mode, so byebye after this:\n";
  431.         print join("\n", @found), "\n";
  432.         return;
  433.     }
  434.  
  435.     $self->tweak_found_pathnames(\@found);
  436.     $self->assert_closing_stdout;
  437.     return $self->page_module_file(@found)  if  $self->opt_m;
  438.     DEBUG > 2 and print "Found: [@found]\n";
  439.  
  440.     return $self->render_and_page(\@found);
  441. }
  442.  
  443. #..........................................................................
  444. {
  445.  
  446. my( %class_seen, %class_loaded );
  447. sub find_good_formatter_class {
  448.   my $self = $_[0];
  449.   my @class_list = @{ $self->{'formatter_classes'} || [] };
  450.   die "WHAT?  Nothing in the formatter class list!?" unless @class_list;
  451.   
  452.   my $good_class_found;
  453.   foreach my $c (@class_list) {
  454.     DEBUG > 4 and print "Trying to load $c...\n";
  455.     if($class_loaded{$c}) {
  456.       DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
  457.       $good_class_found = $c;
  458.       last;
  459.     }
  460.     
  461.     if($class_seen{$c}) {
  462.       DEBUG > 4 and print
  463.        "I've tried $c before, and it's no good.  Skipping.\n";
  464.       next;
  465.     }
  466.     
  467.     $class_seen{$c} = 1;
  468.     
  469.     if( $c->can('parse_from_file') ) {
  470.       DEBUG > 4 and print
  471.        "Interesting, the formatter class $c is already loaded!\n";
  472.       
  473.     } elsif(
  474.       (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
  475.        # the alway case-insensitive fs's
  476.       and $class_seen{lc("~$c")}++
  477.     ) {
  478.       DEBUG > 4 and print
  479.        "We already used something quite like \"\L$c\E\", so no point using $c\n";
  480.       # This avoids redefining the package.
  481.     } else {
  482.       DEBUG > 4 and print "Trying to eval 'require $c'...\n";
  483.  
  484.       local $^W = $^W;
  485.       if(DEBUG() or $self->opt_v) {
  486.         # feh, let 'em see it
  487.       } else {
  488.         $^W = 0;
  489.         # The average user just has no reason to be seeing
  490.         #  $^W-suppressable warnings from the the require!
  491.       }
  492.  
  493.       eval "require $c";
  494.       if($@) {
  495.         DEBUG > 4 and print "Couldn't load $c: $!\n";
  496.         next;
  497.       }
  498.     }
  499.     
  500.     if( $c->can('parse_from_file') ) {
  501.       DEBUG > 4 and print "Settling on $c\n";
  502.       my $v = $c->VERSION;
  503.       $v = ( defined $v and length $v ) ? " version $v" : '';
  504.       $self->aside("Formatter class $c$v successfully loaded!\n");
  505.       $good_class_found = $c;
  506.       last;
  507.     } else {
  508.       DEBUG > 4 and print "Class $c isn't a formatter?!  Skipping.\n";
  509.     }
  510.   }
  511.   
  512.   die "Can't find any loadable formatter class in @class_list?!\nAborting"
  513.     unless $good_class_found;
  514.   
  515.   $self->{'formatter_class'} = $good_class_found;
  516.   $self->aside("Will format with the class $good_class_found\n");
  517.   
  518.   return;
  519. }
  520.  
  521. }
  522. #..........................................................................
  523.  
  524. sub formatter_sanity_check {
  525.   my $self = shift;
  526.   my $formatter_class = $self->{'formatter_class'}
  527.    || die "NO FORMATTER CLASS YET!?";
  528.   
  529.   if(!$self->opt_T # so -T can FORCE sending to STDOUT
  530.     and $formatter_class->can('is_pageable')
  531.     and !$formatter_class->is_pageable
  532.     and !$formatter_class->can('page_for_perldoc')
  533.   ) {
  534.     my $ext =
  535.      ($formatter_class->can('output_extension')
  536.        && $formatter_class->output_extension
  537.      ) || '';
  538.     $ext = ".$ext" if length $ext;
  539.     
  540.     die
  541.        "When using Perldoc to format with $formatter_class, you have to\n"
  542.      . "specify -T or -dsomefile$ext\n"
  543.      . "See `perldoc perldoc' for more information on those switches.\n"
  544.     ;
  545.   }
  546. }
  547.  
  548. #..........................................................................
  549.  
  550. sub render_and_page {
  551.     my($self, $found_list) = @_;
  552.     
  553.     $self->maybe_generate_dynamic_pod($found_list);
  554.  
  555.     my($out, $formatter) = $self->render_findings($found_list);
  556.     
  557.     if($self->opt_d) {
  558.       printf "Perldoc (%s) output saved to %s\n",
  559.         $self->{'formatter_class'} || ref($self),
  560.         $out;
  561.       print "But notice that it's 0 bytes long!\n" unless -s $out;
  562.       
  563.       
  564.     } elsif(  # Allow the formatter to "page" itself, if it wants.
  565.       $formatter->can('page_for_perldoc')
  566.       and do {
  567.         $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
  568.         if( $formatter->page_for_perldoc($out, $self) ) {
  569.           $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
  570.           1;
  571.         } else {
  572.           $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
  573.           '';
  574.         }
  575.       }
  576.     ) {
  577.       # Do nothing, since the formatter has "paged" it for itself.
  578.     
  579.     } else {
  580.       # Page it normally (internally)
  581.       
  582.       if( -s $out ) {  # Usual case:
  583.         $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
  584.         
  585.       } else {
  586.         # Odd case:
  587.         $self->aside("Skipping $out (from $$found_list[0] "
  588.          . "via $$self{'formatter_class'}) as it is 0-length.\n");
  589.          
  590.         push @{ $self->{'temp_file_list'} }, $out;
  591.         $self->unlink_if_temp_file($out);
  592.       }
  593.     }
  594.     
  595.     $self->after_rendering();  # any extra cleanup or whatever
  596.     
  597.     return;
  598. }
  599.  
  600. #..........................................................................
  601.  
  602. sub options_reading {
  603.     my $self = shift;
  604.     
  605.     if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
  606.       require Text::ParseWords;
  607.       $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
  608.       # Yes, appends to the beginning
  609.       unshift @{ $self->{'args'} },
  610.         Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
  611.       ;
  612.       DEBUG > 1 and print "  Args now: @{$self->{'args'}}\n\n";
  613.     } else {
  614.       DEBUG > 1 and print "  Okay, no PERLDOC setting in ENV.\n";
  615.     }
  616.  
  617.     DEBUG > 1
  618.      and print "  Args right before switch processing: @{$self->{'args'}}\n";
  619.  
  620.     Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
  621.      or return $self->usage;
  622.  
  623.     DEBUG > 1
  624.      and print "  Args after switch processing: @{$self->{'args'}}\n";
  625.  
  626.     return $self->usage if $self->opt_h;
  627.   
  628.     return;
  629. }
  630.  
  631. #..........................................................................
  632.  
  633. sub options_processing {
  634.     my $self = shift;
  635.     
  636.     if ($self->opt_X) {
  637.         my $podidx = "$Config{'archlib'}/pod.idx";
  638.         $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
  639.         $self->{'podidx'} = $podidx;
  640.     }
  641.  
  642.     $self->{'output_to_stdout'} = 1  if  $self->opt_T or ! -t STDOUT;
  643.  
  644.     $self->options_sanity;
  645.  
  646.     $self->opt_n("nroff") unless $self->opt_n;
  647.     $self->add_formatter_option( '__nroffer' => $self->opt_n );
  648.  
  649.     return;
  650. }
  651.  
  652. #..........................................................................
  653.  
  654. sub options_sanity {
  655.     my $self = shift;
  656.  
  657.     # The opts-counting stuff interacts quite badly with
  658.     # the $ENV{"PERLDOC"} stuff.  I.e., if I have $ENV{"PERLDOC"}
  659.     # set to -t, and I specify -u on the command line, I don't want
  660.     # to be hectored at that -u and -t don't make sense together.
  661.  
  662.     #my $opts = grep $_ && 1, # yes, the count of the set ones
  663.     #  $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
  664.     #;
  665.     #
  666.     #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
  667.     
  668.     
  669.     # Any sanity-checking need doing here?
  670.     
  671.     return;
  672. }
  673.  
  674. #..........................................................................
  675.  
  676. sub grand_search_init {
  677.     my($self, $pages, @found) = @_;
  678.  
  679.     foreach (@$pages) {
  680.         if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
  681.             my $searchfor = catfile split '::', $_;
  682.             $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
  683.             local $_;
  684.             while (<PODIDX>) {
  685.                 chomp;
  686.                 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
  687.             }
  688.             close(PODIDX)            or die "Can't close $$self{'podidx'}: $!";
  689.             next;
  690.         }
  691.  
  692.         $self->aside( "Searching for $_\n" );
  693.  
  694.         if ($self->opt_F) {
  695.             next unless -r;
  696.             push @found, $_ if $self->opt_m or $self->containspod($_);
  697.             next;
  698.         }
  699.  
  700.         # We must look both in @INC for library modules and in $bindir
  701.         # for executables, like h2xs or perldoc itself.
  702.  
  703.         my @searchdirs = ($self->{'bindir'}, @INC);
  704.         unless ($self->opt_m) {
  705.             if (IS_VMS) {
  706.                 my($i,$trn);
  707.                 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
  708.                     push(@searchdirs,$trn);
  709.                 }
  710.                 push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
  711.             }
  712.             else {
  713.                 push(@searchdirs, grep(-d, split($Config{path_sep},
  714.                                                  $ENV{'PATH'})));
  715.             }
  716.         }
  717.         my @files = $self->searchfor(0,$_,@searchdirs);
  718.         if (@files) {
  719.             $self->aside( "Found as @files\n" );
  720.         }
  721.         else {
  722.             # no match, try recursive search
  723.             @searchdirs = grep(!/^\.\z/s,@INC);
  724.             @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
  725.             if (@files) {
  726.                 $self->aside( "Loosely found as @files\n" );
  727.             }
  728.             else {
  729.                 print STDERR "No " .
  730.                     ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
  731.                 if ( @{ $self->{'found'} } ) {
  732.                     print STDERR "However, try\n";
  733.                     for my $dir (@{ $self->{'found'} }) {
  734.                         opendir(DIR, $dir) or die "opendir $dir: $!";
  735.                         while (my $file = readdir(DIR)) {
  736.                             next if ($file =~ /^\./s);
  737.                             $file =~ s/\.(pm|pod)\z//;  # XXX: badfs
  738.                             print STDERR "\tperldoc $_\::$file\n";
  739.                         }
  740.                         closedir(DIR)    or die "closedir $dir: $!";
  741.                     }
  742.                 }
  743.             }
  744.         }
  745.         push(@found,@files);
  746.     }
  747.     return @found;
  748. }
  749.  
  750. #..........................................................................
  751.  
  752. sub maybe_generate_dynamic_pod {
  753.     my($self, $found_things) = @_;
  754.     my @dynamic_pod;
  755.     
  756.     $self->search_perlfunc($found_things, \@dynamic_pod)  if  $self->opt_f;
  757.     
  758.     $self->search_perlfaqs($found_things, \@dynamic_pod)  if  $self->opt_q;
  759.  
  760.     if( ! $self->opt_f and ! $self->opt_q ) {
  761.         DEBUG > 4 and print "That's a non-dynamic pod search.\n";
  762.     } elsif ( @dynamic_pod ) {
  763.         $self->aside("Hm, I found some Pod from that search!\n");
  764.         my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
  765.         
  766.         push @{ $self->{'temp_file_list'} }, $buffer;
  767.          # I.e., it MIGHT be deleted at the end.
  768.         
  769.     my $in_list = $self->opt_f;
  770.  
  771.         print $buffd "=over 8\n\n" if $in_list;
  772.         print $buffd @dynamic_pod  or die "Can't print $buffer: $!";
  773.         print $buffd "=back\n"     if $in_list;
  774.  
  775.         close $buffd        or die "Can't close $buffer: $!";
  776.         
  777.         @$found_things = $buffer;
  778.           # Yes, so found_things never has more than one thing in
  779.           #  it, by time we leave here
  780.         
  781.         $self->add_formatter_option('__filter_nroff' => 1);
  782.  
  783.     } else {
  784.         @$found_things = ();
  785.         $self->aside("I found no Pod from that search!\n");
  786.     }
  787.  
  788.     return;
  789. }
  790.  
  791. #..........................................................................
  792.  
  793. sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
  794.   my $self = shift;
  795.   push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
  796.  
  797.   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
  798.    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  799.   
  800.   return;
  801. }
  802.  
  803. #..........................................................................
  804.  
  805. sub search_perlfunc {
  806.     my($self, $found_things, $pod) = @_;
  807.  
  808.     DEBUG > 2 and print "Search: @$found_things\n";
  809.  
  810.     my $perlfunc = shift @$found_things;
  811.     open(PFUNC, "<", $perlfunc)               # "Funk is its own reward"
  812.         or die("Can't open $perlfunc: $!");
  813.  
  814.     # Functions like -r, -e, etc. are listed under `-X'.
  815.     my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
  816.                         ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
  817.  
  818.     DEBUG > 2 and
  819.      print "Going to perlfunc-scan for $search_re in $perlfunc\n";
  820.     
  821.     # Skip introduction
  822.     local $_;
  823.     while (<PFUNC>) {
  824.         last if /^=head2 Alphabetical Listing of Perl Functions/;
  825.     }
  826.  
  827.     # Look for our function
  828.     my $found = 0;
  829.     my $inlist = 0;
  830.     while (<PFUNC>) {  # "The Mothership Connection is here!"
  831.         if ( m/^=item\s+$search_re\b/ )  {
  832.             $found = 1;
  833.         }
  834.         elsif (/^=item/) {
  835.             last if $found > 1 and not $inlist;
  836.         }
  837.         next unless $found;
  838.         if (/^=over/) {
  839.             ++$inlist;
  840.         }
  841.         elsif (/^=back/) {
  842.             --$inlist;
  843.         }
  844.         push @$pod, $_;
  845.         ++$found if /^\w/;        # found descriptive text
  846.     }
  847.     if (!@$pod) {
  848.         die sprintf
  849.           "No documentation for perl function `%s' found\n",
  850.           $self->opt_f
  851.         ;
  852.     }
  853.     close PFUNC                or die "Can't open $perlfunc: $!";
  854.  
  855.     return;
  856. }
  857.  
  858. #..........................................................................
  859.  
  860. sub search_perlfaqs {
  861.     my( $self, $found_things, $pod) = @_;
  862.  
  863.     my $found = 0;
  864.     my %found_in;
  865.     my $search_key = $self->opt_q;
  866.     
  867.     my $rx = eval { qr/$search_key/ }
  868.      or die <<EOD;
  869. Invalid regular expression '$search_key' given as -q pattern:
  870. $@
  871. Did you mean \\Q$search_key ?
  872.  
  873. EOD
  874.  
  875.     local $_;
  876.     foreach my $file (@$found_things) {
  877.         die "invalid file spec: $!" if $file =~ /[<>|]/;
  878.         open(INFAQ, "<", $file)  # XXX 5.6ism
  879.          or die "Can't read-open $file: $!\nAborting";
  880.         while (<INFAQ>) {
  881.             if ( m/^=head2\s+.*(?:$search_key)/i ) {
  882.                 $found = 1;
  883.                 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
  884.             }
  885.             elsif (/^=head[12]/) {
  886.                 $found = 0;
  887.             }
  888.             next unless $found;
  889.             push @$pod, $_;
  890.         }
  891.         close(INFAQ);
  892.     }
  893.     die("No documentation for perl FAQ keyword `$search_key' found\n")
  894.      unless @$pod;
  895.  
  896.     return;
  897. }
  898.  
  899.  
  900. #..........................................................................
  901.  
  902. sub render_findings {
  903.   # Return the filename to open
  904.  
  905.   my($self, $found_things) = @_;
  906.  
  907.   my $formatter_class = $self->{'formatter_class'}
  908.    || die "No formatter class set!?";
  909.   my $formatter = $formatter_class->can('new')
  910.     ? $formatter_class->new
  911.     : $formatter_class
  912.   ;
  913.  
  914.   if(! @$found_things) {
  915.     die "Nothing found?!";
  916.     # should have been caught before here
  917.   } elsif(@$found_things > 1) {
  918.     warn join '',
  919.      "Perldoc is only really meant for reading one document at a time.\n",
  920.      "So these parameters are being ignored: ",
  921.      join(' ', @$found_things[1 .. $#$found_things] ),
  922.      "\n"
  923.   }
  924.  
  925.   my $file = $found_things->[0];
  926.   
  927.   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
  928.    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  929.  
  930.   # Set formatter options:
  931.   if( ref $formatter ) {
  932.     foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
  933.       my($switch, $value, $silent_fail) = @$f;
  934.       if( $formatter->can($switch) ) {
  935.         eval { $formatter->$switch( defined($value) ? $value : () ) };
  936.         warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
  937.          if $@;
  938.       } else {
  939.         if( $silent_fail or $switch =~ m/^__/s ) {
  940.           DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
  941.         } else {
  942.           warn "$formatter_class doesn't recognize the $switch switch.\n";
  943.         }
  944.       }
  945.     }
  946.   }
  947.   
  948.   $self->{'output_is_binary'} =
  949.     $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
  950.  
  951.   my ($out_fh, $out) = $self->new_output_file(
  952.     ( $formatter->can('output_extension') && $formatter->output_extension )
  953.      || undef,
  954.     $self->useful_filename_bit,
  955.   );
  956.  
  957.   # Now, finally, do the formatting!
  958.   {
  959.     local $^W = $^W;
  960.     if(DEBUG() or $self->opt_v) {
  961.       # feh, let 'em see it
  962.     } else {
  963.       $^W = 0;
  964.       # The average user just has no reason to be seeing
  965.       #  $^W-suppressable warnings from the formatting!
  966.     }
  967.           
  968.     eval {  $formatter->parse_from_file( $file, $out_fh )  };
  969.   }
  970.   
  971.   warn "Error while formatting with $formatter_class:\n $@\n" if $@;
  972.   DEBUG > 2 and print "Back from formatting with $formatter_class\n";
  973.  
  974.   close $out_fh 
  975.    or warn "Can't close $out: $!\n(Did $formatter already close it?)";
  976.   sleep 0; sleep 0; sleep 0;
  977.    # Give the system a few timeslices to meditate on the fact
  978.    # that the output file does in fact exist and is closed.
  979.   
  980.   $self->unlink_if_temp_file($file);
  981.  
  982.   unless( -s $out ) {
  983.     if( $formatter->can( 'if_zero_length' ) ) {
  984.       # Basically this is just a hook for Pod::Simple::Checker; since
  985.       # what other class could /happily/ format an input file with Pod
  986.       # as a 0-length output file?
  987.       $formatter->if_zero_length( $file, $out, $out_fh );
  988.     } else {
  989.       warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
  990.     }
  991.   }
  992.  
  993.   DEBUG and print "Finished writing to $out.\n";
  994.   return($out, $formatter) if wantarray;
  995.   return $out;
  996. }
  997.  
  998. #..........................................................................
  999.  
  1000. sub unlink_if_temp_file {
  1001.   # Unlink the specified file IFF it's in the list of temp files.
  1002.   # Really only used in the case of -f / -q things when we can
  1003.   #  throw away the dynamically generated source pod file once
  1004.   #  we've formatted it.
  1005.   #
  1006.   my($self, $file) = @_;
  1007.   return unless defined $file and length $file;
  1008.   
  1009.   my $temp_file_list = $self->{'temp_file_list'} || return;
  1010.   if(grep $_ eq $file, @$temp_file_list) {
  1011.     $self->aside("Unlinking $file\n");
  1012.     unlink($file) or warn "Odd, couldn't unlink $file: $!";
  1013.   } else {
  1014.     DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
  1015.   }
  1016.   return;
  1017. }
  1018.  
  1019. #..........................................................................
  1020.  
  1021. sub MSWin_temp_cleanup {
  1022.  
  1023.   # Nothing particularly MSWin-specific in here, but I don't know if any
  1024.   # other OS needs its temp dir policed like MSWin does!
  1025.  
  1026.   my $self = shift;
  1027.  
  1028.   my $tempdir = $ENV{'TEMP'};
  1029.   return unless defined $tempdir and length $tempdir
  1030.    and -e $tempdir and -d _ and -w _;
  1031.  
  1032.   $self->aside(
  1033.    "Considering whether any old files of mine in $tempdir need unlinking.\n"
  1034.   );
  1035.  
  1036.   opendir(TMPDIR, $tempdir) || return;
  1037.   my @to_unlink;
  1038.   
  1039.   my $limit = time() - $Temp_File_Lifetime;
  1040.   
  1041.   DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
  1042.    ($limit) x 2;
  1043.   
  1044.   my $filespec;
  1045.   
  1046.   while(defined($filespec = readdir(TMPDIR))) {
  1047.     if(
  1048.      $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
  1049.     ) {
  1050.       if( hex($1) < $limit ) {
  1051.         push @to_unlink, "$tempdir/$filespec";
  1052.         $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
  1053.       } else {
  1054.         DEBUG > 5 and
  1055.          printf "  $tempdir/$filespec is too recent (after %x)\n", $limit;
  1056.       }
  1057.     } else {
  1058.       DEBUG > 5 and
  1059.        print "  $tempdir/$filespec doesn't look like a perldoc temp file.\n";
  1060.     }
  1061.   }
  1062.   closedir(TMPDIR);
  1063.   $self->aside(sprintf "Unlinked %s items of mine in %s\n",
  1064.     scalar(unlink(@to_unlink)),
  1065.     $tempdir
  1066.   );
  1067.   return;
  1068. }
  1069.  
  1070. #  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
  1071.  
  1072. sub MSWin_perldoc_tempfile {
  1073.   my($self, $suffix, $infix) = @_;
  1074.  
  1075.   my $tempdir = $ENV{'TEMP'};
  1076.   return unless defined $tempdir and length $tempdir
  1077.    and -e $tempdir and -d _ and -w _;
  1078.  
  1079.   my $spec;
  1080.   
  1081.   do {
  1082.     $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
  1083.       # Yes, we embed the create-time in the filename!
  1084.       $tempdir,
  1085.       $infix || 'x',
  1086.       time(),
  1087.       $$,
  1088.       defined( &Win32::GetTickCount )
  1089.         ? (Win32::GetTickCount() & 0xff)
  1090.         : int(rand 256)
  1091.        # Under MSWin, $$ values get reused quickly!  So if we ran
  1092.        # perldoc foo and then perldoc bar before there was time for
  1093.        # time() to increment time."_$$" would likely be the same
  1094.        # for each process!  So we tack on the tick count's lower
  1095.        # bits (or, in a pinch, rand)
  1096.       ,
  1097.       $suffix || 'txt';
  1098.     ;
  1099.   } while( -e $spec );
  1100.  
  1101.   my $counter = 0;
  1102.   
  1103.   while($counter < 50) {
  1104.     my $fh;
  1105.     # If we are running before perl5.6.0, we can't autovivify
  1106.     if ($] < 5.006) {
  1107.       require Symbol;
  1108.       $fh = Symbol::gensym();
  1109.     }
  1110.     DEBUG > 3 and print "About to try making temp file $spec\n";
  1111.     return($fh, $spec) if open($fh, ">", $spec);    # XXX 5.6ism
  1112.     $self->aside("Can't create temp file $spec: $!\n");
  1113.   }
  1114.  
  1115.   $self->aside("Giving up on making a temp file!\n");
  1116.   die "Can't make a tempfile!?";
  1117. }
  1118.  
  1119. #..........................................................................
  1120.  
  1121.  
  1122. sub after_rendering {
  1123.   my $self = $_[0];
  1124.   $self->after_rendering_VMS     if IS_VMS;
  1125.   $self->after_rendering_MSWin32 if IS_MSWin32;
  1126.   $self->after_rendering_Dos     if IS_Dos;
  1127.   $self->after_rendering_OS2     if IS_OS2;
  1128.   return;
  1129. }
  1130.  
  1131. sub after_rendering_VMS      { return }
  1132. sub after_rendering_Dos      { return }
  1133. sub after_rendering_OS2      { return }
  1134.  
  1135. sub after_rendering_MSWin32  {
  1136.   shift->MSWin_temp_cleanup() if $Temp_Files_Created;
  1137. }
  1138.  
  1139. #..........................................................................
  1140. #    :    :    :    :    :    :    :    :    :
  1141. #..........................................................................
  1142.  
  1143.  
  1144. sub minus_f_nocase {   # i.e., do like -f, but without regard to case
  1145.  
  1146.      my($self, $dir, $file) = @_;
  1147.      my $path = catfile($dir,$file);
  1148.      return $path if -f $path and -r _;
  1149.  
  1150.      if(!$self->opt_i
  1151.         or IS_VMS or IS_MSWin32
  1152.         or IS_Dos or IS_OS2
  1153.      ) {
  1154.         # On a case-forgiving file system, or if case is important,
  1155.     #  that is it, all we can do.
  1156.     warn "Ignored $path: unreadable\n" if -f _;
  1157.     return '';
  1158.      }
  1159.      
  1160.      local *DIR;
  1161.      my @p = ($dir);
  1162.      my($p,$cip);
  1163.      foreach $p (splitdir $file){
  1164.     my $try = catfile @p, $p;
  1165.         $self->aside("Scrutinizing $try...\n");
  1166.     stat $try;
  1167.      if (-d _) {
  1168.          push @p, $p;
  1169.         if ( $p eq $self->{'target'} ) {
  1170.         my $tmp_path = catfile @p;
  1171.         my $path_f = 0;
  1172.         for (@{ $self->{'found'} }) {
  1173.             $path_f = 1 if $_ eq $tmp_path;
  1174.         }
  1175.         push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
  1176.         $self->aside( "Found as $tmp_path but directory\n" );
  1177.         }
  1178.      }
  1179.     elsif (-f _ && -r _) {
  1180.          return $try;
  1181.      }
  1182.     elsif (-f _) {
  1183.         warn "Ignored $try: unreadable\n";
  1184.      }
  1185.     elsif (-d catdir(@p)) {  # at least we see the containing directory!
  1186.          my $found = 0;
  1187.          my $lcp = lc $p;
  1188.          my $p_dirspec = catdir(@p);
  1189.          opendir DIR, $p_dirspec  or die "opendir $p_dirspec: $!";
  1190.          while(defined( $cip = readdir(DIR) )) {
  1191.          if (lc $cip eq $lcp){
  1192.              $found++;
  1193.              last; # XXX stop at the first? what if there's others?
  1194.          }
  1195.          }
  1196.          closedir DIR  or die "closedir $p_dirspec: $!";
  1197.          return "" unless $found;
  1198.  
  1199.          push @p, $cip;
  1200.          my $p_filespec = catfile(@p);
  1201.          return $p_filespec if -f $p_filespec and -r _;
  1202.         warn "Ignored $p_filespec: unreadable\n" if -f _;
  1203.      }
  1204.      }
  1205.      return "";
  1206. }
  1207.  
  1208. #..........................................................................
  1209.  
  1210. sub pagers_guessing {
  1211.     my $self = shift;
  1212.  
  1213.     my @pagers;
  1214.     push @pagers, $self->pagers;
  1215.     $self->{'pagers'} = \@pagers;
  1216.  
  1217.     if (IS_MSWin32) {
  1218.         push @pagers, qw( more< less notepad );
  1219.         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  1220.     }
  1221.     elsif (IS_VMS) {
  1222.         push @pagers, qw( most more less type/page );
  1223.     }
  1224.     elsif (IS_Dos) {
  1225.         push @pagers, qw( less.exe more.com< );
  1226.         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  1227.     }
  1228.     else {
  1229.         if (IS_OS2) {
  1230.           unshift @pagers, 'less', 'cmd /c more <';
  1231.         }
  1232.         push @pagers, qw( more less pg view cat );
  1233.         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  1234.     }
  1235.     unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
  1236.     
  1237.     return;   
  1238. }
  1239.  
  1240. #..........................................................................
  1241.  
  1242. sub page_module_file {
  1243.     my($self, @found) = @_;
  1244.  
  1245.     # Security note:
  1246.     # Don't ever just pass this off to anything like MSWin's "start.exe",
  1247.     # since we might be calling on a .pl file, and we wouldn't want that
  1248.     # to actually /execute/ the file that we just want to page thru!
  1249.     # Also a consideration if one were to use a web browser as a pager;
  1250.     # doing so could trigger the browser's MIME mapping for whatever
  1251.     # it thinks .pm/.pl/whatever is.  Probably just a (useless and
  1252.     # annoying) "Save as..." dialog, but potentially executing the file
  1253.     # in question -- particularly in the case of MSIE and it's, ahem,
  1254.     # occasionally hazy distinction between OS-local extension
  1255.     # associations, and browser-specific MIME mappings.
  1256.  
  1257.     if ($self->{'output_to_stdout'}) {
  1258.         $self->aside("Sending unpaged output to STDOUT.\n");
  1259.     local $_;
  1260.     my $any_error = 0;
  1261.         foreach my $output (@found) {
  1262.         unless( open(TMP, "<", $output) ) {    # XXX 5.6ism
  1263.           warn("Can't open $output: $!");
  1264.           $any_error = 1;
  1265.           next;
  1266.         }
  1267.         while (<TMP>) {
  1268.             print or die "Can't print to stdout: $!";
  1269.         } 
  1270.         close TMP  or die "Can't close while $output: $!";
  1271.         $self->unlink_if_temp_file($output);
  1272.     }
  1273.     return $any_error; # successful
  1274.     }
  1275.  
  1276.     foreach my $pager ( $self->pagers ) {
  1277.         $self->aside("About to try calling $pager @found\n");
  1278.         if (system($pager, @found) == 0) {
  1279.             $self->aside("Yay, it worked.\n");
  1280.             return 0;
  1281.         }
  1282.         $self->aside("That didn't work.\n");
  1283.         
  1284.         # Odd -- when it fails, under Win32, this seems to neither
  1285.         #  return with a fail nor return with a success!!
  1286.         #  That's discouraging!
  1287.     }
  1288.  
  1289.     $self->aside(
  1290.       sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
  1291.       join(' ', @found),
  1292.       join(' ', $self->pagers),
  1293.     );
  1294.     
  1295.     if (IS_VMS) { 
  1296.         DEBUG > 1 and print "Bailing out in a VMSish way.\n";
  1297.         eval q{
  1298.             use vmsish qw(status exit); 
  1299.             exit $?;
  1300.             1;
  1301.         } or die;
  1302.     }
  1303.     
  1304.     return 1;
  1305.       # i.e., an UNSUCCESSFUL return value!
  1306. }
  1307.  
  1308. #..........................................................................
  1309.  
  1310. sub check_file {
  1311.     my($self, $dir, $file) = @_;
  1312.     
  1313.     unless( ref $self ) {
  1314.       # Should never get called:
  1315.       $Carp::Verbose = 1;
  1316.       require Carp;
  1317.       Carp::croak( join '',
  1318.         "Crazy ", __PACKAGE__, " error:\n",
  1319.         "check_file must be an object_method!\n",
  1320.         "Aborting"
  1321.       );
  1322.     }
  1323.     
  1324.     if(length $dir and not -d $dir) {
  1325.       DEBUG > 3 and print "  No dir $dir -- skipping.\n";
  1326.       return "";
  1327.     }
  1328.     
  1329.     if ($self->opt_m) {
  1330.     return $self->minus_f_nocase($dir,$file);
  1331.     }
  1332.     
  1333.     else {
  1334.     my $path = $self->minus_f_nocase($dir,$file);
  1335.         if( length $path and $self->containspod($path) ) {
  1336.             DEBUG > 3 and print
  1337.               "  The file $path indeed looks promising!\n";
  1338.             return $path;
  1339.         }
  1340.     }
  1341.     DEBUG > 3 and print "  No good: $file in $dir\n";
  1342.     
  1343.     return "";
  1344. }
  1345.  
  1346. #..........................................................................
  1347.  
  1348. sub containspod {
  1349.     my($self, $file, $readit) = @_;
  1350.     return 1 if !$readit && $file =~ /\.pod\z/i;
  1351.  
  1352.  
  1353.     #  Under cygwin the /usr/bin/perl is legal executable, but
  1354.     #  you cannot open a file with that name. It must be spelled
  1355.     #  out as "/usr/bin/perl.exe".
  1356.     #
  1357.     #  The following if-case under cygwin prevents error
  1358.     #
  1359.     #     $ perldoc perl
  1360.     #     Cannot open /usr/bin/perl: no such file or directory
  1361.     #
  1362.     #  This would work though
  1363.     #
  1364.     #     $ perldoc perl.pod
  1365.  
  1366.     if ( IS_Cygwin  and  -x $file  and  -f "$file.exe" )
  1367.     {
  1368.         warn "Cygwin $file.exe search skipped\n"  if DEBUG or $self->opt_v;
  1369.         return 0;
  1370.     }
  1371.  
  1372.     local($_);
  1373.     open(TEST,"<", $file)     or die "Can't open $file: $!";   # XXX 5.6ism
  1374.     while (<TEST>) {
  1375.     if (/^=head/) {
  1376.         close(TEST)     or die "Can't close $file: $!";
  1377.         return 1;
  1378.     }
  1379.     }
  1380.     close(TEST)         or die "Can't close $file: $!";
  1381.     return 0;
  1382. }
  1383.  
  1384. #..........................................................................
  1385.  
  1386. sub maybe_diddle_INC {
  1387.   my $self = shift;
  1388.   
  1389.   # Does this look like a module or extension directory?
  1390.   
  1391.   if (-f "Makefile.PL") {
  1392.  
  1393.     # Add "." and "lib" to @INC (if they exist)
  1394.     eval q{ use lib qw(. lib); 1; } or die;
  1395.  
  1396.     # don't add if superuser
  1397.     if ($< && $> && -f "blib") {   # don't be looking too hard now!
  1398.       eval q{ use blib; 1 };
  1399.       warn $@ if $@ && $self->opt_v;
  1400.     }
  1401.   }
  1402.   
  1403.   return;
  1404. }
  1405.  
  1406. #..........................................................................
  1407.  
  1408. sub new_output_file {
  1409.   my $self = shift;
  1410.   my $outspec = $self->opt_d;  # Yes, -d overrides all else!
  1411.                                # So don't call this twice per format-job!
  1412.   
  1413.   return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
  1414.  
  1415.   # Otherwise open a write-handle on opt_d!f
  1416.  
  1417.   my $fh;
  1418.   # If we are running before perl5.6.0, we can't autovivify
  1419.   if ($] < 5.006) {
  1420.     require Symbol;
  1421.     $fh = Symbol::gensym();
  1422.   }
  1423.   DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
  1424.   die "Can't write-open $outspec: $!"
  1425.    unless open($fh, ">", $outspec); # XXX 5.6ism
  1426.   
  1427.   DEBUG > 3 and print "Successfully opened $outspec\n";
  1428.   binmode($fh) if $self->{'output_is_binary'};
  1429.   return($fh, $outspec);
  1430. }
  1431.  
  1432. #..........................................................................
  1433.  
  1434. sub useful_filename_bit {
  1435.   # This tries to provide a meaningful bit of text to do with the query,
  1436.   # such as can be used in naming the file -- since if we're going to be
  1437.   # opening windows on temp files (as a "pager" may well do!) then it's
  1438.   # better if the temp file's name (which may well be used as the window
  1439.   # title) isn't ALL just random garbage!
  1440.   # In other words "perldoc_LWPSimple_2371981429" is a better temp file
  1441.   # name than "perldoc_2371981429".  So this routine is what tries to
  1442.   # provide the "LWPSimple" bit.
  1443.   #
  1444.   my $self = shift;
  1445.   my $pages = $self->{'pages'} || return undef;
  1446.   return undef unless @$pages;
  1447.   
  1448.   my $chunk = $pages->[0];
  1449.   return undef unless defined $chunk;
  1450.   $chunk =~ s/:://g;
  1451.   $chunk =~ s/\.\w+$//g; # strip any extension
  1452.   if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
  1453.     $chunk = $1;
  1454.   } else {
  1455.     return undef;
  1456.   }
  1457.   $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
  1458.   $chunk = substr($chunk, -10) if length($chunk) > 10;
  1459.   return $chunk;
  1460. }
  1461.  
  1462. #..........................................................................
  1463.  
  1464. sub new_tempfile {    # $self->new_tempfile( [$suffix, [$infix] ] )
  1465.   my $self = shift;
  1466.  
  1467.   ++$Temp_Files_Created;
  1468.  
  1469.   if( IS_MSWin32 ) {
  1470.     my @out = $self->MSWin_perldoc_tempfile(@_);
  1471.     return @out if @out;
  1472.     # otherwise fall thru to the normal stuff below...
  1473.   }
  1474.   
  1475.   require File::Temp;
  1476.   return File::Temp::tempfile(UNLINK => 1);
  1477. }
  1478.  
  1479. #..........................................................................
  1480.  
  1481. sub page {  # apply a pager to the output file
  1482.     my ($self, $output, $output_to_stdout, @pagers) = @_;
  1483.     if ($output_to_stdout) {
  1484.         $self->aside("Sending unpaged output to STDOUT.\n");
  1485.     open(TMP, "<", $output)  or  die "Can't open $output: $!"; # XXX 5.6ism
  1486.     local $_;
  1487.     while (<TMP>) {
  1488.         print or die "Can't print to stdout: $!";
  1489.     } 
  1490.     close TMP  or die "Can't close while $output: $!";
  1491.     $self->unlink_if_temp_file($output);
  1492.     } else {
  1493.         # On VMS, quoting prevents logical expansion, and temp files with no
  1494.         # extension get the wrong default extension (such as .LIS for TYPE)
  1495.  
  1496.         $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
  1497.         foreach my $pager (@pagers) {
  1498.             $self->aside("About to try calling $pager $output\n");
  1499.             if (IS_VMS) {
  1500.                 last if system("$pager $output") == 0;
  1501.             } else {
  1502.             last if system("$pager \"$output\"") == 0;
  1503.             }
  1504.     }
  1505.     }
  1506.     return;
  1507. }
  1508.  
  1509. #..........................................................................
  1510.  
  1511. sub searchfor {
  1512.     my($self, $recurse,$s,@dirs) = @_;
  1513.     $s =~ s!::!/!g;
  1514.     $s = VMS::Filespec::unixify($s) if IS_VMS;
  1515.     return $s if -f $s && $self->containspod($s);
  1516.     $self->aside( "Looking for $s in @dirs\n" );
  1517.     my $ret;
  1518.     my $i;
  1519.     my $dir;
  1520.     $self->{'target'} = (splitdir $s)[-1];  # XXX: why not use File::Basename?
  1521.     for ($i=0; $i<@dirs; $i++) {
  1522.     $dir = $dirs[$i];
  1523.     ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
  1524.     if (       (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
  1525.         or ( $ret = $self->check_file($dir,"$s.pm"))
  1526.         or ( $ret = $self->check_file($dir,$s))
  1527.         or ( IS_VMS and
  1528.              $ret = $self->check_file($dir,"$s.com"))
  1529.         or ( IS_OS2 and
  1530.              $ret = $self->check_file($dir,"$s.cmd"))
  1531.         or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
  1532.              $ret = $self->check_file($dir,"$s.bat"))
  1533.         or ( $ret = $self->check_file("$dir/pod","$s.pod"))
  1534.         or ( $ret = $self->check_file("$dir/pod",$s))
  1535.         or ( $ret = $self->check_file("$dir/pods","$s.pod"))
  1536.         or ( $ret = $self->check_file("$dir/pods",$s))
  1537.     ) {
  1538.         DEBUG > 1 and print "  Found $ret\n";
  1539.         return $ret;
  1540.     }
  1541.  
  1542.     if ($recurse) {
  1543.         opendir(D,$dir)    or die "Can't opendir $dir: $!";
  1544.         my @newdirs = map catfile($dir, $_), grep {
  1545.         not /^\.\.?\z/s and
  1546.         not /^auto\z/s  and   # save time! don't search auto dirs
  1547.         -d  catfile($dir, $_)
  1548.         } readdir D;
  1549.         closedir(D)        or die "Can't closedir $dir: $!";
  1550.         next unless @newdirs;
  1551.         # what a wicked map!
  1552.         @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
  1553.         $self->aside( "Also looking in @newdirs\n" );
  1554.         push(@dirs,@newdirs);
  1555.     }
  1556.     }
  1557.     return ();
  1558. }
  1559.  
  1560. #..........................................................................
  1561. {
  1562.   my $already_asserted;
  1563.   sub assert_closing_stdout {
  1564.     my $self = shift;
  1565.  
  1566.     return if $already_asserted;
  1567.  
  1568.     eval  q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
  1569.      # What for? to let the pager know that nothing more will come?
  1570.   
  1571.     die $@ if $@;
  1572.     $already_asserted = 1;
  1573.     return;
  1574.   }
  1575. }
  1576.  
  1577. #..........................................................................
  1578.  
  1579. sub tweak_found_pathnames {
  1580.   my($self, $found) = @_;
  1581.   if (IS_MSWin32) {
  1582.     foreach (@$found) { s,/,\\,g }
  1583.   }
  1584.   return;
  1585. }
  1586.  
  1587. #..........................................................................
  1588. #    :    :    :    :    :    :    :    :    :
  1589. #..........................................................................
  1590.  
  1591. sub am_taint_checking {
  1592.     my $self = shift;
  1593.     die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
  1594.     my($k,$v) = each %ENV;
  1595.     return is_tainted($v);  
  1596. }
  1597.  
  1598. #..........................................................................
  1599.  
  1600. sub is_tainted { # just a function
  1601.     my $arg  = shift;
  1602.     my $nada = substr($arg, 0, 0);  # zero-length!
  1603.     local $@;  # preserve the caller's version of $@
  1604.     eval { eval "# $nada" };
  1605.     return length($@) != 0;
  1606. }
  1607.  
  1608. #..........................................................................
  1609.  
  1610. sub drop_privs_maybe {
  1611.     my $self = shift;
  1612.     
  1613.     # Attempt to drop privs if we should be tainting and aren't
  1614.     if (!(IS_VMS || IS_MSWin32 || IS_Dos
  1615.           || IS_OS2
  1616.          )
  1617.         && ($> == 0 || $< == 0)
  1618.         && !$self->am_taint_checking()
  1619.     ) {
  1620.         my $id = eval { getpwnam("nobody") };
  1621.         $id = eval { getpwnam("nouser") } unless defined $id;
  1622.         $id = -2 unless defined $id;
  1623.             #
  1624.             # According to Stevens' APUE and various
  1625.             # (BSD, Solaris, HP-UX) man pages, setting
  1626.             # the real uid first and effective uid second
  1627.             # is the way to go if one wants to drop privileges,
  1628.             # because if one changes into an effective uid of
  1629.             # non-zero, one cannot change the real uid any more.
  1630.             #
  1631.             # Actually, it gets even messier.  There is
  1632.             # a third uid, called the saved uid, and as
  1633.             # long as that is zero, one can get back to
  1634.             # uid of zero.  Setting the real-effective *twice*
  1635.             # helps in *most* systems (FreeBSD and Solaris)
  1636.             # but apparently in HP-UX even this doesn't help:
  1637.             # the saved uid stays zero (apparently the only way
  1638.             # in HP-UX to change saved uid is to call setuid()
  1639.             # when the effective uid is zero).
  1640.             #
  1641.         eval {
  1642.             $< = $id; # real uid
  1643.             $> = $id; # effective uid
  1644.             $< = $id; # real uid
  1645.             $> = $id; # effective uid
  1646.         };
  1647.         if( !$@ && $< && $> ) {
  1648.           DEBUG and print "OK, I dropped privileges.\n";
  1649.         } elsif( $self->opt_U ) {
  1650.           DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
  1651.         } else {
  1652.           DEBUG and print "Hm, couldn't drop privileges.  Ah well.\n";
  1653.           # We used to die here; but that seemed pointless.
  1654.         }
  1655.     }
  1656.     return;
  1657. }
  1658.  
  1659. #..........................................................................
  1660.  
  1661. 1;
  1662.  
  1663. __END__
  1664.  
  1665. # See "perldoc perldoc" for basic details.
  1666. #
  1667. # Perldoc -- look up a piece of documentation in .pod format that
  1668. # is embedded in the perl installation tree.
  1669. # 
  1670. #~~~~~~
  1671. #
  1672. # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
  1673. #
  1674. # Version 3.01: Sun Nov 10 21:38:09 MST 2002
  1675. #       Sean M. Burke <sburke@cpan.org>
  1676. #       Massive refactoring and code-tidying.
  1677. #       Now it's a module(-family)!
  1678. #       Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
  1679. #       Added -T, -d, -o, -M, -w.
  1680. #       Added some improved MSWin funk.
  1681. #
  1682. #~~~~~~
  1683. #
  1684. # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
  1685. #    Hugo van der Sanden <hv@crypt.org>
  1686. #    Made -U the default, based on patch from Simon Cozens
  1687. # Version 2.04: Sun Aug 18 13:27:12 BST 2002
  1688. #    Randy W. Sims <RandyS@ThePierianSpring.org>
  1689. #    allow -n to enable nroff under Win32
  1690. # Version 2.03: Sun Apr 23 16:56:34 BST 2000
  1691. #    Hugo van der Sanden <hv@crypt.org>
  1692. #    don't die when 'use blib' fails
  1693. # Version 2.02: Mon Mar 13 18:03:04 MST 2000
  1694. #       Tom Christiansen <tchrist@perl.com>
  1695. #    Added -U insecurity option
  1696. # Version 2.01: Sat Mar 11 15:22:33 MST 2000 
  1697. #       Tom Christiansen <tchrist@perl.com>, querulously.
  1698. #       Security and correctness patches.
  1699. #       What a twisted bit of distasteful spaghetti code.
  1700. # Version 2.0: ????
  1701. #
  1702. #~~~~~~
  1703. #
  1704. # Version 1.15: Tue Aug 24 01:50:20 EST 1999
  1705. #       Charles Wilson <cwilson@ece.gatech.edu>
  1706. #    changed /pod/ directory to /pods/ for cygwin
  1707. #         to support cygwin/win32
  1708. # Version 1.14: Wed Jul 15 01:50:20 EST 1998
  1709. #       Robin Barker <rmb1@cise.npl.co.uk>
  1710. #    -strict, -w cleanups
  1711. # Version 1.13: Fri Feb 27 16:20:50 EST 1997
  1712. #       Gurusamy Sarathy <gsar@activestate.com>
  1713. #    -doc tweaks for -F and -X options
  1714. # Version 1.12: Sat Apr 12 22:41:09 EST 1997
  1715. #       Gurusamy Sarathy <gsar@activestate.com>
  1716. #    -various fixes for win32
  1717. # Version 1.11: Tue Dec 26 09:54:33 EST 1995
  1718. #       Kenneth Albanowski <kjahds@kjahds.com>
  1719. #   -added Charles Bailey's further VMS patches, and -u switch
  1720. #   -added -t switch, with pod2text support
  1721. #
  1722. # Version 1.10: Thu Nov  9 07:23:47 EST 1995
  1723. #        Kenneth Albanowski <kjahds@kjahds.com>
  1724. #    -added VMS support
  1725. #    -added better error recognition (on no found pages, just exit. On
  1726. #     missing nroff/pod2man, just display raw pod.)
  1727. #    -added recursive/case-insensitive matching (thanks, Andreas). This
  1728. #     slows things down a bit, unfortunately. Give a precise name, and
  1729. #     it'll run faster.
  1730. #
  1731. # Version 1.01:    Tue May 30 14:47:34 EDT 1995
  1732. #        Andy Dougherty  <doughera@lafcol.lafayette.edu>
  1733. #   -added pod documentation.
  1734. #   -added PATH searching.
  1735. #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
  1736. #    and friends.
  1737. #
  1738. #~~~~~~~
  1739. #
  1740. # TODO:
  1741. #
  1742. #    Cache the directories read during sloppy match
  1743. #       (To disk, or just in-memory?)
  1744. #
  1745. #       Backport this to perl 5.005?
  1746. #
  1747. #       Implement at least part of the "perlman" interface described
  1748. #       in Programming Perl 3e?
  1749.