lib/Pod/Perldoc.pm

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