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