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