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