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