lib/Pod/Perldoc.pm

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