8 use Fcntl; # for sysopen
9 use File::Spec::Functions qw(catfile catdir splitdir);
11 use vars qw($VERSION @Pagers $Bindir $Pod2man
12 $Temp_Files_Created $Temp_File_Lifetime
15 #..........................................................................
17 BEGIN { # Make a DEBUG constant very first thing...
18 unless(defined &DEBUG) {
19 if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
20 eval("sub DEBUG () {$1}");
21 die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
28 use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
30 #..........................................................................
31 { my $pager = $Config{'pager'};
32 push @Pagers, $pager if ((-x (split /\s+/, $pager)[0]) || $^O eq 'VMS');
34 $Bindir = $Config{'scriptdirexp'};
35 $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
37 #..........................................................................
43 *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
44 *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
45 *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
46 *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
47 *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
50 $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
51 # If it's older than five days, it's quite unlikely
52 # that anyone's still looking at it!!
53 # (Currently used only by the MSWin cleanup routine)
55 # End of class-init stuff
57 ###########################################################################
61 foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTd}) {
63 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
66 # And these are so that GetOptsOO knows they take options:
67 sub opt_f_with { shift->_elem('opt_f', @_) }
68 sub opt_q_with { shift->_elem('opt_q', @_) }
69 sub opt_d_with { shift->_elem('opt_d', @_) }
71 sub opt_w_with { # Specify an option for the formatter subclass
72 my($self, $value) = @_;
73 if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
75 my $option_value = defined($2) ? $2 : "TRUE";
76 $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
77 $self->add_formatter_option( $option, $option_value );
79 warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
84 sub opt_M_with { # specify formatter class name(s)
85 my($self, $classes) = @_;
86 return unless defined $classes and length $classes;
87 DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
89 foreach my $classname (split m/[,;]+/s, $classes) {
90 next unless $classname =~ m/\S/;
91 if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
92 # A mildly restrictive concept of what modulenames are valid.
93 push @classes_to_add, $1; # untaint
95 warn "\"$classname\" isn't a valid classname. Ignoring.\n";
99 unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
102 "Adding @classes_to_add to the list of formatter classes, "
103 . "making them @{ $self->{'formatter_classes'} }.\n"
109 sub opt_V { # report version and exit
111 "Perldoc v$VERSION, under perl v$] for $^O",
113 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
114 ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
116 (chr(65) eq 'A') ? () : " (non-ASCII)",
123 sub opt_U {} # legacy no-op
125 sub opt_t { # choose plaintext as output format
127 $self->opt_o_with('text') if @_ and $_[0];
128 return $self->_elem('opt_t', @_);
131 sub opt_u { # choose raw pod as output format
133 $self->opt_o_with('pod') if @_ and $_[0];
134 return $self->_elem('opt_u', @_);
138 # choose man as the output format, and specify the proggy to run
140 $self->opt_o_with('man') if @_ and $_[0];
141 $self->_elem('opt_n', @_);
144 sub opt_o_with { # "o" for output format
145 my($self, $rest) = @_;
146 return unless defined $rest and length $rest;
147 if($rest =~ m/^(\w+)$/s) {
150 warn "\"$rest\" isn't a valid output format. Skipping.\n";
154 $self->aside("Noting \"$rest\" as desired output format...\n");
156 # Figure out what class(es) that could actually mean...
159 foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
162 $rest, # Yes, try it first with the given capitalization
163 "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
166 push @classes, $prefix . $stem;
167 #print "Considering $prefix$stem\n";
170 # Tidier, but misses too much:
171 #push @classes, $prefix . ucfirst(lc($rest));
173 $self->opt_M_with( join ";", @classes );
177 ###########################################################################
178 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
180 sub run { # to be called by the "perldoc" executable
183 print "Parameters to $class\->run:\n";
186 $x[1] = '<undef>' unless defined $x[1];
187 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
188 print " [$x[0]] => [$x[1]]\n";
193 return $class -> new(@_) -> process() || 0;
196 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
197 ###########################################################################
199 sub new { # yeah, nothing fancy
201 my $new = bless {@_}, (ref($class) || $class);
202 DEBUG > 1 and print "New $class object $new\n";
207 #..........................................................................
209 sub aside { # If we're in -v or DEBUG mode, say this.
211 if( DEBUG or $self->opt_v ) {
214 my $callsub = (caller(1))[3];
215 my $package = quotemeta(__PACKAGE__ . '::');
216 $callsub =~ s/^$package/'/os;
221 if(DEBUG) { print $out } else { print STDERR $out }
226 #..........................................................................
232 # Erase evidence of previous errors (if any), so exit status is simple.
236 perldoc [options] PageName|ModuleName|ProgramName...
237 perldoc [options] -f BuiltinFunction
238 perldoc [options] -q FAQRegex
241 -h Display this help message
243 -r Recursive search (slow)
245 -t Display pod using pod2text instead of pod2man and nroff
246 (-t is the default on win32 unless -n is specified)
247 -u Display unformatted pod text
248 -m Display module's file in its entirety
249 -n Specify replacement for nroff
250 -l Display the module's file name
251 -F Arguments are file names, not modules
252 -v Verbosely describe what's going on
253 -T Send output to STDOUT without any pager
254 -d output_filename_to_send_to
255 -o output_format_name
256 -M FormatterModuleNameToUse
257 -w formatter_option:option_value
258 -X use index if present (looks for pod.idx at $Config{archlib})
259 -q Search the text of questions (not answers) in perlfaq[1-9]
261 PageName|ModuleName...
262 is the name of a piece of documentation that you want to look at. You
263 may either give a descriptive name of the page (as in the case of
264 `perlfunc') the name of a module, either like `Term::Info' or like
265 `Term/Info', or the name of a program, like `perldoc'.
268 is the name of a perl function. Will extract documentation from
272 is a regex. Will search perlfaq[1-9] for and extract any
273 questions that match.
275 Any switches in the PERLDOC environment variable will be used before the
276 command line arguments. The optional pod index file contains a list of
277 filenames, one per line.
283 #..........................................................................
286 my $me = $0; # Editing $0 is unportable
288 $me =~ s,.*[/\\],,; # get basename
291 Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName
295 The -h option prints more help. Also try "perldoc perldoc" to get
296 acquainted with the system. [Perldoc v$VERSION]
301 #..........................................................................
303 sub pagers { @{ shift->{'pagers'} } }
305 #..........................................................................
307 sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
308 if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
309 else { return $_[0]{ $_[1] } }
311 #..........................................................................
312 ###########################################################################
314 # Init formatter switches, and start it off with __bindir and all that
315 # other stuff that ToMan.pm needs.
321 # Make sure creat()s are neither too much nor too little
322 eval { umask(0077) }; # doubtless someone has no mask
324 $self->{'args'} ||= \@ARGV;
325 $self->{'found'} ||= [];
326 $self->{'temp_file_list'} ||= [];
329 $self->{'target'} = undef;
331 $self->init_formatter_class_list;
333 $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
334 $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
335 $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
337 push @{ $self->{'formatter_switches'} = [] }, (
338 # Yeah, we could use a hashref, but maybe there's some class where options
339 # have to be ordered; so we'll use an arrayref.
341 [ '__bindir' => $self->{'bindir' } ],
342 [ '__pod2man' => $self->{'pod2man'} ],
345 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
346 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
351 #..........................................................................
353 sub init_formatter_class_list {
355 $self->{'formatter_classes'} ||= [];
357 # Remember, no switches have been read yet, when
358 # we've started this routine.
360 $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
361 $self->opt_o_with('text');
362 $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos || IS_Cygwin
363 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i);
368 #..........................................................................
371 # if this ever returns, its retval will be used for exit(RETVAL)
374 DEBUG > 1 and print " Beginning process.\n";
375 DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
377 print "Object contents:\n";
380 $x[1] = '<undef>' unless defined $x[1];
381 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
382 print " [$x[0]] => [$x[1]]\n";
388 # TODO: make it deal with being invoked as various different things
391 return $self->usage_brief unless @{ $self->{'args'} };
392 $self->pagers_guessing;
393 $self->options_reading;
394 $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
395 $self->drop_privs_maybe;
396 $self->options_processing;
398 # Hm, we have @pages and @found, but we only really act on one
399 # file per call, with the exception of the opt_q hack, and with
405 $self->{'pages'} = \@pages;
406 if( $self->opt_f) { @pages = ("perlfunc") }
407 elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
408 else { @pages = @{$self->{'args'}};
410 # if @pages == 1 and $pages[0] eq 'perldoc';
413 return $self->usage_brief unless @pages;
415 $self->find_good_formatter_class();
416 $self->formatter_sanity_check();
418 $self->maybe_diddle_INC();
419 # for when we're apparently in a module or extension directory
421 my @found = $self->grand_search_init(\@pages);
422 exit (IS_VMS ? 98962 : 1) unless @found;
425 DEBUG and print "We're in -l mode, so byebye after this:\n";
426 print join("\n", @found), "\n";
430 $self->tweak_found_pathnames(\@found);
431 $self->assert_closing_stdout;
432 return $self->page_module_file(@found) if $self->opt_m;
433 DEBUG > 2 and print "Found: [@found]\n";
435 return $self->render_and_page(\@found);
438 #..........................................................................
441 my( %class_seen, %class_loaded );
442 sub find_good_formatter_class {
444 my @class_list = @{ $self->{'formatter_classes'} || [] };
445 die "WHAT? Nothing in the formatter class list!?" unless @class_list;
447 my $good_class_found;
448 foreach my $c (@class_list) {
449 DEBUG > 4 and print "Trying to load $c...\n";
450 if($class_loaded{$c}) {
451 DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
452 $good_class_found = $c;
456 if($class_seen{$c}) {
458 "I've tried $c before, and it's no good. Skipping.\n";
464 if( $c->can('parse_from_file') ) {
466 "Interesting, the formatter class $c is already loaded!\n";
469 (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
470 # the alway case-insensitive fs's
471 and $class_seen{lc("~$c")}++
474 "We already used something quite like \"\L$c\E\", so no point using $c\n";
475 # This avoids redefining the package.
477 DEBUG > 4 and print "Trying to eval 'require $c'...\n";
480 if(DEBUG() or $self->opt_v) {
481 # feh, let 'em see it
484 # The average user just has no reason to be seeing
485 # $^W-suppressable warnings from the require!
490 DEBUG > 4 and print "Couldn't load $c: $!\n";
495 if( $c->can('parse_from_file') ) {
496 DEBUG > 4 and print "Settling on $c\n";
498 $v = ( defined $v and length $v ) ? " version $v" : '';
499 $self->aside("Formatter class $c$v successfully loaded!\n");
500 $good_class_found = $c;
503 DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
507 die "Can't find any loadable formatter class in @class_list?!\nAborting"
508 unless $good_class_found;
510 $self->{'formatter_class'} = $good_class_found;
511 $self->aside("Will format with the class $good_class_found\n");
517 #..........................................................................
519 sub formatter_sanity_check {
521 my $formatter_class = $self->{'formatter_class'}
522 || die "NO FORMATTER CLASS YET!?";
524 if(!$self->opt_T # so -T can FORCE sending to STDOUT
525 and $formatter_class->can('is_pageable')
526 and !$formatter_class->is_pageable
527 and !$formatter_class->can('page_for_perldoc')
530 ($formatter_class->can('output_extension')
531 && $formatter_class->output_extension
533 $ext = ".$ext" if length $ext;
536 "When using Perldoc to format with $formatter_class, you have to\n"
537 . "specify -T or -dsomefile$ext\n"
538 . "See `perldoc perldoc' for more information on those switches.\n"
543 #..........................................................................
545 sub render_and_page {
546 my($self, $found_list) = @_;
548 $self->maybe_generate_dynamic_pod($found_list);
550 my($out, $formatter) = $self->render_findings($found_list);
553 printf "Perldoc (%s) output saved to %s\n",
554 $self->{'formatter_class'} || ref($self),
556 print "But notice that it's 0 bytes long!\n" unless -s $out;
559 } elsif( # Allow the formatter to "page" itself, if it wants.
560 $formatter->can('page_for_perldoc')
562 $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
563 if( $formatter->page_for_perldoc($out, $self) ) {
564 $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
567 $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
572 # Do nothing, since the formatter has "paged" it for itself.
575 # Page it normally (internally)
577 if( -s $out ) { # Usual case:
578 $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
582 $self->aside("Skipping $out (from $$found_list[0] "
583 . "via $$self{'formatter_class'}) as it is 0-length.\n");
585 push @{ $self->{'temp_file_list'} }, $out;
586 $self->unlink_if_temp_file($out);
590 $self->after_rendering(); # any extra cleanup or whatever
595 #..........................................................................
597 sub options_reading {
600 if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
601 require Text::ParseWords;
602 $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
603 # Yes, appends to the beginning
604 unshift @{ $self->{'args'} },
605 Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
607 DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
609 DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
613 and print " Args right before switch processing: @{$self->{'args'}}\n";
615 Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
616 or return $self->usage;
619 and print " Args after switch processing: @{$self->{'args'}}\n";
621 return $self->usage if $self->opt_h;
626 #..........................................................................
628 sub options_processing {
632 my $podidx = "$Config{'archlib'}/pod.idx";
633 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
634 $self->{'podidx'} = $podidx;
637 $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
639 $self->options_sanity;
641 $self->opt_n("nroff") unless $self->opt_n;
642 $self->add_formatter_option( '__nroffer' => $self->opt_n );
647 #..........................................................................
652 # The opts-counting stuff interacts quite badly with
653 # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
654 # set to -t, and I specify -u on the command line, I don't want
655 # to be hectored at that -u and -t don't make sense together.
657 #my $opts = grep $_ && 1, # yes, the count of the set ones
658 # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
661 #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
664 # Any sanity-checking need doing here?
669 #..........................................................................
671 sub grand_search_init {
672 my($self, $pages, @found) = @_;
675 if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
676 my $searchfor = catfile split '::', $_;
677 $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
681 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
683 close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
687 $self->aside( "Searching for $_\n" );
691 push @found, $_ if $self->opt_m or $self->containspod($_);
695 # We must look both in @INC for library modules and in $bindir
696 # for executables, like h2xs or perldoc itself.
698 my @searchdirs = ($self->{'bindir'}, @INC);
699 unless ($self->opt_m) {
702 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
703 push(@searchdirs,$trn);
705 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
708 push(@searchdirs, grep(-d, split($Config{path_sep},
712 my @files = $self->searchfor(0,$_,@searchdirs);
714 $self->aside( "Found as @files\n" );
717 # no match, try recursive search
718 @searchdirs = grep(!/^\.\z/s,@INC);
719 @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
721 $self->aside( "Loosely found as @files\n" );
725 ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
726 if ( @{ $self->{'found'} } ) {
727 print STDERR "However, try\n";
728 for my $dir (@{ $self->{'found'} }) {
729 opendir(DIR, $dir) or die "opendir $dir: $!";
730 while (my $file = readdir(DIR)) {
731 next if ($file =~ /^\./s);
732 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
733 print STDERR "\tperldoc $_\::$file\n";
735 closedir DIR or die "closedir $dir: $!";
745 #..........................................................................
747 sub maybe_generate_dynamic_pod {
748 my($self, $found_things) = @_;
751 $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
753 $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
755 if( ! $self->opt_f and ! $self->opt_q ) {
756 DEBUG > 4 and print "That's a non-dynamic pod search.\n";
757 } elsif ( @dynamic_pod ) {
758 $self->aside("Hm, I found some Pod from that search!\n");
759 my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
761 push @{ $self->{'temp_file_list'} }, $buffer;
762 # I.e., it MIGHT be deleted at the end.
764 print $buffd "=over 8\n\n";
765 print $buffd @dynamic_pod or die "Can't print $buffer: $!";
766 print $buffd "=back\n";
767 close $buffd or die "Can't close $buffer: $!";
769 @$found_things = $buffer;
770 # Yes, so found_things never has more than one thing in
771 # it, by time we leave here
773 $self->add_formatter_option('__filter_nroff' => 1);
777 $self->aside("I found no Pod from that search!\n");
783 #..........................................................................
785 sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
787 push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
789 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
790 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
795 #..........................................................................
797 sub search_perlfunc {
798 my($self, $found_things, $pod) = @_;
800 DEBUG > 2 and print "Search: @$found_things\n";
802 my $perlfunc = shift @$found_things;
803 open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
804 or die("Can't open $perlfunc: $!");
806 # Functions like -r, -e, etc. are listed under `-X'.
807 my $search_string = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
808 ? 'I<-X' : $self->opt_f ;
811 print "Going to perlfunc-scan for $search_string in $perlfunc\n";
817 last if /^=head2 Alphabetical Listing of Perl Functions/;
820 # Look for our function
823 while (<PFUNC>) { # "The Mothership Connection is here!"
824 if (/^=item\s+\Q$search_string\E\b/o) {
828 last if $found > 1 and not $inlist;
838 ++$found if /^\w/; # found descriptive text
842 "No documentation for perl function `%s' found\n",
846 close PFUNC or die "Can't open $perlfunc: $!";
851 #..........................................................................
853 sub search_perlfaqs {
854 my( $self, $found_things, $pod) = @_;
858 my $search_key = $self->opt_q;
859 my $rx = eval { qr/$search_key/ } or die <<EOD;
860 Invalid regular expression '$search_key' given as -q pattern:
862 Did you mean \\Q$search_key ?
867 foreach my $file (@$found_things) {
868 die "invalid file spec: $!" if $file =~ /[<>|]/;
869 open(INFAQ, "<", $file) or die "Can't read-open $file: $!\nAborting";
871 if (/^=head2\s+.*(?:$search_key)/oi) { # it's good for only one key
873 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
875 elsif (/^=head[12]/) {
883 die("No documentation for perl FAQ keyword `$search_key' found\n")
890 #..........................................................................
892 sub render_findings {
893 # Return the filename to open
895 my($self, $found_things) = @_;
897 my $formatter_class = $self->{'formatter_class'}
898 || die "No formatter class set!?";
899 my $formatter = $formatter_class->can('new')
900 ? $formatter_class->new
904 if(! @$found_things) {
905 die "Nothing found?!";
906 # should have been caught before here
907 } elsif(@$found_things > 1) {
909 "Perldoc is only really meant for reading one document at a time.\n",
910 "So these parameters are being ignored: ",
911 join(' ', @$found_things[1 .. $#$found_things] ),
915 my $file = $found_things->[0];
917 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
918 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
920 # Set formatter options:
921 if( ref $formatter ) {
922 foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
923 my($switch, $value, $silent_fail) = @$f;
924 if( $formatter->can($switch) ) {
925 eval { $formatter->$switch( defined($value) ? $value : () ) };
926 warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
929 if( $silent_fail or $switch =~ m/^__/s ) {
930 DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
932 warn "$formatter_class doesn't recognize the $switch switch.\n";
938 $self->{'output_is_binary'} =
939 $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
941 my ($out_fh, $out) = $self->new_output_file(
942 ( $formatter->can('output_extension') && $formatter->output_extension )
944 $self->useful_filename_bit,
947 # Now, finally, do the formatting!
950 if(DEBUG() or $self->opt_v) {
951 # feh, let 'em see it
954 # The average user just has no reason to be seeing
955 # $^W-suppressable warnings from the formatting!
958 eval { $formatter->parse_from_file( $file, $out_fh ) };
961 warn "Error while formatting with $formatter_class:\n $@\n" if $@;
962 DEBUG > 2 and print "Back from formatting with $formatter_class\n";
965 or warn "Can't close $out: $!\n(Did $formatter already close it?)";
966 sleep 0; sleep 0; sleep 0;
967 # Give the system a few timeslices to meditate on the fact
968 # that the output file does in fact exist and is closed.
970 $self->unlink_if_temp_file($file);
973 if( $formatter->can( 'if_zero_length' ) ) {
974 # Basically this is just a hook for Pod::Simple::Checker; since
975 # what other class could /happily/ format an input file with Pod
976 # as a 0-length output file?
977 $formatter->if_zero_length( $file, $out, $out_fh );
979 warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
983 DEBUG and print "Finished writing to $out.\n";
984 return($out, $formatter) if wantarray;
988 #..........................................................................
990 sub unlink_if_temp_file {
991 # Unlink the specified file IFF it's in the list of temp files.
992 # Really only used in the case of -f / -q things when we can
993 # throw away the dynamically generated source pod file once
994 # we've formatted it.
996 my($self, $file) = @_;
997 return unless defined $file and length $file;
999 my $temp_file_list = $self->{'temp_file_list'} || return;
1000 if(grep $_ eq $file, @$temp_file_list) {
1001 $self->aside("Unlinking $file\n");
1002 unlink($file) or warn "Odd, couldn't unlink $file: $!";
1004 DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1009 #..........................................................................
1011 sub MSWin_temp_cleanup {
1013 # Nothing particularly MSWin-specific in here, but I don't know if any
1014 # other OS needs its temp dir policed like MSWin does!
1018 my $tempdir = $ENV{'TEMP'};
1019 return unless defined $tempdir and length $tempdir
1020 and -e $tempdir and -d _ and -w _;
1023 "Considering whether any old files of mine in $tempdir need unlinking.\n"
1026 opendir(TMPDIR, $tempdir) || return;
1029 my $limit = time() - $Temp_File_Lifetime;
1031 DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
1036 while(defined($filespec = readdir(TMPDIR))) {
1038 $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
1040 if( hex($1) < $limit ) {
1041 push @to_unlink, "$tempdir/$filespec";
1042 $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
1045 printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
1049 print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
1053 $self->aside(sprintf "Unlinked %s items of mine in %s\n",
1054 scalar(unlink(@to_unlink)),
1060 # . . . . . . . . . . . . . . . . . . . . . . . . .
1062 sub MSWin_perldoc_tempfile {
1063 my($self, $suffix, $infix) = @_;
1065 my $tempdir = $ENV{'TEMP'};
1066 return unless defined $tempdir and length $tempdir
1067 and -e $tempdir and -d _ and -w _;
1072 $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
1073 # Yes, we embed the create-time in the filename!
1078 defined( &Win32::GetTickCount )
1079 ? (Win32::GetTickCount() & 0xff)
1081 # Under MSWin, $$ values get reused quickly! So if we ran
1082 # perldoc foo and then perldoc bar before there was time for
1083 # time() to increment time."_$$" would likely be the same
1084 # for each process! So we tack on the tick count's lower
1085 # bits (or, in a pinch, rand)
1089 } while( -e $spec );
1093 while($counter < 50) {
1095 # If we are running before perl5.6.0, we can't autovivify
1098 $fh = Symbol::gensym();
1100 DEBUG > 3 and print "About to try making temp file $spec\n";
1101 return($fh, $spec) if open($fh, ">", $spec);
1102 $self->aside("Can't create temp file $spec: $!\n");
1105 $self->aside("Giving up on making a temp file!\n");
1106 die "Can't make a tempfile!?";
1109 #..........................................................................
1112 sub after_rendering {
1114 $self->after_rendering_VMS if IS_VMS;
1115 $self->after_rendering_MSWin32 if IS_MSWin32;
1116 $self->after_rendering_Dos if IS_Dos;
1117 $self->after_rendering_OS2 if IS_OS2;
1121 sub after_rendering_VMS { return }
1122 sub after_rendering_Dos { return }
1123 sub after_rendering_OS2 { return }
1125 sub after_rendering_MSWin32 {
1126 shift->MSWin_temp_cleanup() if $Temp_Files_Created;
1129 #..........................................................................
1131 #..........................................................................
1134 sub minus_f_nocase { # i.e., do like -f, but without regard to case
1136 my($self, $dir, $file) = @_;
1137 my $path = catfile($dir,$file);
1138 return $path if -f $path and -r _;
1141 or IS_VMS or IS_MSWin32
1144 # On a case-forgiving file system, or if case is important,
1145 # that is it, all we can do.
1146 warn "Ignored $path: unreadable\n" if -f _;
1153 foreach $p (splitdir $file){
1154 my $try = catfile @p, $p;
1155 $self->aside("Scrutinizing $try...\n");
1159 if ( $p eq $self->{'target'} ) {
1160 my $tmp_path = catfile @p;
1162 for (@{ $self->{'found'} }) {
1163 $path_f = 1 if $_ eq $tmp_path;
1165 push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1166 $self->aside( "Found as $tmp_path but directory\n" );
1169 elsif (-f _ && -r _) {
1173 warn "Ignored $try: unreadable\n";
1175 elsif (-d catdir(@p)) { # at least we see the containing directory!
1178 my $p_dirspec = catdir(@p);
1179 opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
1180 while(defined( $cip = readdir(DIR) )) {
1181 if (lc $cip eq $lcp){
1183 last; # XXX stop at the first? what if there's others?
1186 closedir DIR or die "closedir $p_dirspec: $!";
1187 return "" unless $found;
1190 my $p_filespec = catfile(@p);
1191 return $p_filespec if -f $p_filespec and -r _;
1192 warn "Ignored $p_filespec: unreadable\n" if -f _;
1198 #..........................................................................
1200 sub pagers_guessing {
1204 push @pagers, $self->pagers;
1205 $self->{'pagers'} = \@pagers;
1208 push @pagers, qw( more< less notepad );
1209 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1212 push @pagers, qw( most more less type/page );
1215 push @pagers, qw( less.exe more.com< );
1216 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1220 unshift @pagers, 'less', 'cmd /c more <';
1222 push @pagers, qw( more less pg view cat );
1223 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1225 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
1230 #..........................................................................
1232 sub page_module_file {
1233 my($self, @found) = @_;
1236 # Don't ever just pass this off to anything like MSWin's "start.exe",
1237 # since we might be calling on a .pl file, and we wouldn't want that
1238 # to actually /execute/ the file that we just want to page thru!
1239 # Also a consideration if one were to use a web browser as a pager;
1240 # doing so could trigger the browser's MIME mapping for whatever
1241 # it thinks .pm/.pl/whatever is. Probably just a (useless and
1242 # annoying) "Save as..." dialog, but potentially executing the file
1243 # in question -- particularly in the case of MSIE and it's, ahem,
1244 # occasionally hazy distinction between OS-local extension
1245 # associations, and browser-specific MIME mappings.
1247 if ($self->{'output_to_stdout'}) {
1248 $self->aside("Sending unpaged output to STDOUT.\n");
1251 foreach my $output (@found) {
1252 unless( open(TMP, "<", $output) ) {
1253 warn("Can't open $output: $!");
1258 print or die "Can't print to stdout: $!";
1260 close TMP or die "Can't close while $output: $!";
1261 $self->unlink_if_temp_file($output);
1263 return $any_error; # successful
1266 foreach my $pager ( $self->pagers ) {
1267 $self->aside("About to try calling $pager @found\n");
1268 if (system($pager, @found) == 0) {
1269 $self->aside("Yay, it worked.\n");
1272 $self->aside("That didn't work.\n");
1274 # Odd -- when it fails, under Win32, this seems to neither
1275 # return with a fail nor return with a success!!
1276 # That's discouraging!
1280 sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
1282 join(' ', $self->pagers),
1286 DEBUG > 1 and print "Bailing out in a VMSish way.\n";
1288 use vmsish qw(status exit);
1295 # i.e., an UNSUCCESSFUL return value!
1298 #..........................................................................
1301 my($self, $dir, $file) = @_;
1303 unless( ref $self ) {
1304 # Should never get called:
1306 Carp::croak join '',
1307 "Crazy ", __PACKAGE__, " error:\n",
1308 "check_file must be an object_method!\n",
1312 if(length $dir and not -d $dir) {
1313 DEBUG > 3 and print " No dir $dir -- skipping.\n";
1318 return $self->minus_f_nocase($dir,$file);
1322 my $path = $self->minus_f_nocase($dir,$file);
1323 if( length $path and $self->containspod($path) ) {
1325 " The file $path indeed looks promising!\n";
1329 DEBUG > 3 and print " No good: $file in $dir\n";
1334 #..........................................................................
1337 my($self, $file, $readit) = @_;
1338 return 1 if !$readit && $file =~ /\.pod\z/i;
1340 open(TEST,"<", $file) or die "Can't open $file: $!";
1343 close(TEST) or die "Can't close $file: $!";
1347 close(TEST) or die "Can't close $file: $!";
1351 #..........................................................................
1353 sub maybe_diddle_INC {
1356 # Does this look like a module or extension directory?
1358 if (-f "Makefile.PL") {
1360 # Add "." and "lib" to @INC (if they exist)
1361 eval q{ use lib qw(. lib); 1; } or die;
1363 # don't add if superuser
1364 if ($< && $> && -f "blib") { # don't be looking too hard now!
1365 eval q{ use blib; 1 };
1366 warn $@ if $@ && $self->opt_v;
1373 #..........................................................................
1375 sub new_output_file {
1377 my $outspec = $self->opt_d; # Yes, -d overrides all else!
1378 # So don't call this twice per format-job!
1380 return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1382 # Otherwise open a write-handle on opt_d!f
1385 # If we are running before perl5.6.0, we can't autovivify
1388 $fh = Symbol::gensym();
1390 DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1391 die "Can't write-open $outspec: $!" unless open($fh, ">", $outspec);
1392 DEBUG > 3 and print "Successfully opened $outspec\n";
1393 binmode($fh) if $self->{'output_is_binary'};
1394 return($fh, $outspec);
1397 #..........................................................................
1399 sub useful_filename_bit {
1400 # This tries to provide a meaningful bit of text to do with the query,
1401 # such as can be used in naming the file -- since if we're going to be
1402 # opening windows on temp files (as a "pager" may well do!) then it's
1403 # better if the temp file's name (which may well be used as the window
1404 # title) isn't ALL just random garbage!
1405 # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1406 # name than "perldoc_2371981429". So this routine is what tries to
1407 # provide the "LWPSimple" bit.
1410 my $pages = $self->{'pages'} || return undef;
1411 return undef unless @$pages;
1413 my $chunk = $pages->[0];
1414 return undef unless defined $chunk;
1416 $chunk =~ s/\.\w+$//g; # strip any extension
1417 if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1422 $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1423 $chunk = substr($chunk, -10) if length($chunk) > 10;
1427 #..........................................................................
1429 sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
1432 ++$Temp_Files_Created;
1435 my @out = $self->MSWin_perldoc_tempfile(@_);
1436 return @out if @out;
1437 # otherwise fall thru to the normal stuff below...
1441 return File::Temp::tempfile(UNLINK => 1);
1444 #..........................................................................
1446 sub page { # apply a pager to the output file
1447 my ($self, $output, $output_to_stdout, @pagers) = @_;
1448 if ($output_to_stdout) {
1449 $self->aside("Sending unpaged output to STDOUT.\n");
1450 open(TMP, "<", $output) or die "Can't open $output: $!";
1453 print or die "Can't print to stdout: $!";
1455 close TMP or die "Can't close while $output: $!";
1456 $self->unlink_if_temp_file($output);
1458 # On VMS, quoting prevents logical expansion, and temp files with no
1459 # extension get the wrong default extension (such as .LIS for TYPE)
1461 $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
1462 foreach my $pager (@pagers) {
1463 $self->aside("About to try calling $pager $output\n");
1465 last if system("$pager $output") == 0;
1467 last if system("$pager \"$output\"") == 0;
1474 #..........................................................................
1477 my($self, $recurse,$s,@dirs) = @_;
1479 $s = VMS::Filespec::unixify($s) if IS_VMS;
1480 return $s if -f $s && $self->containspod($s);
1481 $self->aside( "Looking for $s in @dirs\n" );
1485 $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
1486 for ($i=0; $i<@dirs; $i++) {
1488 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
1489 if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1490 or ( $ret = $self->check_file($dir,"$s.pm"))
1491 or ( $ret = $self->check_file($dir,$s))
1493 $ret = $self->check_file($dir,"$s.com"))
1495 $ret = $self->check_file($dir,"$s.cmd"))
1496 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
1497 $ret = $self->check_file($dir,"$s.bat"))
1498 or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1499 or ( $ret = $self->check_file("$dir/pod",$s))
1500 or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1501 or ( $ret = $self->check_file("$dir/pods",$s))
1503 DEBUG > 1 and print " Found $ret\n";
1508 opendir(D,$dir) or die "Can't opendir $dir: $!";
1509 my @newdirs = map catfile($dir, $_), grep {
1511 not /^auto\z/s and # save time! don't search auto dirs
1512 -d catfile($dir, $_)
1514 closedir(D) or die "Can't closedir $dir: $!";
1515 next unless @newdirs;
1516 # what a wicked map!
1517 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
1518 $self->aside( "Also looking in @newdirs\n" );
1519 push(@dirs,@newdirs);
1525 #..........................................................................
1527 my $already_asserted;
1528 sub assert_closing_stdout {
1531 return if $already_asserted;
1533 eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
1534 # What for? to let the pager know that nothing more will come?
1537 $already_asserted = 1;
1542 #..........................................................................
1544 sub tweak_found_pathnames {
1545 my($self, $found) = @_;
1547 foreach (@$found) { s,/,\\,g }
1552 #..........................................................................
1554 #..........................................................................
1556 sub am_taint_checking {
1558 die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
1559 my($k,$v) = each %ENV;
1560 return is_tainted($v);
1563 #..........................................................................
1565 sub is_tainted { # just a function
1567 my $nada = substr($arg, 0, 0); # zero-length!
1568 local $@; # preserve the caller's version of $@
1569 eval { eval "# $nada" };
1570 return length($@) != 0;
1573 #..........................................................................
1575 sub drop_privs_maybe {
1578 # Attempt to drop privs if we should be tainting and aren't
1579 if (!(IS_VMS || IS_MSWin32 || IS_Dos
1582 && ($> == 0 || $< == 0)
1583 && !$self->am_taint_checking()
1585 my $id = eval { getpwnam("nobody") };
1586 $id = eval { getpwnam("nouser") } unless defined $id;
1587 $id = -2 unless defined $id;
1589 # According to Stevens' APUE and various
1590 # (BSD, Solaris, HP-UX) man pages, setting
1591 # the real uid first and effective uid second
1592 # is the way to go if one wants to drop privileges,
1593 # because if one changes into an effective uid of
1594 # non-zero, one cannot change the real uid any more.
1596 # Actually, it gets even messier. There is
1597 # a third uid, called the saved uid, and as
1598 # long as that is zero, one can get back to
1599 # uid of zero. Setting the real-effective *twice*
1600 # helps in *most* systems (FreeBSD and Solaris)
1601 # but apparently in HP-UX even this doesn't help:
1602 # the saved uid stays zero (apparently the only way
1603 # in HP-UX to change saved uid is to call setuid()
1604 # when the effective uid is zero).
1607 $< = $id; # real uid
1608 $> = $id; # effective uid
1609 $< = $id; # real uid
1610 $> = $id; # effective uid
1612 die "Superuser must not run $0 without security audit and taint checks.\n"
1613 unless !$@ && $< && $>;
1618 #..........................................................................
1624 # See "perldoc perldoc" for basic details.
1626 # Perldoc -- look up a piece of documentation in .pod format that
1627 # is embedded in the perl installation tree.
1631 # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
1633 # Version 3.01: Sun Nov 10 21:38:09 MST 2002
1634 # Sean M. Burke <sburke@cpan.org>
1635 # Massive refactoring and code-tidying.
1636 # Now it's a module(-family)!
1637 # Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
1638 # Added -T, -d, -o, -M, -w.
1639 # Added some improved MSWin funk.
1643 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
1644 # Hugo van der Sanden <hv@crypt.org>
1645 # Made -U the default, based on patch from Simon Cozens
1646 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
1647 # Randy W. Sims <RandyS@ThePierianSpring.org>
1648 # allow -n to enable nroff under Win32
1649 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
1650 # Hugo van der Sanden <hv@crypt.org>
1651 # don't die when 'use blib' fails
1652 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
1653 # Tom Christiansen <tchrist@perl.com>
1654 # Added -U insecurity option
1655 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
1656 # Tom Christiansen <tchrist@perl.com>, querulously.
1657 # Security and correctness patches.
1658 # What a twisted bit of distasteful spaghetti code.
1663 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
1664 # Charles Wilson <cwilson@ece.gatech.edu>
1665 # changed /pod/ directory to /pods/ for cygwin
1666 # to support cygwin/win32
1667 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
1668 # Robin Barker <rmb1@cise.npl.co.uk>
1669 # -strict, -w cleanups
1670 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
1671 # Gurusamy Sarathy <gsar@activestate.com>
1672 # -doc tweaks for -F and -X options
1673 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
1674 # Gurusamy Sarathy <gsar@activestate.com>
1675 # -various fixes for win32
1676 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
1677 # Kenneth Albanowski <kjahds@kjahds.com>
1678 # -added Charles Bailey's further VMS patches, and -u switch
1679 # -added -t switch, with pod2text support
1681 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
1682 # Kenneth Albanowski <kjahds@kjahds.com>
1683 # -added VMS support
1684 # -added better error recognition (on no found pages, just exit. On
1685 # missing nroff/pod2man, just display raw pod.)
1686 # -added recursive/case-insensitive matching (thanks, Andreas). This
1687 # slows things down a bit, unfortunately. Give a precise name, and
1690 # Version 1.01: Tue May 30 14:47:34 EDT 1995
1691 # Andy Dougherty <doughera@lafayette.edu>
1692 # -added pod documentation.
1693 # -added PATH searching.
1694 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
1701 # Cache the directories read during sloppy match
1702 # (To disk, or just in-memory?)
1704 # Backport this to perl 5.005?
1706 # Implement at least part of the "perlman" interface described
1707 # in Programming Perl 3e?