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