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