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_06';
  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             }
 735             else {
 736                 print STDERR "No " .
 737                     ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
 738             }
 739             next;
 740         }
 741         if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
 742             my $searchfor = catfile split '::', $_;
 743             $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
 744             local $_;
 745             while (<PODIDX>) {
 746                 chomp;
 747                 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
 748             }
 749             close(PODIDX)            or die "Can't close $$self{'podidx'}: $!";
 750             next;
 751         }
 752
 753         $self->aside( "Searching for $_\n" );
 754
 755         if ($self->opt_F) {
 756             next unless -r;
 757             push @found, $_ if $self->opt_m or $self->containspod($_);
 758             next;
 759         }
 760
 761         my @searchdirs;
 762
 763         # prepend extra search directories (including language specific)
 764         push @searchdirs, @{ $self->{'extra_search_dirs'} };
 765
 766         # We must look both in @INC for library modules and in $bindir
 767         # for executables, like h2xs or perldoc itself.
 768         push @searchdirs, ($self->{'bindir'}, @INC);
 769         unless ($self->opt_m) {
 770             if (IS_VMS) {
 771                 my($i,$trn);
 772                 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
 773                     push(@searchdirs,$trn);
 774                 }
 775                 push(@searchdirs,'perl_root:[lib.pods]')  # installed pods
 776             }
 777             else {
 778                 push(@searchdirs, grep(-d, split($Config{path_sep},
 779                                                  $ENV{'PATH'})));
 780             }
 781         }
 782         my @files = $self->searchfor(0,$_,@searchdirs);
 783         if (@files) {
 784             $self->aside( "Found as @files\n" );
 785         }
 786         # add "perl" prefix, so "perldoc foo" may find perlfoo.pod
 787         elsif (BE_LENIENT and !/\W/ and  @files = $self->searchfor(0, "perl$_", @searchdirs)) {
 788             $self->aside( "Loosely found as @files\n" );
 789         }
 790         else {
 791             # no match, try recursive search
 792             @searchdirs = grep(!/^\.\z/s,@INC);
 793             @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
 794             if (@files) {
 795                 $self->aside( "Loosely found as @files\n" );
 796             }
 797             else {
 798                 print STDERR "No " .
 799                     ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
 800                 if ( @{ $self->{'found'} } ) {
 801                     print STDERR "However, try\n";
 802                     my $me = $self->program_name;
 803                     for my $dir (@{ $self->{'found'} }) {
 804                         opendir(DIR, $dir) or die "opendir $dir: $!";
 805                         while (my $file = readdir(DIR)) {
 806                             next if ($file =~ /^\./s);
 807                             $file =~ s/\.(pm|pod)\z//;  # XXX: badfs
 808                             print STDERR "\t$me $_\::$file\n";
 809                         }
 810                         closedir(DIR)    or die "closedir $dir: $!";
 811                     }
 812                 }
 813             }
 814         }
 815         push(@found,@files);
 816     }
 817     return @found;
 818 }
 819
 820 #..........................................................................
 821
 822 sub maybe_generate_dynamic_pod {
 823     my($self, $found_things) = @_;
 824     my @dynamic_pod;
 825
 826     $self->search_perlfunc($found_things, \@dynamic_pod)  if  $self->opt_f;
 827
 828     $self->search_perlvar($found_things, \@dynamic_pod)   if  $self->opt_v;
 829
 830     $self->search_perlfaqs($found_things, \@dynamic_pod)  if  $self->opt_q;
 831
 832     if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) {
 833         DEBUG > 4 and print "That's a non-dynamic pod search.\n";
 834     } elsif ( @dynamic_pod ) {
 835         $self->aside("Hm, I found some Pod from that search!\n");
 836         my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
 837
 838         push @{ $self->{'temp_file_list'} }, $buffer;
 839          # I.e., it MIGHT be deleted at the end.
 840
 841         my $in_list = $self->opt_f || $self->opt_v;
 842
 843         print $buffd "=over 8\n\n" if $in_list;
 844         print $buffd @dynamic_pod  or die "Can't print $buffer: $!";
 845         print $buffd "=back\n"     if $in_list;
 846
 847         close $buffd        or die "Can't close $buffer: $!";
 848
 849         @$found_things = $buffer;
 850           # Yes, so found_things never has more than one thing in
 851           #  it, by time we leave here
 852
 853         $self->add_formatter_option('__filter_nroff' => 1);
 854
 855     } else {
 856         @$found_things = ();
 857         $self->aside("I found no Pod from that search!\n");
 858     }
 859
 860     return;
 861 }
 862
 863 #..........................................................................
 864
 865 sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
 866   my $self = shift;
 867   push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
 868
 869   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
 870    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
 871
 872   return;
 873 }
 874
 875 #.........................................................................
 876
 877 sub new_translator { # $tr = $self->new_translator($lang);
 878     my $self = shift;
 879     my $lang = shift;
 880
 881     my $pack = 'POD2::' . uc($lang);
 882     eval "require $pack";
 883     if ( !$@ && $pack->can('new') ) {
 884         return $pack->new();
 885     }
 886
 887     eval { require POD2::Base };
 888     return if $@;
 889
 890     return POD2::Base->new({ lang => $lang });
 891 }
 892
 893 #.........................................................................
 894
 895 sub add_translator { # $self->add_translator($lang);
 896     my $self = shift;
 897     for my $lang (@_) {
 898         my $tr = $self->new_translator($lang);
 899         if ( defined $tr ) {
 900             push @{ $self->{'translators'} }, $tr;
 901             push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
 902
 903             $self->aside( "translator for '$lang' loaded\n" );
 904         } else {
 905             # non-installed or bad translator package
 906             warn "Perldoc cannot load translator package for '$lang': ignored\n";
 907         }
 908
 909     }
 910     return;
 911 }
 912
 913 #..........................................................................
 914
 915 sub search_perlvar {
 916     my($self, $found_things, $pod) = @_;
 917
 918     my $opt = $self->opt_v;
 919
 920     if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
 921         die "'$opt' does not look like a Perl variable\n";
 922     }
 923
 924     DEBUG > 2 and print "Search: @$found_things\n";
 925
 926     my $perlvar = shift @$found_things;
 927     open(PVAR, "<", $perlvar)               # "Funk is its own reward"
 928         or die("Can't open $perlvar: $!");
 929
 930     if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ...
 931       $opt = '$<I<digits>>';
 932     }
 933     my $search_re = quotemeta($opt);
 934
 935     DEBUG > 2 and
 936      print "Going to perlvar-scan for $search_re in $perlvar\n";
 937
 938     # Skip introduction
 939     local $_;
 940     while (<PVAR>) {
 941         last if /^=over 8/;
 942     }
 943
 944     # Look for our variable
 945     my $found = 0;
 946     my $inheader = 1;
 947     my $inlist = 0;
 948     while (<PVAR>) {  # "The Mothership Connection is here!"
 949         last if /^=head2 Error Indicators/;
 950         # \b at the end of $` and friends borks things!
 951         if ( m/^=item\s+$search_re\s/ )  {
 952             $found = 1;
 953         }
 954         elsif (/^=item/) {
 955             last if $found && !$inheader && !$inlist;
 956         }
 957         elsif (!/^\s+$/) { # not a blank line
 958             if ( $found ) {
 959                 $inheader = 0; # don't accept more =item (unless inlist)
 960             }
 961             else {
 962                 @$pod = (); # reset
 963                 $inheader = 1; # start over
 964                 next;
 965             }
 966         }
 967
 968         if (/^=over/) {
 969             ++$inlist;
 970         }
 971         elsif (/^=back/) {
 972             last if $found && !$inheader && !$inlist;
 973             --$inlist;
 974         }
 975         push @$pod, $_;
 976 #        ++$found if /^\w/;        # found descriptive text
 977     }
 978     @$pod = () unless $found;
 979     if (!@$pod) {
 980         die "No documentation for perl variable '$opt' found\n";
 981     }
 982     close PVAR                or die "Can't open $perlvar: $!";
 983
 984     return;
 985 }
 986
 987 #..........................................................................
 988
 989 sub search_perlfunc {
 990     my($self, $found_things, $pod) = @_;
 991
 992     DEBUG > 2 and print "Search: @$found_things\n";
 993
 994     my $perlfunc = shift @$found_things;
 995     open(PFUNC, "<", $perlfunc)               # "Funk is its own reward"
 996         or die("Can't open $perlfunc: $!");
 997
 998     # Functions like -r, -e, etc. are listed under `-X'.
 999     my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
1000                         ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
1001
1002     DEBUG > 2 and
1003      print "Going to perlfunc-scan for $search_re in $perlfunc\n";
1004
1005     my $re = 'Alphabetical Listing of Perl Functions';
1006
1007     # Check available translator or backup to default (english)
1008     if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
1009         my $tr = $self->{'translators'}->[0];
1010         $re =  $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
1011     }
1012
1013     # Skip introduction
1014     local $_;
1015     while (<PFUNC>) {
1016         last if /^=head2 $re/;
1017     }
1018
1019     # Look for our function
1020     my $found = 0;
1021     my $inlist = 0;
1022     while (<PFUNC>) {  # "The Mothership Connection is here!"
1023         if ( m/^=item\s+$search_re\b/ )  {
1024             $found = 1;
1025         }
1026         elsif (/^=item/) {
1027             last if $found > 1 and not $inlist;
1028         }
1029         next unless $found;
1030         if (/^=over/) {
1031             ++$inlist;
1032         }
1033         elsif (/^=back/) {
1034             last if $found > 1 and not $inlist;
1035             --$inlist;
1036         }
1037         push @$pod, $_;
1038         ++$found if /^\w/;        # found descriptive text
1039     }
1040     if (!@$pod) {
1041         die sprintf
1042           "No documentation for perl function `%s' found\n",
1043           $self->opt_f
1044         ;
1045     }
1046     close PFUNC                or die "Can't open $perlfunc: $!";
1047
1048     return;
1049 }
1050
1051 #..........................................................................
1052
1053 sub search_perlfaqs {
1054     my( $self, $found_things, $pod) = @_;
1055
1056     my $found = 0;
1057     my %found_in;
1058     my $search_key = $self->opt_q;
1059
1060     my $rx = eval { qr/$search_key/ }
1061      or die <<EOD;
1062 Invalid regular expression '$search_key' given as -q pattern:
1063 $@
1064 Did you mean \\Q$search_key ?
1065
1066 EOD
1067
1068     local $_;
1069     foreach my $file (@$found_things) {
1070         die "invalid file spec: $!" if $file =~ /[<>|]/;
1071         open(INFAQ, "<", $file)  # XXX 5.6ism
1072          or die "Can't read-open $file: $!\nAborting";
1073         while (<INFAQ>) {
1074             if ( m/^=head2\s+.*(?:$search_key)/i ) {
1075                 $found = 1;
1076                 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
1077             }
1078             elsif (/^=head[12]/) {
1079                 $found = 0;
1080             }
1081             next unless $found;
1082             push @$pod, $_;
1083         }
1084         close(INFAQ);
1085     }
1086     die("No documentation for perl FAQ keyword `$search_key' found\n")
1087      unless @$pod;
1088
1089     return;
1090 }
1091
1092
1093 #..........................................................................
1094
1095 sub render_findings {
1096   # Return the filename to open
1097
1098   my($self, $found_things) = @_;
1099
1100   my $formatter_class = $self->{'formatter_class'}
1101    || die "No formatter class set!?";
1102   my $formatter = $formatter_class->can('new')
1103     ? $formatter_class->new
1104     : $formatter_class
1105   ;
1106
1107   if(! @$found_things) {
1108     die "Nothing found?!";
1109     # should have been caught before here
1110   } elsif(@$found_things > 1) {
1111     warn
1112      "Perldoc is only really meant for reading one document at a time.\n",
1113      "So these parameters are being ignored: ",
1114      join(' ', @$found_things[1 .. $#$found_things] ),
1115      "\n"
1116   }
1117
1118   my $file = $found_things->[0];
1119
1120   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
1121    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
1122
1123   # Set formatter options:
1124   if( ref $formatter ) {
1125     foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
1126       my($switch, $value, $silent_fail) = @$f;
1127       if( $formatter->can($switch) ) {
1128         eval { $formatter->$switch( defined($value) ? $value : () ) };
1129         warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
1130          if $@;
1131       } else {
1132         if( $silent_fail or $switch =~ m/^__/s ) {
1133           DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
1134         } else {
1135           warn "$formatter_class doesn't recognize the $switch switch.\n";
1136         }
1137       }
1138     }
1139   }
1140
1141   $self->{'output_is_binary'} =
1142     $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
1143
1144   my ($out_fh, $out) = $self->new_output_file(
1145     ( $formatter->can('output_extension') && $formatter->output_extension )
1146      || undef,
1147     $self->useful_filename_bit,
1148   );
1149
1150   # Now, finally, do the formatting!
1151   {
1152     local $^W = $^W;
1153     if(DEBUG() or $self->opt_D) {
1154       # feh, let 'em see it
1155     } else {
1156       $^W = 0;
1157       # The average user just has no reason to be seeing
1158       #  $^W-suppressible warnings from the formatting!
1159     }
1160
1161     eval {  $formatter->parse_from_file( $file, $out_fh )  };
1162   }
1163
1164   warn "Error while formatting with $formatter_class:\n $@\n" if $@;
1165   DEBUG > 2 and print "Back from formatting with $formatter_class\n";
1166
1167   close $out_fh
1168    or warn "Can't close $out: $!\n(Did $formatter already close it?)";
1169   sleep 0; sleep 0; sleep 0;
1170    # Give the system a few timeslices to meditate on the fact
1171    # that the output file does in fact exist and is closed.
1172
1173   $self->unlink_if_temp_file($file);
1174
1175   unless( -s $out ) {
1176     if( $formatter->can( 'if_zero_length' ) ) {
1177       # Basically this is just a hook for Pod::Simple::Checker; since
1178       # what other class could /happily/ format an input file with Pod
1179       # as a 0-length output file?
1180       $formatter->if_zero_length( $file, $out, $out_fh );
1181     } else {
1182       warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
1183     }
1184   }
1185
1186   DEBUG and print "Finished writing to $out.\n";
1187   return($out, $formatter) if wantarray;
1188   return $out;
1189 }
1190
1191 #..........................................................................
1192
1193 sub unlink_if_temp_file {
1194   # Unlink the specified file IFF it's in the list of temp files.
1195   # Really only used in the case of -f / -q things when we can
1196   #  throw away the dynamically generated source pod file once
1197   #  we've formatted it.
1198   #
1199   my($self, $file) = @_;
1200   return unless defined $file and length $file;
1201
1202   my $temp_file_list = $self->{'temp_file_list'} || return;
1203   if(grep $_ eq $file, @$temp_file_list) {
1204     $self->aside("Unlinking $file\n");
1205     unlink($file) or warn "Odd, couldn't unlink $file: $!";
1206   } else {
1207     DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1208   }
1209   return;
1210 }
1211
1212 #..........................................................................
1213
1214 sub MSWin_temp_cleanup {
1215
1216   # Nothing particularly MSWin-specific in here, but I don't know if any
1217   # other OS needs its temp dir policed like MSWin does!
1218
1219   my $self = shift;
1220
1221   my $tempdir = $ENV{'TEMP'};
1222   return unless defined $tempdir and length $tempdir
1223    and -e $tempdir and -d _ and -w _;
1224
1225   $self->aside(
1226    "Considering whether any old files of mine in $tempdir need unlinking.\n"
1227   );
1228
1229   opendir(TMPDIR, $tempdir) || return;
1230   my @to_unlink;
1231
1232   my $limit = time() - $Temp_File_Lifetime;
1233
1234   DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
1235    ($limit) x 2;
1236
1237   my $filespec;
1238
1239   while(defined($filespec = readdir(TMPDIR))) {
1240     if(
1241      $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
1242     ) {
1243       if( hex($1) < $limit ) {
1244         push @to_unlink, "$tempdir/$filespec";
1245         $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
1246       } else {
1247         DEBUG > 5 and
1248          printf "  $tempdir/$filespec is too recent (after %x)\n", $limit;
1249       }
1250     } else {
1251       DEBUG > 5 and
1252        print "  $tempdir/$filespec doesn't look like a perldoc temp file.\n";
1253     }
1254   }
1255   closedir(TMPDIR);
1256   $self->aside(sprintf "Unlinked %s items of mine in %s\n",
1257     scalar(unlink(@to_unlink)),
1258     $tempdir
1259   );
1260   return;
1261 }
1262
1263 #  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
1264
1265 sub MSWin_perldoc_tempfile {
1266   my($self, $suffix, $infix) = @_;
1267
1268   my $tempdir = $ENV{'TEMP'};
1269   return unless defined $tempdir and length $tempdir
1270    and -e $tempdir and -d _ and -w _;
1271
1272   my $spec;
1273
1274   do {
1275     $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
1276       # Yes, we embed the create-time in the filename!
1277       $tempdir,
1278       $infix || 'x',
1279       time(),
1280       $$,
1281       defined( &Win32::GetTickCount )
1282         ? (Win32::GetTickCount() & 0xff)
1283         : int(rand 256)
1284        # Under MSWin, $$ values get reused quickly!  So if we ran
1285        # perldoc foo and then perldoc bar before there was time for
1286        # time() to increment time."_$$" would likely be the same
1287        # for each process!  So we tack on the tick count's lower
1288        # bits (or, in a pinch, rand)
1289       ,
1290       $suffix || 'txt';
1291     ;
1292   } while( -e $spec );
1293
1294   my $counter = 0;
1295
1296   while($counter < 50) {
1297     my $fh;
1298     # If we are running before perl5.6.0, we can't autovivify
1299     if ($] < 5.006) {
1300       require Symbol;
1301       $fh = Symbol::gensym();
1302     }
1303     DEBUG > 3 and print "About to try making temp file $spec\n";
1304     return($fh, $spec) if open($fh, ">", $spec);    # XXX 5.6ism
1305     $self->aside("Can't create temp file $spec: $!\n");
1306   }
1307
1308   $self->aside("Giving up on making a temp file!\n");
1309   die "Can't make a tempfile!?";
1310 }
1311
1312 #..........................................................................
1313
1314
1315 sub after_rendering {
1316   my $self = $_[0];
1317   $self->after_rendering_VMS     if IS_VMS;
1318   $self->after_rendering_MSWin32 if IS_MSWin32;
1319   $self->after_rendering_Dos     if IS_Dos;
1320   $self->after_rendering_OS2     if IS_OS2;
1321   return;
1322 }
1323
1324 sub after_rendering_VMS      { return }
1325 sub after_rendering_Dos      { return }
1326 sub after_rendering_OS2      { return }
1327
1328 sub after_rendering_MSWin32  {
1329   shift->MSWin_temp_cleanup() if $Temp_Files_Created;
1330 }
1331
1332 #..........................................................................
1333 #       :       :       :       :       :       :       :       :       :
1334 #..........................................................................
1335
1336
1337 sub minus_f_nocase {   # i.e., do like -f, but without regard to case
1338
1339      my($self, $dir, $file) = @_;
1340      my $path = catfile($dir,$file);
1341      return $path if -f $path and -r _;
1342
1343      if(!$self->opt_i
1344         or IS_VMS or IS_MSWin32
1345         or IS_Dos or IS_OS2
1346      ) {
1347         # On a case-forgiving file system, or if case is important,
1348         #  that is it, all we can do.
1349         warn "Ignored $path: unreadable\n" if -f _;
1350         return '';
1351      }
1352
1353      local *DIR;
1354      my @p = ($dir);
1355      my($p,$cip);
1356      foreach $p (splitdir $file){
1357         my $try = catfile @p, $p;
1358         $self->aside("Scrutinizing $try...\n");
1359         stat $try;
1360         if (-d _) {
1361             push @p, $p;
1362             if ( $p eq $self->{'target'} ) {
1363                 my $tmp_path = catfile @p;
1364                 my $path_f = 0;
1365                 for (@{ $self->{'found'} }) {
1366                     $path_f = 1 if $_ eq $tmp_path;
1367                 }
1368                 push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1369                 $self->aside( "Found as $tmp_path but directory\n" );
1370             }
1371         }
1372         elsif (-f _ && -r _) {
1373             return $try;
1374         }
1375         elsif (-f _) {
1376             warn "Ignored $try: unreadable\n";
1377         }
1378         elsif (-d catdir(@p)) {  # at least we see the containing directory!
1379             my $found = 0;
1380             my $lcp = lc $p;
1381             my $p_dirspec = catdir(@p);
1382             opendir DIR, $p_dirspec  or die "opendir $p_dirspec: $!";
1383             while(defined( $cip = readdir(DIR) )) {
1384                 if (lc $cip eq $lcp){
1385                     $found++;
1386                     last; # XXX stop at the first? what if there's others?
1387                 }
1388             }
1389             closedir DIR  or die "closedir $p_dirspec: $!";
1390             return "" unless $found;
1391
1392             push @p, $cip;
1393             my $p_filespec = catfile(@p);
1394             return $p_filespec if -f $p_filespec and -r _;
1395             warn "Ignored $p_filespec: unreadable\n" if -f _;
1396         }
1397      }
1398      return "";
1399 }
1400
1401 #..........................................................................
1402
1403 sub pagers_guessing {
1404     my $self = shift;
1405
1406     my @pagers;
1407     push @pagers, $self->pagers;
1408     $self->{'pagers'} = \@pagers;
1409
1410     if (IS_MSWin32) {
1411         push @pagers, qw( more< less notepad );
1412         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
1413     }
1414     elsif (IS_VMS) {
1415         push @pagers, qw( most more less type/page );
1416     }
1417     elsif (IS_Dos) {
1418         push @pagers, qw( less.exe more.com< );
1419         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
1420     }
1421     else {
1422         if (IS_OS2) {
1423           unshift @pagers, 'less', 'cmd /c more <';
1424         }
1425         push @pagers, qw( more less pg view cat );
1426         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
1427     }
1428
1429     if (IS_Cygwin) {
1430         if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
1431             unshift @pagers, '/usr/bin/less -isrR';
1432         }
1433     }
1434
1435     unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
1436
1437     return;
1438 }
1439
1440 #..........................................................................
1441
1442 sub page_module_file {
1443     my($self, @found) = @_;
1444
1445     # Security note:
1446     # Don't ever just pass this off to anything like MSWin's "start.exe",
1447     # since we might be calling on a .pl file, and we wouldn't want that
1448     # to actually /execute/ the file that we just want to page thru!
1449     # Also a consideration if one were to use a web browser as a pager;
1450     # doing so could trigger the browser's MIME mapping for whatever
1451     # it thinks .pm/.pl/whatever is.  Probably just a (useless and
1452     # annoying) "Save as..." dialog, but potentially executing the file
1453     # in question -- particularly in the case of MSIE and it's, ahem,
1454     # occasionally hazy distinction between OS-local extension
1455     # associations, and browser-specific MIME mappings.
1456
1457     if ($self->{'output_to_stdout'}) {
1458         $self->aside("Sending unpaged output to STDOUT.\n");
1459         local $_;
1460         my $any_error = 0;
1461         foreach my $output (@found) {
1462             unless( open(TMP, "<", $output) ) {    # XXX 5.6ism
1463               warn("Can't open $output: $!");
1464               $any_error = 1;
1465               next;
1466             }
1467             while (<TMP>) {
1468                 print or die "Can't print to stdout: $!";
1469             }
1470             close TMP  or die "Can't close while $output: $!";
1471             $self->unlink_if_temp_file($output);
1472         }
1473         return $any_error; # successful
1474     }
1475
1476     foreach my $pager ( $self->pagers ) {
1477         $self->aside("About to try calling $pager @found\n");
1478         if (system($pager, @found) == 0) {
1479             $self->aside("Yay, it worked.\n");
1480             return 0;
1481         }
1482         $self->aside("That didn't work.\n");
1483
1484         # Odd -- when it fails, under Win32, this seems to neither
1485         #  return with a fail nor return with a success!!
1486         #  That's discouraging!
1487     }
1488
1489     $self->aside(
1490       sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
1491       join(' ', @found),
1492       join(' ', $self->pagers),
1493     );
1494
1495     if (IS_VMS) {
1496         DEBUG > 1 and print "Bailing out in a VMSish way.\n";
1497         eval q{
1498             use vmsish qw(status exit);
1499             exit $?;
1500             1;
1501         } or die;
1502     }
1503
1504     return 1;
1505       # i.e., an UNSUCCESSFUL return value!
1506 }
1507
1508 #..........................................................................
1509
1510 sub check_file {
1511     my($self, $dir, $file) = @_;
1512
1513     unless( ref $self ) {
1514       # Should never get called:
1515       $Carp::Verbose = 1;
1516       require Carp;
1517       Carp::croak( join '',
1518         "Crazy ", __PACKAGE__, " error:\n",
1519         "check_file must be an object_method!\n",
1520         "Aborting"
1521       );
1522     }
1523
1524     if(length $dir and not -d $dir) {
1525       DEBUG > 3 and print "  No dir $dir -- skipping.\n";
1526       return "";
1527     }
1528
1529     if ($self->opt_m) {
1530         return $self->minus_f_nocase($dir,$file);
1531     }
1532
1533     else {
1534         my $path = $self->minus_f_nocase($dir,$file);
1535         if( length $path and $self->containspod($path) ) {
1536             DEBUG > 3 and print
1537               "  The file $path indeed looks promising!\n";
1538             return $path;
1539         }
1540     }
1541     DEBUG > 3 and print "  No good: $file in $dir\n";
1542
1543     return "";
1544 }
1545
1546 #..........................................................................
1547
1548 sub containspod {
1549     my($self, $file, $readit) = @_;
1550     return 1 if !$readit && $file =~ /\.pod\z/i;
1551
1552
1553     #  Under cygwin the /usr/bin/perl is legal executable, but
1554     #  you cannot open a file with that name. It must be spelled
1555     #  out as "/usr/bin/perl.exe".
1556     #
1557     #  The following if-case under cygwin prevents error
1558     #
1559     #     $ perldoc perl
1560     #     Cannot open /usr/bin/perl: no such file or directory
1561     #
1562     #  This would work though
1563     #
1564     #     $ perldoc perl.pod
1565
1566     if ( IS_Cygwin  and  -x $file  and  -f "$file.exe" )
1567     {
1568         warn "Cygwin $file.exe search skipped\n"  if DEBUG or $self->opt_D;
1569         return 0;
1570     }
1571
1572     local($_);
1573     open(TEST,"<", $file)       or die "Can't open $file: $!";   # XXX 5.6ism
1574     while (<TEST>) {
1575         if (/^=head/) {
1576             close(TEST)         or die "Can't close $file: $!";
1577             return 1;
1578         }
1579     }
1580     close(TEST)                 or die "Can't close $file: $!";
1581     return 0;
1582 }
1583
1584 #..........................................................................
1585
1586 sub maybe_diddle_INC {
1587   my $self = shift;
1588
1589   # Does this look like a module or extension directory?
1590
1591   if (-f "Makefile.PL" || -f "Build.PL") {
1592
1593     # Add "." and "lib" to @INC (if they exist)
1594     eval q{ use lib qw(. lib); 1; } or die;
1595
1596     # don't add if superuser
1597     if ($< && $> && -d "blib") {   # don't be looking too hard now!
1598       eval q{ use blib; 1 };
1599       warn $@ if $@ && $self->opt_D;
1600     }
1601   }
1602
1603   return;
1604 }
1605
1606 #..........................................................................
1607
1608 sub new_output_file {
1609   my $self = shift;
1610   my $outspec = $self->opt_d;  # Yes, -d overrides all else!
1611                                # So don't call this twice per format-job!
1612
1613   return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1614
1615   # Otherwise open a write-handle on opt_d!f
1616
1617   my $fh;
1618   # If we are running before perl5.6.0, we can't autovivify
1619   if ($] < 5.006) {
1620     require Symbol;
1621     $fh = Symbol::gensym();
1622   }
1623   DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1624   die "Can't write-open $outspec: $!"
1625    unless open($fh, ">", $outspec); # XXX 5.6ism
1626
1627   DEBUG > 3 and print "Successfully opened $outspec\n";
1628   binmode($fh) if $self->{'output_is_binary'};
1629   return($fh, $outspec);
1630 }
1631
1632 #..........................................................................
1633
1634 sub useful_filename_bit {
1635   # This tries to provide a meaningful bit of text to do with the query,
1636   # such as can be used in naming the file -- since if we're going to be
1637   # opening windows on temp files (as a "pager" may well do!) then it's
1638   # better if the temp file's name (which may well be used as the window
1639   # title) isn't ALL just random garbage!
1640   # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1641   # name than "perldoc_2371981429".  So this routine is what tries to
1642   # provide the "LWPSimple" bit.
1643   #
1644   my $self = shift;
1645   my $pages = $self->{'pages'} || return undef;
1646   return undef unless @$pages;
1647
1648   my $chunk = $pages->[0];
1649   return undef unless defined $chunk;
1650   $chunk =~ s/:://g;
1651   $chunk =~ s/\.\w+$//g; # strip any extension
1652   if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1653     $chunk = $1;
1654   } else {
1655     return undef;
1656   }
1657   $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1658   $chunk = substr($chunk, -10) if length($chunk) > 10;
1659   return $chunk;
1660 }
1661
1662 #..........................................................................
1663
1664 sub new_tempfile {    # $self->new_tempfile( [$suffix, [$infix] ] )
1665   my $self = shift;
1666
1667   ++$Temp_Files_Created;
1668
1669   if( IS_MSWin32 ) {
1670     my @out = $self->MSWin_perldoc_tempfile(@_);
1671     return @out if @out;
1672     # otherwise fall thru to the normal stuff below...
1673   }
1674
1675   require File::Temp;
1676   return File::Temp::tempfile(UNLINK => 1);
1677 }
1678
1679 #..........................................................................
1680
1681 sub page {  # apply a pager to the output file
1682     my ($self, $output, $output_to_stdout, @pagers) = @_;
1683     if ($output_to_stdout) {
1684         $self->aside("Sending unpaged output to STDOUT.\n");
1685         open(TMP, "<", $output)  or  die "Can't open $output: $!"; # XXX 5.6ism
1686         local $_;
1687         while (<TMP>) {
1688             print or die "Can't print to stdout: $!";
1689         }
1690         close TMP  or die "Can't close while $output: $!";
1691         $self->unlink_if_temp_file($output);
1692     } else {
1693         # On VMS, quoting prevents logical expansion, and temp files with no
1694         # extension get the wrong default extension (such as .LIS for TYPE)
1695
1696         $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
1697
1698         $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
1699           # Altho "/" under MSWin is in theory good as a pathsep,
1700           #  many many corners of the OS don't like it.  So we
1701           #  have to force it to be "\" to make everyone happy.
1702
1703         foreach my $pager (@pagers) {
1704             $self->aside("About to try calling $pager $output\n");
1705             if (IS_VMS) {
1706                 last if system("$pager $output") == 0;
1707             } else {
1708                 last if system("$pager \"$output\"") == 0;
1709             }
1710         }
1711     }
1712     return;
1713 }
1714
1715 #..........................................................................
1716
1717 sub searchfor {
1718     my($self, $recurse,$s,@dirs) = @_;
1719     $s =~ s!::!/!g;
1720     $s = VMS::Filespec::unixify($s) if IS_VMS;
1721     return $s if -f $s && $self->containspod($s);
1722     $self->aside( "Looking for $s in @dirs\n" );
1723     my $ret;
1724     my $i;
1725     my $dir;
1726     $self->{'target'} = (splitdir $s)[-1];  # XXX: why not use File::Basename?
1727     for ($i=0; $i<@dirs; $i++) {
1728         $dir = $dirs[$i];
1729         next unless -d $dir;
1730         ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
1731         if (       (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1732                 or ( $ret = $self->check_file($dir,"$s.pm"))
1733                 or ( $ret = $self->check_file($dir,$s))
1734                 or ( IS_VMS and
1735                      $ret = $self->check_file($dir,"$s.com"))
1736                 or ( IS_OS2 and
1737                      $ret = $self->check_file($dir,"$s.cmd"))
1738                 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
1739                      $ret = $self->check_file($dir,"$s.bat"))
1740                 or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1741                 or ( $ret = $self->check_file("$dir/pod",$s))
1742                 or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1743                 or ( $ret = $self->check_file("$dir/pods",$s))
1744         ) {
1745             DEBUG > 1 and print "  Found $ret\n";
1746             return $ret;
1747         }
1748
1749         if ($recurse) {
1750             opendir(D,$dir)     or die "Can't opendir $dir: $!";
1751             my @newdirs = map catfile($dir, $_), grep {
1752                 not /^\.\.?\z/s and
1753                 not /^auto\z/s  and   # save time! don't search auto dirs
1754                 -d  catfile($dir, $_)
1755             } readdir D;
1756             closedir(D)         or die "Can't closedir $dir: $!";
1757             next unless @newdirs;
1758             # what a wicked map!
1759             @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
1760             $self->aside( "Also looking in @newdirs\n" );
1761             push(@dirs,@newdirs);
1762         }
1763     }
1764     return ();
1765 }
1766
1767 #..........................................................................
1768 {
1769   my $already_asserted;
1770   sub assert_closing_stdout {
1771     my $self = shift;
1772
1773     return if $already_asserted;
1774
1775     eval  q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
1776      # What for? to let the pager know that nothing more will come?
1777
1778     die $@ if $@;
1779     $already_asserted = 1;
1780     return;
1781   }
1782 }
1783
1784 #..........................................................................
1785
1786 sub tweak_found_pathnames {
1787   my($self, $found) = @_;
1788   if (IS_MSWin32) {
1789     foreach (@$found) { s,/,\\,g }
1790   }
1791   return;
1792 }
1793
1794 #..........................................................................
1795 #       :       :       :       :       :       :       :       :       :
1796 #..........................................................................
1797
1798 sub am_taint_checking {
1799     my $self = shift;
1800     die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
1801     my($k,$v) = each %ENV;
1802     return is_tainted($v);
1803 }
1804
1805 #..........................................................................
1806
1807 sub is_tainted { # just a function
1808     my $arg  = shift;
1809     my $nada = substr($arg, 0, 0);  # zero-length!
1810     local $@;  # preserve the caller's version of $@
1811     eval { eval "# $nada" };
1812     return length($@) != 0;
1813 }
1814
1815 #..........................................................................
1816
1817 sub drop_privs_maybe {
1818     my $self = shift;
1819
1820     # Attempt to drop privs if we should be tainting and aren't
1821     if (!(IS_VMS || IS_MSWin32 || IS_Dos
1822           || IS_OS2
1823          )
1824         && ($> == 0 || $< == 0)
1825         && !$self->am_taint_checking()
1826     ) {
1827         my $id = eval { getpwnam("nobody") };
1828         $id = eval { getpwnam("nouser") } unless defined $id;
1829         $id = -2 unless defined $id;
1830             #
1831             # According to Stevens' APUE and various
1832             # (BSD, Solaris, HP-UX) man pages, setting
1833             # the real uid first and effective uid second
1834             # is the way to go if one wants to drop privileges,
1835             # because if one changes into an effective uid of
1836             # non-zero, one cannot change the real uid any more.
1837             #
1838             # Actually, it gets even messier.  There is
1839             # a third uid, called the saved uid, and as
1840             # long as that is zero, one can get back to
1841             # uid of zero.  Setting the real-effective *twice*
1842             # helps in *most* systems (FreeBSD and Solaris)
1843             # but apparently in HP-UX even this doesn't help:
1844             # the saved uid stays zero (apparently the only way
1845             # in HP-UX to change saved uid is to call setuid()
1846             # when the effective uid is zero).
1847             #
1848         eval {
1849             $< = $id; # real uid
1850             $> = $id; # effective uid
1851             $< = $id; # real uid
1852             $> = $id; # effective uid
1853         };
1854         if( !$@ && $< && $> ) {
1855           DEBUG and print "OK, I dropped privileges.\n";
1856         } elsif( $self->opt_U ) {
1857           DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
1858         } else {
1859           DEBUG and print "Hm, couldn't drop privileges.  Ah well.\n";
1860           # We used to die here; but that seemed pointless.
1861         }
1862     }
1863     return;
1864 }
1865
1866 #..........................................................................
1867
1868 1;
1869
1870 __END__
1871
1872 =head1 NAME
1873
1874 Pod::Perldoc - Look up Perl documentation in Pod format.
1875
1876 =head1 SYNOPSIS
1877
1878     use Pod::Perldoc ();
1879
1880     Pod::Perldoc->run();
1881
1882 =head1 DESCRIPTION
1883
1884 The guts of L<perldoc> utility.
1885
1886 =head1 SEE ALSO
1887
1888 L<perldoc>
1889
1890 =head1 COPYRIGHT AND DISCLAIMERS
1891
1892 Copyright (c) 2002-2007 Sean M. Burke.
1893
1894 This library is free software; you can redistribute it and/or modify it
1895 under the same terms as Perl itself.
1896
1897 This program is distributed in the hope that it will be useful, but
1898 without any warranty; without even the implied warranty of
1899 merchantability or fitness for a particular purpose.
1900
1901 =head1 AUTHOR
1902
1903 Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
1904
1905 Past contributions from:
1906 Sean M. Burke <sburke@cpan.org>
1907
1908 =cut
1909
1910 #
1911 #
1912 # Perldoc -- look up a piece of documentation in .pod format that
1913 # is embedded in the perl installation tree.
1914 #
1915 #~~~~~~
1916 #
1917 # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
1918 #
1919 # Version 3.01: Sun Nov 10 21:38:09 MST 2002
1920 #       Sean M. Burke <sburke@cpan.org>
1921 #       Massive refactoring and code-tidying.
1922 #       Now it's a module(-family)!
1923 #       Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
1924 #       Added -T, -d, -o, -M, -w.
1925 #       Added some improved MSWin funk.
1926 #
1927 #~~~~~~
1928 #
1929 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
1930 #       Hugo van der Sanden <hv@crypt.org>
1931 #       Made -U the default, based on patch from Simon Cozens
1932 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
1933 #       Randy W. Sims <RandyS@ThePierianSpring.org>
1934 #       allow -n to enable nroff under Win32
1935 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
1936 #       Hugo van der Sanden <hv@crypt.org>
1937 #       don't die when 'use blib' fails
1938 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
1939 #       Tom Christiansen <tchrist@perl.com>
1940 #       Added -U insecurity option
1941 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
1942 #       Tom Christiansen <tchrist@perl.com>, querulously.
1943 #       Security and correctness patches.
1944 #       What a twisted bit of distasteful spaghetti code.
1945 # Version 2.0: ????
1946 #
1947 #~~~~~~
1948 #
1949 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
1950 #       Charles Wilson <cwilson@ece.gatech.edu>
1951 #       changed /pod/ directory to /pods/ for cygwin
1952 #         to support cygwin/win32
1953 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
1954 #       Robin Barker <rmb1@cise.npl.co.uk>
1955 #       -strict, -w cleanups
1956 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
1957 #       Gurusamy Sarathy <gsar@activestate.com>
1958 #       -doc tweaks for -F and -X options
1959 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
1960 #       Gurusamy Sarathy <gsar@activestate.com>
1961 #       -various fixes for win32
1962 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
1963 #       Kenneth Albanowski <kjahds@kjahds.com>
1964 #   -added Charles Bailey's further VMS patches, and -u switch
1965 #   -added -t switch, with pod2text support
1966 #
1967 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
1968 #               Kenneth Albanowski <kjahds@kjahds.com>
1969 #       -added VMS support
1970 #       -added better error recognition (on no found pages, just exit. On
1971 #        missing nroff/pod2man, just display raw pod.)
1972 #       -added recursive/case-insensitive matching (thanks, Andreas). This
1973 #        slows things down a bit, unfortunately. Give a precise name, and
1974 #        it'll run faster.
1975 #
1976 # Version 1.01: Tue May 30 14:47:34 EDT 1995
1977 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
1978 #   -added pod documentation.
1979 #   -added PATH searching.
1980 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
1981 #    and friends.
1982 #
1983 #~~~~~~~
1984 #
1985 # TODO:
1986 #
1987 #       Cache the directories read during sloppy match
1988 #       (To disk, or just in-memory?)
1989 #
1990 #       Backport this to perl 5.005?
1991 #
1992 #       Implement at least part of the "perlman" interface described
1993 #       in Programming Perl 3e?