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