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];
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;
49 $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
50 # If it's older than five days, it's quite unlikely
51 # that anyone's still looking at it!!
52 # (Currently used only by the MSWin cleanup routine)
54 # End of class-init stuff
56 ###########################################################################
60 foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTd}) {
62 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
65 # And these are so that GetOptsOO knows they take options:
66 sub opt_f_with { shift->_elem('opt_f', @_) }
67 sub opt_q_with { shift->_elem('opt_q', @_) }
68 sub opt_d_with { shift->_elem('opt_d', @_) }
70 sub opt_w_with { # Specify an option for the formatter subclass
71 my($self, $value) = @_;
72 if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
74 my $option_value = defined($2) ? $2 : "TRUE";
75 $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
76 $self->add_formatter_option( $option, $option_value );
78 warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
83 sub opt_M_with { # specify formatter class name(s)
84 my($self, $classes) = @_;
85 return unless defined $classes and length $classes;
86 DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
88 foreach my $classname (split m/[,;]+/s, $classes) {
89 next unless $classname =~ m/\S/;
90 if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
91 # A mildly restrictive concept of what modulenames are valid.
92 push @classes_to_add, $1; # untaint
94 warn "\"$classname\" isn't a valid classname. Ignoring.\n";
98 unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
101 "Adding @classes_to_add to the list of formatter classes, "
102 . "making them @{ $self->{'formatter_classes'} }.\n"
108 sub opt_V { # report version and exit
110 "Perldoc v$VERSION, under perl v$] for $^O",
112 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
113 ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
115 (chr(65) eq 'A') ? () : " (non-ASCII)",
122 sub opt_U {} # legacy no-op
124 sub opt_t { # choose plaintext as output format
126 $self->opt_o_with('text') if @_ and $_[0];
127 return $self->_elem('opt_t', @_);
130 sub opt_u { # choose raw pod as output format
132 $self->opt_o_with('pod') if @_ and $_[0];
133 return $self->_elem('opt_u', @_);
137 # choose man as the output format, and specify the proggy to run
139 $self->opt_o_with('man') if @_ and $_[0];
140 $self->_elem('opt_n', @_);
143 sub opt_o_with { # "o" for output format
144 my($self, $rest) = @_;
145 return unless defined $rest and length $rest;
146 if($rest =~ m/^(\w+)$/s) {
149 warn "\"$rest\" isn't a valid output format. Skipping.\n";
153 $self->aside("Noting \"$rest\" as desired output format...\n");
155 # Figure out what class(es) that could actually mean...
158 foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
161 $rest, # Yes, try it first with the given capitalization
162 "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
165 push @classes, $prefix . $stem;
166 #print "Considering $prefix$stem\n";
169 # Tidier, but misses too much:
170 #push @classes, $prefix . ucfirst(lc($rest));
172 $self->opt_M_with( join ";", @classes );
176 ###########################################################################
177 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
179 sub run { # to be called by the "perldoc" executable
182 print "Parameters to $class\->run:\n";
185 $x[1] = '<undef>' unless defined $x[1];
186 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
187 print " [$x[0]] => [$x[1]]\n";
192 return $class -> new(@_) -> process() || 0;
195 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
196 ###########################################################################
198 sub new { # yeah, nothing fancy
200 my $new = bless {@_}, (ref($class) || $class);
201 DEBUG > 1 and print "New $class object $new\n";
206 #..........................................................................
208 sub aside { # If we're in -v or DEBUG mode, say this.
210 if( DEBUG or $self->opt_v ) {
213 my $callsub = (caller(1))[3];
214 my $package = quotemeta(__PACKAGE__ . '::');
215 $callsub =~ s/^$package/'/os;
220 if(DEBUG) { print $out } else { print STDERR $out }
225 #..........................................................................
231 # Erase evidence of previous errors (if any), so exit status is simple.
235 perldoc [options] PageName|ModuleName|ProgramName...
236 perldoc [options] -f BuiltinFunction
237 perldoc [options] -q FAQRegex
240 -h Display this help message
242 -r Recursive search (slow)
244 -t Display pod using pod2text instead of pod2man and nroff
245 (-t is the default on win32 unless -n is specified)
246 -u Display unformatted pod text
247 -m Display module's file in its entirety
248 -n Specify replacement for nroff
249 -l Display the module's file name
250 -F Arguments are file names, not modules
251 -v Verbosely describe what's going on
252 -T Send output to STDOUT without any pager
253 -d output_filename_to_send_to
254 -o output_format_name
255 -M FormatterModuleNameToUse
256 -w formatter_option:option_value
257 -X use index if present (looks for pod.idx at $Config{archlib})
258 -q Search the text of questions (not answers) in perlfaq[1-9]
260 PageName|ModuleName...
261 is the name of a piece of documentation that you want to look at. You
262 may either give a descriptive name of the page (as in the case of
263 `perlfunc') the name of a module, either like `Term::Info' or like
264 `Term/Info', or the name of a program, like `perldoc'.
267 is the name of a perl function. Will extract documentation from
271 is a regex. Will search perlfaq[1-9] for and extract any
272 questions that match.
274 Any switches in the PERLDOC environment variable will be used before the
275 command line arguments. The optional pod index file contains a list of
276 filenames, one per line.
282 #..........................................................................
285 my $me = $0; # Editing $0 is unportable
287 $me =~ s,.*[/\\],,; # get basename
290 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
294 The -h option prints more help. Also try "perldoc perldoc" to get
295 acquainted with the system. [Perldoc v$VERSION]
300 #..........................................................................
302 sub pagers { @{ shift->{'pagers'} } }
304 #..........................................................................
306 sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
307 if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
308 else { return $_[0]{ $_[1] } }
310 #..........................................................................
311 ###########################################################################
313 # Init formatter switches, and start it off with __bindir and all that
314 # other stuff that ToMan.pm needs.
320 # Make sure creat()s are neither too much nor too little
321 eval { umask(0077) }; # doubtless someone has no mask
323 $self->{'args'} ||= \@ARGV;
324 $self->{'found'} ||= [];
325 $self->{'temp_file_list'} ||= [];
328 $self->{'target'} = undef;
330 $self->init_formatter_class_list;
332 $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
333 $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
334 $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
336 push @{ $self->{'formatter_switches'} = [] }, (
337 # Yeah, we could use a hashref, but maybe there's some class where options
338 # have to be ordered; so we'll use an arrayref.
340 [ '__bindir' => $self->{'bindir' } ],
341 [ '__pod2man' => $self->{'pod2man'} ],
344 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
345 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
350 #..........................................................................
352 sub init_formatter_class_list {
354 $self->{'formatter_classes'} ||= [];
356 # Remember, no switches have been read yet, when
357 # we've started this routine.
359 $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
360 $self->opt_o_with('text');
361 $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
362 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i);
367 #..........................................................................
370 # if this ever returns, its retval will be used for exit(RETVAL)
373 DEBUG > 1 and print " Beginning process.\n";
374 DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
376 print "Object contents:\n";
379 $x[1] = '<undef>' unless defined $x[1];
380 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
381 print " [$x[0]] => [$x[1]]\n";
387 # TODO: make it deal with being invoked as various different things
390 return $self->usage_brief unless @{ $self->{'args'} };
391 $self->pagers_guessing;
392 $self->options_reading;
393 $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
394 $self->drop_privs_maybe;
395 $self->options_processing;
397 # Hm, we have @pages and @found, but we only really act on one
398 # file per call, with the exception of the opt_q hack, and with
404 $self->{'pages'} = \@pages;
405 if( $self->opt_f) { @pages = ("perlfunc") }
406 elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
407 else { @pages = @{$self->{'args'}};
409 # if @pages == 1 and $pages[0] eq 'perldoc';
412 return $self->usage_brief unless @pages;
414 $self->find_good_formatter_class();
415 $self->formatter_sanity_check();
417 $self->maybe_diddle_INC();
418 # for when we're apparently in a module or extension directory
420 my @found = $self->grand_search_init(\@pages);
421 exit (IS_VMS ? 98962 : 1) unless @found;
424 DEBUG and print "We're in -l mode, so byebye after this:\n";
425 print join("\n", @found), "\n";
429 $self->tweak_found_pathnames(\@found);
430 $self->assert_closing_stdout;
431 return $self->page_module_file(@found) if $self->opt_m;
432 DEBUG > 2 and print "Found: [@found]\n";
434 return $self->render_and_page(\@found);
437 #..........................................................................
440 my( %class_seen, %class_loaded );
441 sub find_good_formatter_class {
443 my @class_list = @{ $self->{'formatter_classes'} || [] };
444 die "WHAT? Nothing in the formatter class list!?" unless @class_list;
446 my $good_class_found;
447 foreach my $c (@class_list) {
448 DEBUG > 4 and print "Trying to load $c...\n";
449 if($class_loaded{$c}) {
450 DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
451 $good_class_found = $c;
455 if($class_seen{$c}) {
457 "I've tried $c before, and it's no good. Skipping.\n";
463 if( $c->can('parse_from_file') ) {
465 "Interesting, the formatter class $c is already loaded!\n";
468 (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
469 # the alway case-insensitive fs's
470 and $class_seen{lc("~$c")}++
473 "We already used something quite like \"\L$c\E\", so no point using $c\n";
474 # This avoids redefining the package.
476 DEBUG > 4 and print "Trying to eval 'require $c'...\n";
479 if(DEBUG() or $self->opt_v) {
480 # feh, let 'em see it
483 # The average user just has no reason to be seeing
484 # $^W-suppressable warnings from the the require!
489 DEBUG > 4 and print "Couldn't load $c: $!\n";
494 if( $c->can('parse_from_file') ) {
495 DEBUG > 4 and print "Settling on $c\n";
497 $v = ( defined $v and length $v ) ? " version $v" : '';
498 $self->aside("Formatter class $c$v successfully loaded!\n");
499 $good_class_found = $c;
502 DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
506 die "Can't find any loadable formatter class in @class_list?!\nAborting"
507 unless $good_class_found;
509 $self->{'formatter_class'} = $good_class_found;
510 $self->aside("Will format with the class $good_class_found\n");
516 #..........................................................................
518 sub formatter_sanity_check {
520 my $formatter_class = $self->{'formatter_class'}
521 || die "NO FORMATTER CLASS YET!?";
523 if(!$self->opt_T # so -T can FORCE sending to STDOUT
524 and $formatter_class->can('is_pageable')
525 and !$formatter_class->is_pageable
526 and !$formatter_class->can('page_for_perldoc')
529 ($formatter_class->can('output_extension')
530 && $formatter_class->output_extension
532 $ext = ".$ext" if length $ext;
535 "When using Perldoc to format with $formatter_class, you have to\n"
536 . "specify -T or -dsomefile$ext\n"
537 . "See `perldoc perldoc' for more information on those switches.\n"
542 #..........................................................................
544 sub render_and_page {
545 my($self, $found_list) = @_;
547 $self->maybe_generate_dynamic_pod($found_list);
549 my($out, $formatter) = $self->render_findings($found_list);
552 printf "Perldoc (%s) output saved to %s\n",
553 $self->{'formatter_class'} || ref($self),
555 print "But notice that it's 0 bytes long!\n" unless -s $out;
558 } elsif( # Allow the formatter to "page" itself, if it wants.
559 $formatter->can('page_for_perldoc')
561 $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
562 if( $formatter->page_for_perldoc($out, $self) ) {
563 $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
566 $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
571 # Do nothing, since the formatter has "paged" it for itself.
574 # Page it normally (internally)
576 if( -s $out ) { # Usual case:
577 $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
581 $self->aside("Skipping $out (from $$found_list[0] "
582 . "via $$self{'formatter_class'}) as it is 0-length.\n");
584 push @{ $self->{'temp_file_list'} }, $out;
585 $self->unlink_if_temp_file($out);
589 $self->after_rendering(); # any extra cleanup or whatever
594 #..........................................................................
596 sub options_reading {
599 if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
600 require Text::ParseWords;
601 $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
602 # Yes, appends to the beginning
603 unshift @{ $self->{'args'} },
604 Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
606 DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
608 DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
612 and print " Args right before switch processing: @{$self->{'args'}}\n";
614 Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
615 or return $self->usage;
618 and print " Args after switch processing: @{$self->{'args'}}\n";
620 return $self->usage if $self->opt_h;
625 #..........................................................................
627 sub options_processing {
631 my $podidx = "$Config{'archlib'}/pod.idx";
632 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
633 $self->{'podidx'} = $podidx;
636 $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
638 $self->options_sanity;
640 $self->opt_n("nroff") unless $self->opt_n;
641 $self->add_formatter_option( '__nroffer' => $self->opt_n );
646 #..........................................................................
651 # The opts-counting stuff interacts quite badly with
652 # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
653 # set to -t, and I specify -u on the command line, I don't want
654 # to be hectored at that -u and -t don't make sense together.
656 #my $opts = grep $_ && 1, # yes, the count of the set ones
657 # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
660 #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
663 # Any sanity-checking need doing here?
668 #..........................................................................
670 sub grand_search_init {
671 my($self, $pages, @found) = @_;
674 if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
675 my $searchfor = catfile split '::', $_;
676 $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
680 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
682 close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
686 $self->aside( "Searching for $_\n" );
690 push @found, $_ if $self->opt_m or $self->containspod($_);
694 # We must look both in @INC for library modules and in $bindir
695 # for executables, like h2xs or perldoc itself.
697 my @searchdirs = ($self->{'bindir'}, @INC);
698 unless ($self->opt_m) {
701 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
702 push(@searchdirs,$trn);
704 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
707 push(@searchdirs, grep(-d, split($Config{path_sep},
711 my @files = $self->searchfor(0,$_,@searchdirs);
713 $self->aside( "Found as @files\n" );
716 # no match, try recursive search
717 @searchdirs = grep(!/^\.\z/s,@INC);
718 @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
720 $self->aside( "Loosely found as @files\n" );
724 ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
725 if ( @{ $self->{'found'} } ) {
726 print STDERR "However, try\n";
727 for my $dir (@{ $self->{'found'} }) {
728 opendir(DIR, $dir) or die "opendir $dir: $!";
729 while (my $file = readdir(DIR)) {
730 next if ($file =~ /^\./s);
731 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
732 print STDERR "\tperldoc $_\::$file\n";
734 closedir DIR or die "closedir $dir: $!";
744 #..........................................................................
746 sub maybe_generate_dynamic_pod {
747 my($self, $found_things) = @_;
750 $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
752 $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
754 if( ! $self->opt_f and ! $self->opt_q ) {
755 DEBUG > 4 and print "That's a non-dynamic pod search.\n";
756 } elsif ( @dynamic_pod ) {
757 $self->aside("Hm, I found some Pod from that search!\n");
758 my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
760 push @{ $self->{'temp_file_list'} }, $buffer;
761 # I.e., it MIGHT be deleted at the end.
763 print $buffd "=over 8\n\n";
764 print $buffd @dynamic_pod or die "Can't print $buffer: $!";
765 print $buffd "=back\n";
766 close $buffd or die "Can't close $buffer: $!";
768 @$found_things = $buffer;
769 # Yes, so found_things never has more than one thing in
770 # it, by time we leave here
772 $self->add_formatter_option('__filter_nroff' => 1);
776 $self->aside("I found no Pod from that search!\n");
782 #..........................................................................
784 sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
786 push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
788 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
789 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
794 #..........................................................................
796 sub search_perlfunc {
797 my($self, $found_things, $pod) = @_;
799 DEBUG > 2 and print "Search: @$found_things\n";
801 my $perlfunc = shift @$found_things;
802 open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
803 or die("Can't open $perlfunc: $!");
805 # Functions like -r, -e, etc. are listed under `-X'.
806 my $search_string = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
807 ? 'I<-X' : $self->opt_f ;
810 print "Going to perlfunc-scan for $search_string in $perlfunc\n";
816 last if /^=head2 Alphabetical Listing of Perl Functions/;
819 # Look for our function
822 while (<PFUNC>) { # "The Mothership Connection is here!"
823 if (/^=item\s+\Q$search_string\E\b/o) {
827 last if $found > 1 and not $inlist;
837 ++$found if /^\w/; # found descriptive text
841 "No documentation for perl function `%s' found\n",
845 close PFUNC or die "Can't open $perlfunc: $!";
850 #..........................................................................
852 sub search_perlfaqs {
853 my( $self, $found_things, $pod) = @_;
857 my $search_key = $self->opt_q;
858 my $rx = eval { qr/$search_key/ } or die <<EOD;
859 Invalid regular expression '$search_key' given as -q pattern:
861 Did you mean \\Q$search_key ?
866 foreach my $file (@$found_things) {
867 die "invalid file spec: $!" if $file =~ /[<>|]/;
868 open(INFAQ, "<", $file) or die "Can't read-open $file: $!\nAborting";
870 if (/^=head2\s+.*(?:$search_key)/oi) { # it's good for only one key
872 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
874 elsif (/^=head[12]/) {
882 die("No documentation for perl FAQ keyword `$search_key' found\n")
889 #..........................................................................
891 sub render_findings {
892 # Return the filename to open
894 my($self, $found_things) = @_;
896 my $formatter_class = $self->{'formatter_class'}
897 || die "No formatter class set!?";
898 my $formatter = $formatter_class->can('new')
899 ? $formatter_class->new
903 if(! @$found_things) {
904 die "Nothing found?!";
905 # should have been caught before here
906 } elsif(@$found_things > 1) {
908 "Perldoc is only really meant for reading one document at a time.\n",
909 "So these parameters are being ignored: ",
910 join(' ', @$found_things[1 .. $#$found_things] ),
914 my $file = $found_things->[0];
916 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
917 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
919 # Set formatter options:
920 if( ref $formatter ) {
921 foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
922 my($switch, $value, $silent_fail) = @$f;
923 if( $formatter->can($switch) ) {
924 eval { $formatter->$switch( defined($value) ? $value : () ) };
925 warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
928 if( $silent_fail or $switch =~ m/^__/s ) {
929 DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
931 warn "$formatter_class doesn't recognize the $switch switch.\n";
937 $self->{'output_is_binary'} =
938 $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
940 my ($out_fh, $out) = $self->new_output_file(
941 ( $formatter->can('output_extension') && $formatter->output_extension )
943 $self->useful_filename_bit,
946 # Now, finally, do the formatting!
949 if(DEBUG() or $self->opt_v) {
950 # feh, let 'em see it
953 # The average user just has no reason to be seeing
954 # $^W-suppressable warnings from the formatting!
957 eval { $formatter->parse_from_file( $file, $out_fh ) };
960 warn "Error while formatting with $formatter_class:\n $@\n" if $@;
961 DEBUG > 2 and print "Back from formatting with $formatter_class\n";
964 or warn "Can't close $out: $!\n(Did $formatter already close it?)";
965 sleep 0; sleep 0; sleep 0;
966 # Give the system a few timeslices to meditate on the fact
967 # that the output file does in fact exist and is closed.
969 $self->unlink_if_temp_file($file);
972 if( $formatter->can( 'if_zero_length' ) ) {
973 # Basically this is just a hook for Pod::Simple::Checker; since
974 # what other class could /happily/ format an input file with Pod
975 # as a 0-length output file?
976 $formatter->if_zero_length( $file, $out, $out_fh );
978 warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
982 DEBUG and print "Finished writing to $out.\n";
983 return($out, $formatter) if wantarray;
987 #..........................................................................
989 sub unlink_if_temp_file {
990 # Unlink the specified file IFF it's in the list of temp files.
991 # Really only used in the case of -f / -q things when we can
992 # throw away the dynamically generated source pod file once
993 # we've formatted it.
995 my($self, $file) = @_;
996 return unless defined $file and length $file;
998 my $temp_file_list = $self->{'temp_file_list'} || return;
999 if(grep $_ eq $file, @$temp_file_list) {
1000 $self->aside("Unlinking $file\n");
1001 unlink($file) or warn "Odd, couldn't unlink $file: $!";
1003 DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1008 #..........................................................................
1010 sub MSWin_temp_cleanup {
1012 # Nothing particularly MSWin-specific in here, but I don't know if any
1013 # other OS needs its temp dir policed like MSWin does!
1017 my $tempdir = $ENV{'TEMP'};
1018 return unless defined $tempdir and length $tempdir
1019 and -e $tempdir and -d _ and -w _;
1022 "Considering whether any old files of mine in $tempdir need unlinking.\n"
1025 opendir(TMPDIR, $tempdir) || return;
1028 my $limit = time() - $Temp_File_Lifetime;
1030 DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
1035 while(defined($filespec = readdir(TMPDIR))) {
1037 $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
1039 if( hex($1) < $limit ) {
1040 push @to_unlink, "$tempdir/$filespec";
1041 $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
1044 printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
1048 print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
1052 $self->aside(sprintf "Unlinked %s items of mine in %s\n",
1053 scalar(unlink(@to_unlink)),
1059 # . . . . . . . . . . . . . . . . . . . . . . . . .
1061 sub MSWin_perldoc_tempfile {
1062 my($self, $suffix, $infix) = @_;
1064 my $tempdir = $ENV{'TEMP'};
1065 return unless defined $tempdir and length $tempdir
1066 and -e $tempdir and -d _ and -w _;
1071 $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
1072 # Yes, we embed the create-time in the filename!
1077 defined( &Win32::GetTickCount )
1078 ? (Win32::GetTickCount() & 0xff)
1080 # Under MSWin, $$ values get reused quickly! So if we ran
1081 # perldoc foo and then perldoc bar before there was time for
1082 # time() to increment time."_$$" would likely be the same
1083 # for each process! So we tack on the tick count's lower
1084 # bits (or, in a pinch, rand)
1088 } while( -e $spec );
1092 while($counter < 50) {
1094 # If we are running before perl5.6.0, we can't autovivify
1097 $fh = Symbol::gensym();
1099 DEBUG > 3 and print "About to try making temp file $spec\n";
1100 return($fh, $spec) if open($fh, ">", $spec);
1101 $self->aside("Can't create temp file $spec: $!\n");
1104 $self->aside("Giving up on making a temp file!\n");
1105 die "Can't make a tempfile!?";
1108 #..........................................................................
1111 sub after_rendering {
1113 $self->after_rendering_VMS if IS_VMS;
1114 $self->after_rendering_MSWin32 if IS_MSWin32;
1115 $self->after_rendering_Dos if IS_Dos;
1116 $self->after_rendering_OS2 if IS_OS2;
1120 sub after_rendering_VMS { return }
1121 sub after_rendering_Dos { return }
1122 sub after_rendering_OS2 { return }
1124 sub after_rendering_MSWin32 {
1125 shift->MSWin_temp_cleanup() if $Temp_Files_Created;
1128 #..........................................................................
1130 #..........................................................................
1133 sub minus_f_nocase { # i.e., do like -f, but without regard to case
1135 my($self, $dir, $file) = @_;
1136 my $path = catfile($dir,$file);
1137 return $path if -f $path and -r _;
1140 or IS_VMS or IS_MSWin32
1143 # On a case-forgiving file system, or if case is important,
1144 # that is it, all we can do.
1145 warn "Ignored $path: unreadable\n" if -f _;
1152 foreach $p (splitdir $file){
1153 my $try = catfile @p, $p;
1154 $self->aside("Scrutinizing $try...\n");
1158 if ( $p eq $self->{'target'} ) {
1159 my $tmp_path = catfile @p;
1161 for (@{ $self->{'found'} }) {
1162 $path_f = 1 if $_ eq $tmp_path;
1164 push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1165 $self->aside( "Found as $tmp_path but directory\n" );
1168 elsif (-f _ && -r _) {
1172 warn "Ignored $try: unreadable\n";
1174 elsif (-d catdir(@p)) { # at least we see the containing directory!
1177 my $p_dirspec = catdir(@p);
1178 opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
1179 while(defined( $cip = readdir(DIR) )) {
1180 if (lc $cip eq $lcp){
1182 last; # XXX stop at the first? what if there's others?
1185 closedir DIR or die "closedir $p_dirspec: $!";
1186 return "" unless $found;
1189 my $p_filespec = catfile(@p);
1190 return $p_filespec if -f $p_filespec and -r _;
1191 warn "Ignored $p_filespec: unreadable\n" if -f _;
1197 #..........................................................................
1199 sub pagers_guessing {
1203 push @pagers, $self->pagers;
1204 $self->{'pagers'} = \@pagers;
1207 push @pagers, qw( more< less notepad );
1208 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1211 push @pagers, qw( most more less type/page );
1214 push @pagers, qw( less.exe more.com< );
1215 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1219 unshift @pagers, 'less', 'cmd /c more <';
1221 push @pagers, qw( more less pg view cat );
1222 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1224 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
1229 #..........................................................................
1231 sub page_module_file {
1232 my($self, @found) = @_;
1235 # Don't ever just pass this off to anything like MSWin's "start.exe",
1236 # since we might be calling on a .pl file, and we wouldn't want that
1237 # to actually /execute/ the file that we just want to page thru!
1238 # Also a consideration if one were to use a web browser as a pager;
1239 # doing so could trigger the browser's MIME mapping for whatever
1240 # it thinks .pm/.pl/whatever is. Probably just a (useless and
1241 # annoying) "Save as..." dialog, but potentially executing the file
1242 # in question -- particularly in the case of MSIE and it's, ahem,
1243 # occasionally hazy distinction between OS-local extension
1244 # associations, and browser-specific MIME mappings.
1246 if ($self->{'output_to_stdout'}) {
1247 $self->aside("Sending unpaged output to STDOUT.\n");
1250 foreach my $output (@found) {
1251 unless( open(TMP, "<", $output) ) {
1252 warn("Can't open $output: $!");
1257 print or die "Can't print to stdout: $!";
1259 close TMP or die "Can't close while $output: $!";
1260 $self->unlink_if_temp_file($output);
1262 return $any_error; # successful
1265 foreach my $pager ( $self->pagers ) {
1266 $self->aside("About to try calling $pager @found\n");
1267 if (system($pager, @found) == 0) {
1268 $self->aside("Yay, it worked.\n");
1271 $self->aside("That didn't work.\n");
1273 # Odd -- when it fails, under Win32, this seems to neither
1274 # return with a fail nor return with a success!!
1275 # That's discouraging!
1279 sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
1281 join(' ', $self->pagers),
1285 DEBUG > 1 and print "Bailing out in a VMSish way.\n";
1287 use vmsish qw(status exit);
1294 # i.e., an UNSUCCESSFUL return value!
1297 #..........................................................................
1300 my($self, $dir, $file) = @_;
1302 unless( ref $self ) {
1303 # Should never get called:
1305 Carp::croak join '',
1306 "Crazy ", __PACKAGE__, " error:\n",
1307 "check_file must be an object_method!\n",
1311 if(length $dir and not -d $dir) {
1312 DEBUG > 3 and print " No dir $dir -- skipping.\n";
1317 return $self->minus_f_nocase($dir,$file);
1321 my $path = $self->minus_f_nocase($dir,$file);
1322 if( length $path and $self->containspod($path) ) {
1324 " The file $path indeed looks promising!\n";
1328 DEBUG > 3 and print " No good: $file in $dir\n";
1333 #..........................................................................
1336 my($self, $file, $readit) = @_;
1337 return 1 if !$readit && $file =~ /\.pod\z/i;
1339 open(TEST,"<", $file) or die "Can't open $file: $!";
1342 close(TEST) or die "Can't close $file: $!";
1346 close(TEST) or die "Can't close $file: $!";
1350 #..........................................................................
1352 sub maybe_diddle_INC {
1355 # Does this look like a module or extension directory?
1357 if (-f "Makefile.PL") {
1359 # Add "." and "lib" to @INC (if they exist)
1360 eval q{ use lib qw(. lib); 1; } or die;
1362 # don't add if superuser
1363 if ($< && $> && -f "blib") { # don't be looking too hard now!
1364 eval q{ use blib; 1 };
1365 warn $@ if $@ && $self->opt_v;
1372 #..........................................................................
1374 sub new_output_file {
1376 my $outspec = $self->opt_d; # Yes, -d overrides all else!
1377 # So don't call this twice per format-job!
1379 return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1381 # Otherwise open a write-handle on opt_d!f
1384 # If we are running before perl5.6.0, we can't autovivify
1387 $fh = Symbol::gensym();
1389 DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1390 die "Can't write-open $outspec: $!" unless open($fh, ">", $outspec);
1391 DEBUG > 3 and print "Successfully opened $outspec\n";
1392 binmode($fh) if $self->{'output_is_binary'};
1393 return($fh, $outspec);
1396 #..........................................................................
1398 sub useful_filename_bit {
1399 # This tries to provide a meaningful bit of text to do with the query,
1400 # such as can be used in naming the file -- since if we're going to be
1401 # opening windows on temp files (as a "pager" may well do!) then it's
1402 # better if the temp file's name (which may well be used as the window
1403 # title) isn't ALL just random garbage!
1404 # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1405 # name than "perldoc_2371981429". So this routine is what tries to
1406 # provide the "LWPSimple" bit.
1409 my $pages = $self->{'pages'} || return undef;
1410 return undef unless @$pages;
1412 my $chunk = $pages->[0];
1413 return undef unless defined $chunk;
1415 $chunk =~ s/\.\w+$//g; # strip any extension
1416 if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1421 $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1422 $chunk = substr($chunk, -10) if length($chunk) > 10;
1426 #..........................................................................
1428 sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
1431 ++$Temp_Files_Created;
1434 my @out = $self->MSWin_perldoc_tempfile(@_);
1435 return @out if @out;
1436 # otherwise fall thru to the normal stuff below...
1440 return File::Temp::tempfile(UNLINK => 1);
1443 #..........................................................................
1445 sub page { # apply a pager to the output file
1446 my ($self, $output, $output_to_stdout, @pagers) = @_;
1447 if ($output_to_stdout) {
1448 $self->aside("Sending unpaged output to STDOUT.\n");
1449 open(TMP, "<", $output) or die "Can't open $output: $!";
1452 print or die "Can't print to stdout: $!";
1454 close TMP or die "Can't close while $output: $!";
1455 $self->unlink_if_temp_file($output);
1457 # On VMS, quoting prevents logical expansion, and temp files with no
1458 # extension get the wrong default extension (such as .LIS for TYPE)
1460 $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
1461 foreach my $pager (@pagers) {
1462 $self->aside("About to try calling $pager $output\n");
1464 last if system("$pager $output") == 0;
1466 last if system("$pager \"$output\"") == 0;
1473 #..........................................................................
1476 my($self, $recurse,$s,@dirs) = @_;
1478 $s = VMS::Filespec::unixify($s) if IS_VMS;
1479 return $s if -f $s && $self->containspod($s);
1480 $self->aside( "Looking for $s in @dirs\n" );
1484 $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
1485 for ($i=0; $i<@dirs; $i++) {
1487 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
1488 if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1489 or ( $ret = $self->check_file($dir,"$s.pm"))
1490 or ( $ret = $self->check_file($dir,$s))
1492 $ret = $self->check_file($dir,"$s.com"))
1494 $ret = $self->check_file($dir,"$s.cmd"))
1495 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
1496 $ret = $self->check_file($dir,"$s.bat"))
1497 or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1498 or ( $ret = $self->check_file("$dir/pod",$s))
1499 or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1500 or ( $ret = $self->check_file("$dir/pods",$s))
1502 DEBUG > 1 and print " Found $ret\n";
1507 opendir(D,$dir) or die "Can't opendir $dir: $!";
1508 my @newdirs = map catfile($dir, $_), grep {
1510 not /^auto\z/s and # save time! don't search auto dirs
1511 -d catfile($dir, $_)
1513 closedir(D) or die "Can't closedir $dir: $!";
1514 next unless @newdirs;
1515 # what a wicked map!
1516 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
1517 $self->aside( "Also looking in @newdirs\n" );
1518 push(@dirs,@newdirs);
1524 #..........................................................................
1526 my $already_asserted;
1527 sub assert_closing_stdout {
1530 return if $already_asserted;
1532 eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
1533 # What for? to let the pager know that nothing more will come?
1536 $already_asserted = 1;
1541 #..........................................................................
1543 sub tweak_found_pathnames {
1544 my($self, $found) = @_;
1546 foreach (@$found) { s,/,\\,g }
1551 #..........................................................................
1553 #..........................................................................
1555 sub am_taint_checking {
1557 die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
1558 my($k,$v) = each %ENV;
1559 return is_tainted($v);
1562 #..........................................................................
1564 sub is_tainted { # just a function
1566 my $nada = substr($arg, 0, 0); # zero-length!
1567 local $@; # preserve the caller's version of $@
1568 eval { eval "# $nada" };
1569 return length($@) != 0;
1572 #..........................................................................
1574 sub drop_privs_maybe {
1577 # Attempt to drop privs if we should be tainting and aren't
1578 if (!(IS_VMS || IS_MSWin32 || IS_Dos
1581 && ($> == 0 || $< == 0)
1582 && !$self->am_taint_checking()
1584 my $id = eval { getpwnam("nobody") };
1585 $id = eval { getpwnam("nouser") } unless defined $id;
1586 $id = -2 unless defined $id;
1588 # According to Stevens' APUE and various
1589 # (BSD, Solaris, HP-UX) man pages, setting
1590 # the real uid first and effective uid second
1591 # is the way to go if one wants to drop privileges,
1592 # because if one changes into an effective uid of
1593 # non-zero, one cannot change the real uid any more.
1595 # Actually, it gets even messier. There is
1596 # a third uid, called the saved uid, and as
1597 # long as that is zero, one can get back to
1598 # uid of zero. Setting the real-effective *twice*
1599 # helps in *most* systems (FreeBSD and Solaris)
1600 # but apparently in HP-UX even this doesn't help:
1601 # the saved uid stays zero (apparently the only way
1602 # in HP-UX to change saved uid is to call setuid()
1603 # when the effective uid is zero).
1606 $< = $id; # real uid
1607 $> = $id; # effective uid
1608 $< = $id; # real uid
1609 $> = $id; # effective uid
1611 die "Superuser must not run $0 without security audit and taint checks.\n"
1612 unless !$@ && $< && $>;
1617 #..........................................................................
1623 # See "perldoc perldoc" for basic details.
1625 # Perldoc -- look up a piece of documentation in .pod format that
1626 # is embedded in the perl installation tree.
1629 # Version 3.06: Sunday November 17 2002 -- 14:05:28
1630 # Sean M. Burke <sburke@cpan.org>
1631 # Added -V to report version
1632 # Restore -U as a no-op legacy switch.
1634 # Version 3.01: Sun Nov 10 21:38:09 MST 2002
1635 # Sean M. Burke <sburke@cpan.org>
1636 # Massive refactoring and code-tidying.
1637 # Now it's a module(-family)!
1638 # Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
1639 # Added -T, -d, -o, -M, -w.
1640 # Added some improved MSWin funk.
1644 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
1645 # Hugo van der Sanden <hv@crypt.org>
1646 # Made -U the default, based on patch from Simon Cozens
1647 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
1648 # Randy W. Sims <RandyS@ThePierianSpring.org>
1649 # allow -n to enable nroff under Win32
1650 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
1651 # Hugo van der Sanden <hv@crypt.org>
1652 # don't die when 'use blib' fails
1653 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
1654 # Tom Christiansen <tchrist@perl.com>
1655 # Added -U insecurity option
1656 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
1657 # Tom Christiansen <tchrist@perl.com>, querulously.
1658 # Security and correctness patches.
1659 # What a twisted bit of distasteful spaghetti code.
1664 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
1665 # Charles Wilson <cwilson@ece.gatech.edu>
1666 # changed /pod/ directory to /pods/ for cygwin
1667 # to support cygwin/win32
1668 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
1669 # Robin Barker <rmb1@cise.npl.co.uk>
1670 # -strict, -w cleanups
1671 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
1672 # Gurusamy Sarathy <gsar@activestate.com>
1673 # -doc tweaks for -F and -X options
1674 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
1675 # Gurusamy Sarathy <gsar@activestate.com>
1676 # -various fixes for win32
1677 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
1678 # Kenneth Albanowski <kjahds@kjahds.com>
1679 # -added Charles Bailey's further VMS patches, and -u switch
1680 # -added -t switch, with pod2text support
1682 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
1683 # Kenneth Albanowski <kjahds@kjahds.com>
1684 # -added VMS support
1685 # -added better error recognition (on no found pages, just exit. On
1686 # missing nroff/pod2man, just display raw pod.)
1687 # -added recursive/case-insensitive matching (thanks, Andreas). This
1688 # slows things down a bit, unfortunately. Give a precise name, and
1691 # Version 1.01: Tue May 30 14:47:34 EDT 1995
1692 # Andy Dougherty <doughera@lafayette.edu>
1693 # -added pod documentation.
1694 # -added PATH searching.
1695 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
1702 # Cache the directories read during sloppy match
1703 # (To disk, or just in-memory?)
1705 # Backport this to perl 5.005?
1707 # Implement at least part of the "perlman" interface described
1708 # in Programming Perl 3e?