3 use 5.006; # we use some open(X, "<", $y) syntax
9 use Fcntl; # for sysopen
10 use File::Spec::Functions qw(catfile catdir splitdir);
12 use vars qw($VERSION @Pagers $Bindir $Pod2man
13 $Temp_Files_Created $Temp_File_Lifetime
16 #..........................................................................
18 BEGIN { # Make a DEBUG constant very first thing...
19 unless(defined &DEBUG) {
20 if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
21 eval("sub DEBUG () {$1}");
22 die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
29 use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
31 #..........................................................................
38 *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
39 *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
40 *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
41 *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
42 *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
43 *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
44 *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
47 $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
48 # If it's older than five days, it's quite unlikely
49 # that anyone's still looking at it!!
50 # (Currently used only by the MSWin cleanup routine)
53 #..........................................................................
54 { my $pager = $Config{'pager'};
55 push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
57 $Bindir = $Config{'scriptdirexp'};
58 $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
60 # End of class-init stuff
62 ###########################################################################
66 foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) {
68 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
71 # And these are so that GetOptsOO knows they take options:
72 sub opt_f_with { shift->_elem('opt_f', @_) }
73 sub opt_q_with { shift->_elem('opt_q', @_) }
74 sub opt_d_with { shift->_elem('opt_d', @_) }
75 sub opt_L_with { shift->_elem('opt_L', @_) }
76 sub opt_v_with { shift->_elem('opt_v', @_) }
78 sub opt_w_with { # Specify an option for the formatter subclass
79 my($self, $value) = @_;
80 if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
82 my $option_value = defined($2) ? $2 : "TRUE";
83 $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
84 $self->add_formatter_option( $option, $option_value );
86 warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
91 sub opt_M_with { # specify formatter class name(s)
92 my($self, $classes) = @_;
93 return unless defined $classes and length $classes;
94 DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
96 foreach my $classname (split m/[,;]+/s, $classes) {
97 next unless $classname =~ m/\S/;
98 if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
99 # A mildly restrictive concept of what modulenames are valid.
100 push @classes_to_add, $1; # untaint
102 warn "\"$classname\" isn't a valid classname. Ignoring.\n";
106 unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
109 "Adding @classes_to_add to the list of formatter classes, "
110 . "making them @{ $self->{'formatter_classes'} }.\n"
116 sub opt_V { # report version and exit
118 "Perldoc v$VERSION, under perl v$] for $^O",
120 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
121 ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
123 (chr(65) eq 'A') ? () : " (non-ASCII)",
130 sub opt_t { # choose plaintext as output format
132 $self->opt_o_with('text') if @_ and $_[0];
133 return $self->_elem('opt_t', @_);
136 sub opt_u { # choose raw pod as output format
138 $self->opt_o_with('pod') if @_ and $_[0];
139 return $self->_elem('opt_u', @_);
143 # choose man as the output format, and specify the proggy to run
145 $self->opt_o_with('man') if @_ and $_[0];
146 $self->_elem('opt_n', @_);
149 sub opt_o_with { # "o" for output format
150 my($self, $rest) = @_;
151 return unless defined $rest and length $rest;
152 if($rest =~ m/^(\w+)$/s) {
155 warn "\"$rest\" isn't a valid output format. Skipping.\n";
159 $self->aside("Noting \"$rest\" as desired output format...\n");
161 # Figure out what class(es) that could actually mean...
164 foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
167 $rest, # Yes, try it first with the given capitalization
168 "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
171 push @classes, $prefix . $stem;
172 #print "Considering $prefix$stem\n";
175 # Tidier, but misses too much:
176 #push @classes, $prefix . ucfirst(lc($rest));
178 $self->opt_M_with( join ";", @classes );
182 ###########################################################################
183 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
185 sub run { # to be called by the "perldoc" executable
188 print "Parameters to $class\->run:\n";
191 $x[1] = '<undef>' unless defined $x[1];
192 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
193 print " [$x[0]] => [$x[1]]\n";
198 return $class -> new(@_) -> process() || 0;
201 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
202 ###########################################################################
204 sub new { # yeah, nothing fancy
206 my $new = bless {@_}, (ref($class) || $class);
207 DEBUG > 1 and print "New $class object $new\n";
212 #..........................................................................
214 sub aside { # If we're in -D or DEBUG mode, say this.
216 if( DEBUG or $self->opt_D ) {
219 my $callsub = (caller(1))[3];
220 my $package = quotemeta(__PACKAGE__ . '::');
221 $callsub =~ s/^$package/'/os;
222 # the o is justified, as $package really won't change.
227 if(DEBUG) { print $out } else { print STDERR $out }
232 #..........................................................................
238 # Erase evidence of previous errors (if any), so exit status is simple.
242 perldoc [options] PageName|ModuleName|ProgramName...
243 perldoc [options] -f BuiltinFunction
244 perldoc [options] -q FAQRegex
245 perldoc [options] -v PerlVariable
248 -h Display this help message
250 -r Recursive search (slow)
252 -t Display pod using pod2text instead of pod2man and nroff
253 (-t is the default on win32 unless -n is specified)
254 -u Display unformatted pod text
255 -m Display module's file in its entirety
256 -n Specify replacement for nroff
257 -l Display the module's file name
258 -F Arguments are file names, not modules
259 -D Verbosely describe what's going on
260 -T Send output to STDOUT without any pager
261 -d output_filename_to_send_to
262 -o output_format_name
263 -M FormatterModuleNameToUse
264 -w formatter_option:option_value
265 -L translation_code Choose doc translation (if any)
266 -X use index if present (looks for pod.idx at $Config{archlib})
267 -q Search the text of questions (not answers) in perlfaq[1-9]
268 -f Search Perl built-in functions
269 -v Search predefined Perl variables
271 PageName|ModuleName...
272 is the name of a piece of documentation that you want to look at. You
273 may either give a descriptive name of the page (as in the case of
274 `perlfunc') the name of a module, either like `Term::Info' or like
275 `Term/Info', or the name of a program, like `perldoc'.
278 is the name of a perl function. Will extract documentation from
282 is a regex. Will search perlfaq[1-9] for and extract any
283 questions that match.
285 Any switches in the PERLDOC environment variable will be used before the
286 command line arguments. The optional pod index file contains a list of
287 filenames, one per line.
293 #..........................................................................
296 my $me = $0; # Editing $0 is unportable
298 $me =~ s,.*[/\\],,; # get basename
301 Usage: $me [-h] [-V] [-r] [-i] [-D] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
306 The -h option prints more help. Also try "perldoc perldoc" to get
307 acquainted with the system. [Perldoc v$VERSION]
312 #..........................................................................
314 sub pagers { @{ shift->{'pagers'} } }
316 #..........................................................................
318 sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
319 if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
320 else { return $_[0]{ $_[1] } }
322 #..........................................................................
323 ###########################################################################
325 # Init formatter switches, and start it off with __bindir and all that
326 # other stuff that ToMan.pm needs.
332 # Make sure creat()s are neither too much nor too little
333 eval { umask(0077) }; # doubtless someone has no mask
335 $self->{'args'} ||= \@ARGV;
336 $self->{'found'} ||= [];
337 $self->{'temp_file_list'} ||= [];
340 $self->{'target'} = undef;
342 $self->init_formatter_class_list;
344 $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
345 $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
346 $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
348 push @{ $self->{'formatter_switches'} = [] }, (
349 # Yeah, we could use a hashref, but maybe there's some class where options
350 # have to be ordered; so we'll use an arrayref.
352 [ '__bindir' => $self->{'bindir' } ],
353 [ '__pod2man' => $self->{'pod2man'} ],
356 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
357 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
359 $self->{'translators'} = [];
360 $self->{'extra_search_dirs'} = [];
365 #..........................................................................
367 sub init_formatter_class_list {
369 $self->{'formatter_classes'} ||= [];
371 # Remember, no switches have been read yet, when
372 # we've started this routine.
374 $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
375 $self->opt_o_with('text');
376 $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
378 ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
384 #..........................................................................
387 # if this ever returns, its retval will be used for exit(RETVAL)
390 DEBUG > 1 and print " Beginning process.\n";
391 DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
393 print "Object contents:\n";
396 $x[1] = '<undef>' unless defined $x[1];
397 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
398 print " [$x[0]] => [$x[1]]\n";
404 # TODO: make it deal with being invoked as various different things
407 return $self->usage_brief unless @{ $self->{'args'} };
408 $self->pagers_guessing;
409 $self->options_reading;
410 $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
411 $self->drop_privs_maybe;
412 $self->options_processing;
414 # Hm, we have @pages and @found, but we only really act on one
415 # file per call, with the exception of the opt_q hack, and with
421 $self->{'pages'} = \@pages;
422 if( $self->opt_f) { @pages = ("perlfunc") }
423 elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
424 elsif( $self->opt_v) { @pages = ("perlvar") }
425 else { @pages = @{$self->{'args'}};
427 # if @pages == 1 and $pages[0] eq 'perldoc';
430 return $self->usage_brief unless @pages;
432 $self->find_good_formatter_class();
433 $self->formatter_sanity_check();
435 $self->maybe_diddle_INC();
436 # for when we're apparently in a module or extension directory
438 my @found = $self->grand_search_init(\@pages);
439 exit (IS_VMS ? 98962 : 1) unless @found;
442 DEBUG and print "We're in -l mode, so byebye after this:\n";
443 print join("\n", @found), "\n";
447 $self->tweak_found_pathnames(\@found);
448 $self->assert_closing_stdout;
449 return $self->page_module_file(@found) if $self->opt_m;
450 DEBUG > 2 and print "Found: [@found]\n";
452 return $self->render_and_page(\@found);
455 #..........................................................................
458 my( %class_seen, %class_loaded );
459 sub find_good_formatter_class {
461 my @class_list = @{ $self->{'formatter_classes'} || [] };
462 die "WHAT? Nothing in the formatter class list!?" unless @class_list;
464 my $good_class_found;
465 foreach my $c (@class_list) {
466 DEBUG > 4 and print "Trying to load $c...\n";
467 if($class_loaded{$c}) {
468 DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
469 $good_class_found = $c;
473 if($class_seen{$c}) {
475 "I've tried $c before, and it's no good. Skipping.\n";
481 if( $c->can('parse_from_file') ) {
483 "Interesting, the formatter class $c is already loaded!\n";
486 (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
487 # the alway case-insensitive fs's
488 and $class_seen{lc("~$c")}++
491 "We already used something quite like \"\L$c\E\", so no point using $c\n";
492 # This avoids redefining the package.
494 DEBUG > 4 and print "Trying to eval 'require $c'...\n";
497 if(DEBUG() or $self->opt_D) {
498 # feh, let 'em see it
501 # The average user just has no reason to be seeing
502 # $^W-suppressable warnings from the the require!
507 DEBUG > 4 and print "Couldn't load $c: $!\n";
512 if( $c->can('parse_from_file') ) {
513 DEBUG > 4 and print "Settling on $c\n";
515 $v = ( defined $v and length $v ) ? " version $v" : '';
516 $self->aside("Formatter class $c$v successfully loaded!\n");
517 $good_class_found = $c;
520 DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
524 die "Can't find any loadable formatter class in @class_list?!\nAborting"
525 unless $good_class_found;
527 $self->{'formatter_class'} = $good_class_found;
528 $self->aside("Will format with the class $good_class_found\n");
534 #..........................................................................
536 sub formatter_sanity_check {
538 my $formatter_class = $self->{'formatter_class'}
539 || die "NO FORMATTER CLASS YET!?";
541 if(!$self->opt_T # so -T can FORCE sending to STDOUT
542 and $formatter_class->can('is_pageable')
543 and !$formatter_class->is_pageable
544 and !$formatter_class->can('page_for_perldoc')
547 ($formatter_class->can('output_extension')
548 && $formatter_class->output_extension
550 $ext = ".$ext" if length $ext;
553 "When using Perldoc to format with $formatter_class, you have to\n"
554 . "specify -T or -dsomefile$ext\n"
555 . "See `perldoc perldoc' for more information on those switches.\n"
560 #..........................................................................
562 sub render_and_page {
563 my($self, $found_list) = @_;
565 $self->maybe_generate_dynamic_pod($found_list);
567 my($out, $formatter) = $self->render_findings($found_list);
570 printf "Perldoc (%s) output saved to %s\n",
571 $self->{'formatter_class'} || ref($self),
573 print "But notice that it's 0 bytes long!\n" unless -s $out;
576 } elsif( # Allow the formatter to "page" itself, if it wants.
577 $formatter->can('page_for_perldoc')
579 $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
580 if( $formatter->page_for_perldoc($out, $self) ) {
581 $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
584 $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
589 # Do nothing, since the formatter has "paged" it for itself.
592 # Page it normally (internally)
594 if( -s $out ) { # Usual case:
595 $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
599 $self->aside("Skipping $out (from $$found_list[0] "
600 . "via $$self{'formatter_class'}) as it is 0-length.\n");
602 push @{ $self->{'temp_file_list'} }, $out;
603 $self->unlink_if_temp_file($out);
607 $self->after_rendering(); # any extra cleanup or whatever
612 #..........................................................................
614 sub options_reading {
617 if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
618 require Text::ParseWords;
619 $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
620 # Yes, appends to the beginning
621 unshift @{ $self->{'args'} },
622 Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
624 DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
626 DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
630 and print " Args right before switch processing: @{$self->{'args'}}\n";
632 Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
633 or return $self->usage;
636 and print " Args after switch processing: @{$self->{'args'}}\n";
638 return $self->usage if $self->opt_h;
643 #..........................................................................
645 sub options_processing {
649 my $podidx = "$Config{'archlib'}/pod.idx";
650 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
651 $self->{'podidx'} = $podidx;
654 $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
656 $self->options_sanity;
658 $self->opt_n("nroff") unless $self->opt_n;
659 $self->add_formatter_option( '__nroffer' => $self->opt_n );
661 # Adjust for using translation packages
662 $self->add_translator($self->opt_L) if $self->opt_L;
667 #..........................................................................
672 # The opts-counting stuff interacts quite badly with
673 # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
674 # set to -t, and I specify -u on the command line, I don't want
675 # to be hectored at that -u and -t don't make sense together.
677 #my $opts = grep $_ && 1, # yes, the count of the set ones
678 # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
681 #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
684 # Any sanity-checking need doing here?
686 # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
687 if( $self->opt_f or $self->opt_q ) {
688 $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
690 "Perldoc is only really meant for reading one word at a time.\n",
691 "So these parameters are being ignored: ",
692 join(' ', @{$self->{'args'}}),
694 if @{$self->{'args'}}
699 #..........................................................................
701 sub grand_search_init {
702 my($self, $pages, @found) = @_;
705 if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
706 my $searchfor = catfile split '::', $_;
707 $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
711 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
713 close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
717 $self->aside( "Searching for $_\n" );
721 push @found, $_ if $self->opt_m or $self->containspod($_);
727 # prepend extra search directories (including language specific)
728 push @searchdirs, @{ $self->{'extra_search_dirs'} };
730 # We must look both in @INC for library modules and in $bindir
731 # for executables, like h2xs or perldoc itself.
732 push @searchdirs, ($self->{'bindir'}, @INC);
733 unless ($self->opt_m) {
736 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
737 push(@searchdirs,$trn);
739 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
742 push(@searchdirs, grep(-d, split($Config{path_sep},
746 my @files = $self->searchfor(0,$_,@searchdirs);
748 $self->aside( "Found as @files\n" );
750 # add "perl" prefix, so "perldoc foo" may find perlfoo.pod
751 elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) {
752 $self->aside( "Loosely found as @files\n" );
755 # no match, try recursive search
756 @searchdirs = grep(!/^\.\z/s,@INC);
757 @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
759 $self->aside( "Loosely found as @files\n" );
763 ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
764 if ( @{ $self->{'found'} } ) {
765 print STDERR "However, try\n";
766 for my $dir (@{ $self->{'found'} }) {
767 opendir(DIR, $dir) or die "opendir $dir: $!";
768 while (my $file = readdir(DIR)) {
769 next if ($file =~ /^\./s);
770 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
771 print STDERR "\tperldoc $_\::$file\n";
773 closedir(DIR) or die "closedir $dir: $!";
783 #..........................................................................
785 sub maybe_generate_dynamic_pod {
786 my($self, $found_things) = @_;
789 $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
791 $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v;
793 $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
795 if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) {
796 DEBUG > 4 and print "That's a non-dynamic pod search.\n";
797 } elsif ( @dynamic_pod ) {
798 $self->aside("Hm, I found some Pod from that search!\n");
799 my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
801 push @{ $self->{'temp_file_list'} }, $buffer;
802 # I.e., it MIGHT be deleted at the end.
804 my $in_list = $self->opt_f || $self->opt_v;
806 print $buffd "=over 8\n\n" if $in_list;
807 print $buffd @dynamic_pod or die "Can't print $buffer: $!";
808 print $buffd "=back\n" if $in_list;
810 close $buffd or die "Can't close $buffer: $!";
812 @$found_things = $buffer;
813 # Yes, so found_things never has more than one thing in
814 # it, by time we leave here
816 $self->add_formatter_option('__filter_nroff' => 1);
820 $self->aside("I found no Pod from that search!\n");
826 #..........................................................................
828 sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
830 push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
832 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
833 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
838 #.........................................................................
840 sub new_translator { # $tr = $self->new_translator($lang);
844 my $pack = 'POD2::' . uc($lang);
845 eval "require $pack";
846 if ( !$@ && $pack->can('new') ) {
850 eval { require POD2::Base };
853 return POD2::Base->new({ lang => $lang });
856 #.........................................................................
858 sub add_translator { # $self->add_translator($lang);
861 my $tr = $self->new_translator($lang);
863 push @{ $self->{'translators'} }, $tr;
864 push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
866 $self->aside( "translator for '$lang' loaded\n" );
868 # non-installed or bad translator package
869 warn "Perldoc cannot load translator package for '$lang': ignored\n";
876 #..........................................................................
879 my($self, $found_things, $pod) = @_;
881 my $opt = $self->opt_v;
883 if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
884 die "'$opt' does not look like a Perl variable\n";
887 DEBUG > 2 and print "Search: @$found_things\n";
889 my $perlvar = shift @$found_things;
890 open(PVAR, "<", $perlvar) # "Funk is its own reward"
891 or die("Can't open $perlvar: $!");
893 if ( $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9
894 $opt = '$<I<digits>>';
896 my $search_re = quotemeta($opt);
899 print "Going to perlvar-scan for $search_re in $perlvar\n";
907 # Look for our variable
911 while (<PVAR>) { # "The Mothership Connection is here!"
912 last if /^=head2 Error Indicators/;
913 # \b at the end of $` and friends borks things!
914 if ( m/^=item\s+$search_re\s/ ) {
918 last if $found && !$inheader && !$inlist;
920 elsif (!/^\s+$/) { # not a blank line
922 $inheader = 0; # don't accept more =item (unless inlist)
926 $inheader = 1; # start over
938 # ++$found if /^\w/; # found descriptive text
940 @$pod = () unless $found;
942 die "No documentation for perl variable '$opt' found\n";
944 close PVAR or die "Can't open $perlvar: $!";
949 #..........................................................................
951 sub search_perlfunc {
952 my($self, $found_things, $pod) = @_;
954 DEBUG > 2 and print "Search: @$found_things\n";
956 my $perlfunc = shift @$found_things;
957 open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
958 or die("Can't open $perlfunc: $!");
960 # Functions like -r, -e, etc. are listed under `-X'.
961 my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
962 ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
965 print "Going to perlfunc-scan for $search_re in $perlfunc\n";
967 my $re = 'Alphabetical Listing of Perl Functions';
968 if ( $self->opt_L ) {
969 my $tr = $self->{'translators'}->[0];
970 $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
976 last if /^=head2 $re/;
979 # Look for our function
982 while (<PFUNC>) { # "The Mothership Connection is here!"
983 if ( m/^=item\s+$search_re\b/ ) {
987 last if $found > 1 and not $inlist;
997 ++$found if /^\w/; # found descriptive text
1001 "No documentation for perl function `%s' found\n",
1005 close PFUNC or die "Can't open $perlfunc: $!";
1010 #..........................................................................
1012 sub search_perlfaqs {
1013 my( $self, $found_things, $pod) = @_;
1017 my $search_key = $self->opt_q;
1019 my $rx = eval { qr/$search_key/ }
1021 Invalid regular expression '$search_key' given as -q pattern:
1023 Did you mean \\Q$search_key ?
1028 foreach my $file (@$found_things) {
1029 die "invalid file spec: $!" if $file =~ /[<>|]/;
1030 open(INFAQ, "<", $file) # XXX 5.6ism
1031 or die "Can't read-open $file: $!\nAborting";
1033 if ( m/^=head2\s+.*(?:$search_key)/i ) {
1035 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
1037 elsif (/^=head[12]/) {
1045 die("No documentation for perl FAQ keyword `$search_key' found\n")
1052 #..........................................................................
1054 sub render_findings {
1055 # Return the filename to open
1057 my($self, $found_things) = @_;
1059 my $formatter_class = $self->{'formatter_class'}
1060 || die "No formatter class set!?";
1061 my $formatter = $formatter_class->can('new')
1062 ? $formatter_class->new
1066 if(! @$found_things) {
1067 die "Nothing found?!";
1068 # should have been caught before here
1069 } elsif(@$found_things > 1) {
1071 "Perldoc is only really meant for reading one document at a time.\n",
1072 "So these parameters are being ignored: ",
1073 join(' ', @$found_things[1 .. $#$found_things] ),
1077 my $file = $found_things->[0];
1079 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
1080 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
1082 # Set formatter options:
1083 if( ref $formatter ) {
1084 foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
1085 my($switch, $value, $silent_fail) = @$f;
1086 if( $formatter->can($switch) ) {
1087 eval { $formatter->$switch( defined($value) ? $value : () ) };
1088 warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
1091 if( $silent_fail or $switch =~ m/^__/s ) {
1092 DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
1094 warn "$formatter_class doesn't recognize the $switch switch.\n";
1100 $self->{'output_is_binary'} =
1101 $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
1103 my ($out_fh, $out) = $self->new_output_file(
1104 ( $formatter->can('output_extension') && $formatter->output_extension )
1106 $self->useful_filename_bit,
1109 # Now, finally, do the formatting!
1112 if(DEBUG() or $self->opt_D) {
1113 # feh, let 'em see it
1116 # The average user just has no reason to be seeing
1117 # $^W-suppressable warnings from the formatting!
1120 eval { $formatter->parse_from_file( $file, $out_fh ) };
1123 warn "Error while formatting with $formatter_class:\n $@\n" if $@;
1124 DEBUG > 2 and print "Back from formatting with $formatter_class\n";
1127 or warn "Can't close $out: $!\n(Did $formatter already close it?)";
1128 sleep 0; sleep 0; sleep 0;
1129 # Give the system a few timeslices to meditate on the fact
1130 # that the output file does in fact exist and is closed.
1132 $self->unlink_if_temp_file($file);
1135 if( $formatter->can( 'if_zero_length' ) ) {
1136 # Basically this is just a hook for Pod::Simple::Checker; since
1137 # what other class could /happily/ format an input file with Pod
1138 # as a 0-length output file?
1139 $formatter->if_zero_length( $file, $out, $out_fh );
1141 warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
1145 DEBUG and print "Finished writing to $out.\n";
1146 return($out, $formatter) if wantarray;
1150 #..........................................................................
1152 sub unlink_if_temp_file {
1153 # Unlink the specified file IFF it's in the list of temp files.
1154 # Really only used in the case of -f / -q things when we can
1155 # throw away the dynamically generated source pod file once
1156 # we've formatted it.
1158 my($self, $file) = @_;
1159 return unless defined $file and length $file;
1161 my $temp_file_list = $self->{'temp_file_list'} || return;
1162 if(grep $_ eq $file, @$temp_file_list) {
1163 $self->aside("Unlinking $file\n");
1164 unlink($file) or warn "Odd, couldn't unlink $file: $!";
1166 DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1171 #..........................................................................
1173 sub MSWin_temp_cleanup {
1175 # Nothing particularly MSWin-specific in here, but I don't know if any
1176 # other OS needs its temp dir policed like MSWin does!
1180 my $tempdir = $ENV{'TEMP'};
1181 return unless defined $tempdir and length $tempdir
1182 and -e $tempdir and -d _ and -w _;
1185 "Considering whether any old files of mine in $tempdir need unlinking.\n"
1188 opendir(TMPDIR, $tempdir) || return;
1191 my $limit = time() - $Temp_File_Lifetime;
1193 DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
1198 while(defined($filespec = readdir(TMPDIR))) {
1200 $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
1202 if( hex($1) < $limit ) {
1203 push @to_unlink, "$tempdir/$filespec";
1204 $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
1207 printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
1211 print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
1215 $self->aside(sprintf "Unlinked %s items of mine in %s\n",
1216 scalar(unlink(@to_unlink)),
1222 # . . . . . . . . . . . . . . . . . . . . . . . . .
1224 sub MSWin_perldoc_tempfile {
1225 my($self, $suffix, $infix) = @_;
1227 my $tempdir = $ENV{'TEMP'};
1228 return unless defined $tempdir and length $tempdir
1229 and -e $tempdir and -d _ and -w _;
1234 $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
1235 # Yes, we embed the create-time in the filename!
1240 defined( &Win32::GetTickCount )
1241 ? (Win32::GetTickCount() & 0xff)
1243 # Under MSWin, $$ values get reused quickly! So if we ran
1244 # perldoc foo and then perldoc bar before there was time for
1245 # time() to increment time."_$$" would likely be the same
1246 # for each process! So we tack on the tick count's lower
1247 # bits (or, in a pinch, rand)
1251 } while( -e $spec );
1255 while($counter < 50) {
1257 # If we are running before perl5.6.0, we can't autovivify
1260 $fh = Symbol::gensym();
1262 DEBUG > 3 and print "About to try making temp file $spec\n";
1263 return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
1264 $self->aside("Can't create temp file $spec: $!\n");
1267 $self->aside("Giving up on making a temp file!\n");
1268 die "Can't make a tempfile!?";
1271 #..........................................................................
1274 sub after_rendering {
1276 $self->after_rendering_VMS if IS_VMS;
1277 $self->after_rendering_MSWin32 if IS_MSWin32;
1278 $self->after_rendering_Dos if IS_Dos;
1279 $self->after_rendering_OS2 if IS_OS2;
1283 sub after_rendering_VMS { return }
1284 sub after_rendering_Dos { return }
1285 sub after_rendering_OS2 { return }
1287 sub after_rendering_MSWin32 {
1288 shift->MSWin_temp_cleanup() if $Temp_Files_Created;
1291 #..........................................................................
1293 #..........................................................................
1296 sub minus_f_nocase { # i.e., do like -f, but without regard to case
1298 my($self, $dir, $file) = @_;
1299 my $path = catfile($dir,$file);
1300 return $path if -f $path and -r _;
1303 or IS_VMS or IS_MSWin32
1306 # On a case-forgiving file system, or if case is important,
1307 # that is it, all we can do.
1308 warn "Ignored $path: unreadable\n" if -f _;
1315 foreach $p (splitdir $file){
1316 my $try = catfile @p, $p;
1317 $self->aside("Scrutinizing $try...\n");
1321 if ( $p eq $self->{'target'} ) {
1322 my $tmp_path = catfile @p;
1324 for (@{ $self->{'found'} }) {
1325 $path_f = 1 if $_ eq $tmp_path;
1327 push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1328 $self->aside( "Found as $tmp_path but directory\n" );
1331 elsif (-f _ && -r _) {
1335 warn "Ignored $try: unreadable\n";
1337 elsif (-d catdir(@p)) { # at least we see the containing directory!
1340 my $p_dirspec = catdir(@p);
1341 opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
1342 while(defined( $cip = readdir(DIR) )) {
1343 if (lc $cip eq $lcp){
1345 last; # XXX stop at the first? what if there's others?
1348 closedir DIR or die "closedir $p_dirspec: $!";
1349 return "" unless $found;
1352 my $p_filespec = catfile(@p);
1353 return $p_filespec if -f $p_filespec and -r _;
1354 warn "Ignored $p_filespec: unreadable\n" if -f _;
1360 #..........................................................................
1362 sub pagers_guessing {
1366 push @pagers, $self->pagers;
1367 $self->{'pagers'} = \@pagers;
1370 push @pagers, qw( more< less notepad );
1371 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1374 push @pagers, qw( most more less type/page );
1377 push @pagers, qw( less.exe more.com< );
1378 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1382 unshift @pagers, 'less', 'cmd /c more <';
1384 push @pagers, qw( more less pg view cat );
1385 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1389 if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
1390 unshift @pagers, '/usr/bin/less -isrR';
1394 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
1399 #..........................................................................
1401 sub page_module_file {
1402 my($self, @found) = @_;
1405 # Don't ever just pass this off to anything like MSWin's "start.exe",
1406 # since we might be calling on a .pl file, and we wouldn't want that
1407 # to actually /execute/ the file that we just want to page thru!
1408 # Also a consideration if one were to use a web browser as a pager;
1409 # doing so could trigger the browser's MIME mapping for whatever
1410 # it thinks .pm/.pl/whatever is. Probably just a (useless and
1411 # annoying) "Save as..." dialog, but potentially executing the file
1412 # in question -- particularly in the case of MSIE and it's, ahem,
1413 # occasionally hazy distinction between OS-local extension
1414 # associations, and browser-specific MIME mappings.
1416 if ($self->{'output_to_stdout'}) {
1417 $self->aside("Sending unpaged output to STDOUT.\n");
1420 foreach my $output (@found) {
1421 unless( open(TMP, "<", $output) ) { # XXX 5.6ism
1422 warn("Can't open $output: $!");
1427 print or die "Can't print to stdout: $!";
1429 close TMP or die "Can't close while $output: $!";
1430 $self->unlink_if_temp_file($output);
1432 return $any_error; # successful
1435 foreach my $pager ( $self->pagers ) {
1436 $self->aside("About to try calling $pager @found\n");
1437 if (system($pager, @found) == 0) {
1438 $self->aside("Yay, it worked.\n");
1441 $self->aside("That didn't work.\n");
1443 # Odd -- when it fails, under Win32, this seems to neither
1444 # return with a fail nor return with a success!!
1445 # That's discouraging!
1449 sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
1451 join(' ', $self->pagers),
1455 DEBUG > 1 and print "Bailing out in a VMSish way.\n";
1457 use vmsish qw(status exit);
1464 # i.e., an UNSUCCESSFUL return value!
1467 #..........................................................................
1470 my($self, $dir, $file) = @_;
1472 unless( ref $self ) {
1473 # Should never get called:
1476 Carp::croak( join '',
1477 "Crazy ", __PACKAGE__, " error:\n",
1478 "check_file must be an object_method!\n",
1483 if(length $dir and not -d $dir) {
1484 DEBUG > 3 and print " No dir $dir -- skipping.\n";
1489 return $self->minus_f_nocase($dir,$file);
1493 my $path = $self->minus_f_nocase($dir,$file);
1494 if( length $path and $self->containspod($path) ) {
1496 " The file $path indeed looks promising!\n";
1500 DEBUG > 3 and print " No good: $file in $dir\n";
1505 #..........................................................................
1508 my($self, $file, $readit) = @_;
1509 return 1 if !$readit && $file =~ /\.pod\z/i;
1512 # Under cygwin the /usr/bin/perl is legal executable, but
1513 # you cannot open a file with that name. It must be spelled
1514 # out as "/usr/bin/perl.exe".
1516 # The following if-case under cygwin prevents error
1519 # Cannot open /usr/bin/perl: no such file or directory
1521 # This would work though
1523 # $ perldoc perl.pod
1525 if ( IS_Cygwin and -x $file and -f "$file.exe" )
1527 warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_D;
1532 open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
1535 close(TEST) or die "Can't close $file: $!";
1539 close(TEST) or die "Can't close $file: $!";
1543 #..........................................................................
1545 sub maybe_diddle_INC {
1548 # Does this look like a module or extension directory?
1550 if (-f "Makefile.PL" || -f "Build.PL") {
1552 # Add "." and "lib" to @INC (if they exist)
1553 eval q{ use lib qw(. lib); 1; } or die;
1555 # don't add if superuser
1556 if ($< && $> && -d "blib") { # don't be looking too hard now!
1557 eval q{ use blib; 1 };
1558 warn $@ if $@ && $self->opt_D;
1565 #..........................................................................
1567 sub new_output_file {
1569 my $outspec = $self->opt_d; # Yes, -d overrides all else!
1570 # So don't call this twice per format-job!
1572 return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1574 # Otherwise open a write-handle on opt_d!f
1577 # If we are running before perl5.6.0, we can't autovivify
1580 $fh = Symbol::gensym();
1582 DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1583 die "Can't write-open $outspec: $!"
1584 unless open($fh, ">", $outspec); # XXX 5.6ism
1586 DEBUG > 3 and print "Successfully opened $outspec\n";
1587 binmode($fh) if $self->{'output_is_binary'};
1588 return($fh, $outspec);
1591 #..........................................................................
1593 sub useful_filename_bit {
1594 # This tries to provide a meaningful bit of text to do with the query,
1595 # such as can be used in naming the file -- since if we're going to be
1596 # opening windows on temp files (as a "pager" may well do!) then it's
1597 # better if the temp file's name (which may well be used as the window
1598 # title) isn't ALL just random garbage!
1599 # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1600 # name than "perldoc_2371981429". So this routine is what tries to
1601 # provide the "LWPSimple" bit.
1604 my $pages = $self->{'pages'} || return undef;
1605 return undef unless @$pages;
1607 my $chunk = $pages->[0];
1608 return undef unless defined $chunk;
1610 $chunk =~ s/\.\w+$//g; # strip any extension
1611 if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1616 $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1617 $chunk = substr($chunk, -10) if length($chunk) > 10;
1621 #..........................................................................
1623 sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
1626 ++$Temp_Files_Created;
1629 my @out = $self->MSWin_perldoc_tempfile(@_);
1630 return @out if @out;
1631 # otherwise fall thru to the normal stuff below...
1635 return File::Temp::tempfile(UNLINK => 1);
1638 #..........................................................................
1640 sub page { # apply a pager to the output file
1641 my ($self, $output, $output_to_stdout, @pagers) = @_;
1642 if ($output_to_stdout) {
1643 $self->aside("Sending unpaged output to STDOUT.\n");
1644 open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
1647 print or die "Can't print to stdout: $!";
1649 close TMP or die "Can't close while $output: $!";
1650 $self->unlink_if_temp_file($output);
1652 # On VMS, quoting prevents logical expansion, and temp files with no
1653 # extension get the wrong default extension (such as .LIS for TYPE)
1655 $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
1657 $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
1658 # Altho "/" under MSWin is in theory good as a pathsep,
1659 # many many corners of the OS don't like it. So we
1660 # have to force it to be "\" to make everyone happy.
1662 foreach my $pager (@pagers) {
1663 $self->aside("About to try calling $pager $output\n");
1665 last if system("$pager $output") == 0;
1667 last if system("$pager \"$output\"") == 0;
1674 #..........................................................................
1677 my($self, $recurse,$s,@dirs) = @_;
1679 $s = VMS::Filespec::unixify($s) if IS_VMS;
1680 return $s if -f $s && $self->containspod($s);
1681 $self->aside( "Looking for $s in @dirs\n" );
1685 $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
1686 for ($i=0; $i<@dirs; $i++) {
1688 next unless -d $dir;
1689 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
1690 if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1691 or ( $ret = $self->check_file($dir,"$s.pm"))
1692 or ( $ret = $self->check_file($dir,$s))
1694 $ret = $self->check_file($dir,"$s.com"))
1696 $ret = $self->check_file($dir,"$s.cmd"))
1697 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
1698 $ret = $self->check_file($dir,"$s.bat"))
1699 or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1700 or ( $ret = $self->check_file("$dir/pod",$s))
1701 or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1702 or ( $ret = $self->check_file("$dir/pods",$s))
1704 DEBUG > 1 and print " Found $ret\n";
1709 opendir(D,$dir) or die "Can't opendir $dir: $!";
1710 my @newdirs = map catfile($dir, $_), grep {
1712 not /^auto\z/s and # save time! don't search auto dirs
1713 -d catfile($dir, $_)
1715 closedir(D) or die "Can't closedir $dir: $!";
1716 next unless @newdirs;
1717 # what a wicked map!
1718 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
1719 $self->aside( "Also looking in @newdirs\n" );
1720 push(@dirs,@newdirs);
1726 #..........................................................................
1728 my $already_asserted;
1729 sub assert_closing_stdout {
1732 return if $already_asserted;
1734 eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
1735 # What for? to let the pager know that nothing more will come?
1738 $already_asserted = 1;
1743 #..........................................................................
1745 sub tweak_found_pathnames {
1746 my($self, $found) = @_;
1748 foreach (@$found) { s,/,\\,g }
1753 #..........................................................................
1755 #..........................................................................
1757 sub am_taint_checking {
1759 die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
1760 my($k,$v) = each %ENV;
1761 return is_tainted($v);
1764 #..........................................................................
1766 sub is_tainted { # just a function
1768 my $nada = substr($arg, 0, 0); # zero-length!
1769 local $@; # preserve the caller's version of $@
1770 eval { eval "# $nada" };
1771 return length($@) != 0;
1774 #..........................................................................
1776 sub drop_privs_maybe {
1779 # Attempt to drop privs if we should be tainting and aren't
1780 if (!(IS_VMS || IS_MSWin32 || IS_Dos
1783 && ($> == 0 || $< == 0)
1784 && !$self->am_taint_checking()
1786 my $id = eval { getpwnam("nobody") };
1787 $id = eval { getpwnam("nouser") } unless defined $id;
1788 $id = -2 unless defined $id;
1790 # According to Stevens' APUE and various
1791 # (BSD, Solaris, HP-UX) man pages, setting
1792 # the real uid first and effective uid second
1793 # is the way to go if one wants to drop privileges,
1794 # because if one changes into an effective uid of
1795 # non-zero, one cannot change the real uid any more.
1797 # Actually, it gets even messier. There is
1798 # a third uid, called the saved uid, and as
1799 # long as that is zero, one can get back to
1800 # uid of zero. Setting the real-effective *twice*
1801 # helps in *most* systems (FreeBSD and Solaris)
1802 # but apparently in HP-UX even this doesn't help:
1803 # the saved uid stays zero (apparently the only way
1804 # in HP-UX to change saved uid is to call setuid()
1805 # when the effective uid is zero).
1808 $< = $id; # real uid
1809 $> = $id; # effective uid
1810 $< = $id; # real uid
1811 $> = $id; # effective uid
1813 if( !$@ && $< && $> ) {
1814 DEBUG and print "OK, I dropped privileges.\n";
1815 } elsif( $self->opt_U ) {
1816 DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
1818 DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
1819 # We used to die here; but that seemed pointless.
1825 #..........................................................................
1833 Pod::Perldoc - Look up Perl documentation in Pod format.
1837 use Pod::Perldoc ();
1839 Pod::Perldoc->run();
1843 The guts of L<perldoc> utility.
1849 =head1 COPYRIGHT AND DISCLAIMERS
1851 Copyright (c) 2002-2007 Sean M. Burke.
1853 This library is free software; you can redistribute it and/or modify it
1854 under the same terms as Perl itself.
1856 This program is distributed in the hope that it will be useful, but
1857 without any warranty; without even the implied warranty of
1858 merchantability or fitness for a particular purpose.
1862 Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
1864 Past contributions from:
1865 Sean M. Burke <sburke@cpan.org>
1871 # Perldoc -- look up a piece of documentation in .pod format that
1872 # is embedded in the perl installation tree.
1876 # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
1878 # Version 3.01: Sun Nov 10 21:38:09 MST 2002
1879 # Sean M. Burke <sburke@cpan.org>
1880 # Massive refactoring and code-tidying.
1881 # Now it's a module(-family)!
1882 # Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
1883 # Added -T, -d, -o, -M, -w.
1884 # Added some improved MSWin funk.
1888 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
1889 # Hugo van der Sanden <hv@crypt.org>
1890 # Made -U the default, based on patch from Simon Cozens
1891 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
1892 # Randy W. Sims <RandyS@ThePierianSpring.org>
1893 # allow -n to enable nroff under Win32
1894 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
1895 # Hugo van der Sanden <hv@crypt.org>
1896 # don't die when 'use blib' fails
1897 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
1898 # Tom Christiansen <tchrist@perl.com>
1899 # Added -U insecurity option
1900 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
1901 # Tom Christiansen <tchrist@perl.com>, querulously.
1902 # Security and correctness patches.
1903 # What a twisted bit of distasteful spaghetti code.
1908 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
1909 # Charles Wilson <cwilson@ece.gatech.edu>
1910 # changed /pod/ directory to /pods/ for cygwin
1911 # to support cygwin/win32
1912 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
1913 # Robin Barker <rmb1@cise.npl.co.uk>
1914 # -strict, -w cleanups
1915 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
1916 # Gurusamy Sarathy <gsar@activestate.com>
1917 # -doc tweaks for -F and -X options
1918 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
1919 # Gurusamy Sarathy <gsar@activestate.com>
1920 # -various fixes for win32
1921 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
1922 # Kenneth Albanowski <kjahds@kjahds.com>
1923 # -added Charles Bailey's further VMS patches, and -u switch
1924 # -added -t switch, with pod2text support
1926 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
1927 # Kenneth Albanowski <kjahds@kjahds.com>
1928 # -added VMS support
1929 # -added better error recognition (on no found pages, just exit. On
1930 # missing nroff/pod2man, just display raw pod.)
1931 # -added recursive/case-insensitive matching (thanks, Andreas). This
1932 # slows things down a bit, unfortunately. Give a precise name, and
1935 # Version 1.01: Tue May 30 14:47:34 EDT 1995
1936 # Andy Dougherty <doughera@lafcol.lafayette.edu>
1937 # -added pod documentation.
1938 # -added PATH searching.
1939 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
1946 # Cache the directories read during sloppy match
1947 # (To disk, or just in-memory?)
1949 # Backport this to perl 5.005?
1951 # Implement at least part of the "perlman" interface described
1952 # in Programming Perl 3e?