cpan/Pod-Perldoc/lib/Pod/Perldoc.pm

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