lib/Pod/Perldoc.pm

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