lib/Pod/Perldoc.pm

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