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