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