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 #..........................................................................
37 *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
38 *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
39 *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
40 *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
41 *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
44 $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
45 # If it's older than five days, it's quite unlikely
46 # that anyone's still looking at it!!
47 # (Currently used only by the MSWin cleanup routine)
50 #..........................................................................
51 { my $pager = $Config{'pager'};
52 push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
54 $Bindir = $Config{'scriptdirexp'};
55 $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
57 # End of class-init stuff
59 ###########################################################################
63 foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) {
65 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
68 # And these are so that GetOptsOO knows they take options:
69 sub opt_f_with { shift->_elem('opt_f', @_) }
70 sub opt_q_with { shift->_elem('opt_q', @_) }
71 sub opt_d_with { shift->_elem('opt_d', @_) }
73 sub opt_w_with { # Specify an option for the formatter subclass
74 my($self, $value) = @_;
75 if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
77 my $option_value = defined($2) ? $2 : "TRUE";
78 $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
79 $self->add_formatter_option( $option, $option_value );
81 warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
86 sub opt_M_with { # specify formatter class name(s)
87 my($self, $classes) = @_;
88 return unless defined $classes and length $classes;
89 DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
91 foreach my $classname (split m/[,;]+/s, $classes) {
92 next unless $classname =~ m/\S/;
93 if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
94 # A mildly restrictive concept of what modulenames are valid.
95 push @classes_to_add, $1; # untaint
97 warn "\"$classname\" isn't a valid classname. Ignoring.\n";
101 unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
104 "Adding @classes_to_add to the list of formatter classes, "
105 . "making them @{ $self->{'formatter_classes'} }.\n"
111 sub opt_V { # report version and exit
113 "Perldoc v$VERSION, under perl v$] for $^O",
115 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
116 ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
118 (chr(65) eq 'A') ? () : " (non-ASCII)",
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;
217 # the o is justified, as $package really won't change.
222 if(DEBUG) { print $out } else { print STDERR $out }
227 #..........................................................................
233 # Erase evidence of previous errors (if any), so exit status is simple.
237 perldoc [options] PageName|ModuleName|ProgramName...
238 perldoc [options] -f BuiltinFunction
239 perldoc [options] -q FAQRegex
242 -h Display this help message
244 -r Recursive search (slow)
246 -t Display pod using pod2text instead of pod2man and nroff
247 (-t is the default on win32 unless -n is specified)
248 -u Display unformatted pod text
249 -m Display module's file in its entirety
250 -n Specify replacement for nroff
251 -l Display the module's file name
252 -F Arguments are file names, not modules
253 -v Verbosely describe what's going on
254 -T Send output to STDOUT without any pager
255 -d output_filename_to_send_to
256 -o output_format_name
257 -M FormatterModuleNameToUse
258 -w formatter_option:option_value
259 -X use index if present (looks for pod.idx at $Config{archlib})
260 -q Search the text of questions (not answers) in perlfaq[1-9]
262 PageName|ModuleName...
263 is the name of a piece of documentation that you want to look at. You
264 may either give a descriptive name of the page (as in the case of
265 `perlfunc') the name of a module, either like `Term::Info' or like
266 `Term/Info', or the name of a program, like `perldoc'.
269 is the name of a perl function. Will extract documentation from
273 is a regex. Will search perlfaq[1-9] for and extract any
274 questions that match.
276 Any switches in the PERLDOC environment variable will be used before the
277 command line arguments. The optional pod index file contains a list of
278 filenames, one per line.
284 #..........................................................................
287 my $me = $0; # Editing $0 is unportable
289 $me =~ s,.*[/\\],,; # get basename
292 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
296 The -h option prints more help. Also try "perldoc perldoc" to get
297 acquainted with the system. [Perldoc v$VERSION]
302 #..........................................................................
304 sub pagers { @{ shift->{'pagers'} } }
306 #..........................................................................
308 sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
309 if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
310 else { return $_[0]{ $_[1] } }
312 #..........................................................................
313 ###########################################################################
315 # Init formatter switches, and start it off with __bindir and all that
316 # other stuff that ToMan.pm needs.
322 # Make sure creat()s are neither too much nor too little
323 eval { umask(0077) }; # doubtless someone has no mask
325 $self->{'args'} ||= \@ARGV;
326 $self->{'found'} ||= [];
327 $self->{'temp_file_list'} ||= [];
330 $self->{'target'} = undef;
332 $self->init_formatter_class_list;
334 $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
335 $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
336 $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
338 push @{ $self->{'formatter_switches'} = [] }, (
339 # Yeah, we could use a hashref, but maybe there's some class where options
340 # have to be ordered; so we'll use an arrayref.
342 [ '__bindir' => $self->{'bindir' } ],
343 [ '__pod2man' => $self->{'pod2man'} ],
346 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
347 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
352 #..........................................................................
354 sub init_formatter_class_list {
356 $self->{'formatter_classes'} ||= [];
358 # Remember, no switches have been read yet, when
359 # we've started this routine.
361 $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
362 $self->opt_o_with('text');
363 $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos || IS_Cygwin
365 ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
371 #..........................................................................
374 # if this ever returns, its retval will be used for exit(RETVAL)
377 DEBUG > 1 and print " Beginning process.\n";
378 DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
380 print "Object contents:\n";
383 $x[1] = '<undef>' unless defined $x[1];
384 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
385 print " [$x[0]] => [$x[1]]\n";
391 # TODO: make it deal with being invoked as various different things
394 return $self->usage_brief unless @{ $self->{'args'} };
395 $self->pagers_guessing;
396 $self->options_reading;
397 $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
398 $self->drop_privs_maybe;
399 $self->options_processing;
401 # Hm, we have @pages and @found, but we only really act on one
402 # file per call, with the exception of the opt_q hack, and with
408 $self->{'pages'} = \@pages;
409 if( $self->opt_f) { @pages = ("perlfunc") }
410 elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
411 else { @pages = @{$self->{'args'}};
413 # if @pages == 1 and $pages[0] eq 'perldoc';
416 return $self->usage_brief unless @pages;
418 $self->find_good_formatter_class();
419 $self->formatter_sanity_check();
421 $self->maybe_diddle_INC();
422 # for when we're apparently in a module or extension directory
424 my @found = $self->grand_search_init(\@pages);
425 exit (IS_VMS ? 98962 : 1) unless @found;
428 DEBUG and print "We're in -l mode, so byebye after this:\n";
429 print join("\n", @found), "\n";
433 $self->tweak_found_pathnames(\@found);
434 $self->assert_closing_stdout;
435 return $self->page_module_file(@found) if $self->opt_m;
436 DEBUG > 2 and print "Found: [@found]\n";
438 return $self->render_and_page(\@found);
441 #..........................................................................
444 my( %class_seen, %class_loaded );
445 sub find_good_formatter_class {
447 my @class_list = @{ $self->{'formatter_classes'} || [] };
448 die "WHAT? Nothing in the formatter class list!?" unless @class_list;
450 my $good_class_found;
451 foreach my $c (@class_list) {
452 DEBUG > 4 and print "Trying to load $c...\n";
453 if($class_loaded{$c}) {
454 DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
455 $good_class_found = $c;
459 if($class_seen{$c}) {
461 "I've tried $c before, and it's no good. Skipping.\n";
467 if( $c->can('parse_from_file') ) {
469 "Interesting, the formatter class $c is already loaded!\n";
472 (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
473 # the alway case-insensitive fs's
474 and $class_seen{lc("~$c")}++
477 "We already used something quite like \"\L$c\E\", so no point using $c\n";
478 # This avoids redefining the package.
480 DEBUG > 4 and print "Trying to eval 'require $c'...\n";
483 if(DEBUG() or $self->opt_v) {
484 # feh, let 'em see it
487 # The average user just has no reason to be seeing
488 # $^W-suppressable warnings from the require!
493 DEBUG > 4 and print "Couldn't load $c: $!\n";
498 if( $c->can('parse_from_file') ) {
499 DEBUG > 4 and print "Settling on $c\n";
501 $v = ( defined $v and length $v ) ? " version $v" : '';
502 $self->aside("Formatter class $c$v successfully loaded!\n");
503 $good_class_found = $c;
506 DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
510 die "Can't find any loadable formatter class in @class_list?!\nAborting"
511 unless $good_class_found;
513 $self->{'formatter_class'} = $good_class_found;
514 $self->aside("Will format with the class $good_class_found\n");
520 #..........................................................................
522 sub formatter_sanity_check {
524 my $formatter_class = $self->{'formatter_class'}
525 || die "NO FORMATTER CLASS YET!?";
527 if(!$self->opt_T # so -T can FORCE sending to STDOUT
528 and $formatter_class->can('is_pageable')
529 and !$formatter_class->is_pageable
530 and !$formatter_class->can('page_for_perldoc')
533 ($formatter_class->can('output_extension')
534 && $formatter_class->output_extension
536 $ext = ".$ext" if length $ext;
539 "When using Perldoc to format with $formatter_class, you have to\n"
540 . "specify -T or -dsomefile$ext\n"
541 . "See `perldoc perldoc' for more information on those switches.\n"
546 #..........................................................................
548 sub render_and_page {
549 my($self, $found_list) = @_;
551 $self->maybe_generate_dynamic_pod($found_list);
553 my($out, $formatter) = $self->render_findings($found_list);
556 printf "Perldoc (%s) output saved to %s\n",
557 $self->{'formatter_class'} || ref($self),
559 print "But notice that it's 0 bytes long!\n" unless -s $out;
562 } elsif( # Allow the formatter to "page" itself, if it wants.
563 $formatter->can('page_for_perldoc')
565 $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
566 if( $formatter->page_for_perldoc($out, $self) ) {
567 $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
570 $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
575 # Do nothing, since the formatter has "paged" it for itself.
578 # Page it normally (internally)
580 if( -s $out ) { # Usual case:
581 $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
585 $self->aside("Skipping $out (from $$found_list[0] "
586 . "via $$self{'formatter_class'}) as it is 0-length.\n");
588 push @{ $self->{'temp_file_list'} }, $out;
589 $self->unlink_if_temp_file($out);
593 $self->after_rendering(); # any extra cleanup or whatever
598 #..........................................................................
600 sub options_reading {
603 if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
604 require Text::ParseWords;
605 $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
606 # Yes, appends to the beginning
607 unshift @{ $self->{'args'} },
608 Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
610 DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
612 DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
616 and print " Args right before switch processing: @{$self->{'args'}}\n";
618 Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
619 or return $self->usage;
622 and print " Args after switch processing: @{$self->{'args'}}\n";
624 return $self->usage if $self->opt_h;
629 #..........................................................................
631 sub options_processing {
635 my $podidx = "$Config{'archlib'}/pod.idx";
636 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
637 $self->{'podidx'} = $podidx;
640 $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
642 $self->options_sanity;
644 $self->opt_n("nroff") unless $self->opt_n;
645 $self->add_formatter_option( '__nroffer' => $self->opt_n );
650 #..........................................................................
655 # The opts-counting stuff interacts quite badly with
656 # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
657 # set to -t, and I specify -u on the command line, I don't want
658 # to be hectored at that -u and -t don't make sense together.
660 #my $opts = grep $_ && 1, # yes, the count of the set ones
661 # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
664 #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
667 # Any sanity-checking need doing here?
672 #..........................................................................
674 sub grand_search_init {
675 my($self, $pages, @found) = @_;
678 if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
679 my $searchfor = catfile split '::', $_;
680 $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
684 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
686 close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
690 $self->aside( "Searching for $_\n" );
694 push @found, $_ if $self->opt_m or $self->containspod($_);
698 # We must look both in @INC for library modules and in $bindir
699 # for executables, like h2xs or perldoc itself.
701 my @searchdirs = ($self->{'bindir'}, @INC);
702 unless ($self->opt_m) {
705 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
706 push(@searchdirs,$trn);
708 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
711 push(@searchdirs, grep(-d, split($Config{path_sep},
715 my @files = $self->searchfor(0,$_,@searchdirs);
717 $self->aside( "Found as @files\n" );
720 # no match, try recursive search
721 @searchdirs = grep(!/^\.\z/s,@INC);
722 @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
724 $self->aside( "Loosely found as @files\n" );
728 ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
729 if ( @{ $self->{'found'} } ) {
730 print STDERR "However, try\n";
731 for my $dir (@{ $self->{'found'} }) {
732 opendir(DIR, $dir) or die "opendir $dir: $!";
733 while (my $file = readdir(DIR)) {
734 next if ($file =~ /^\./s);
735 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
736 print STDERR "\tperldoc $_\::$file\n";
738 closedir(DIR) or die "closedir $dir: $!";
748 #..........................................................................
750 sub maybe_generate_dynamic_pod {
751 my($self, $found_things) = @_;
754 $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
756 $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
758 if( ! $self->opt_f and ! $self->opt_q ) {
759 DEBUG > 4 and print "That's a non-dynamic pod search.\n";
760 } elsif ( @dynamic_pod ) {
761 $self->aside("Hm, I found some Pod from that search!\n");
762 my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
764 push @{ $self->{'temp_file_list'} }, $buffer;
765 # I.e., it MIGHT be deleted at the end.
767 print $buffd "=over 8\n\n";
768 print $buffd @dynamic_pod or die "Can't print $buffer: $!";
769 print $buffd "=back\n";
770 close $buffd or die "Can't close $buffer: $!";
772 @$found_things = $buffer;
773 # Yes, so found_things never has more than one thing in
774 # it, by time we leave here
776 $self->add_formatter_option('__filter_nroff' => 1);
780 $self->aside("I found no Pod from that search!\n");
786 #..........................................................................
788 sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
790 push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
792 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
793 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
798 #..........................................................................
800 sub search_perlfunc {
801 my($self, $found_things, $pod) = @_;
803 DEBUG > 2 and print "Search: @$found_things\n";
805 my $perlfunc = shift @$found_things;
806 open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
807 or die("Can't open $perlfunc: $!");
809 # Functions like -r, -e, etc. are listed under `-X'.
810 my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
811 ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
814 print "Going to perlfunc-scan for $search_re in $perlfunc\n";
819 last if /^=head2 Alphabetical Listing of Perl Functions/;
822 # Look for our function
825 while (<PFUNC>) { # "The Mothership Connection is here!"
826 if ( m/^=item\s+$search_re\b/ ) {
830 last if $found > 1 and not $inlist;
840 ++$found if /^\w/; # found descriptive text
844 "No documentation for perl function `%s' found\n",
848 close PFUNC or die "Can't open $perlfunc: $!";
853 #..........................................................................
855 sub search_perlfaqs {
856 my( $self, $found_things, $pod) = @_;
860 my $search_key = $self->opt_q;
862 my $rx = eval { qr/$search_key/ }
864 Invalid regular expression '$search_key' given as -q pattern:
866 Did you mean \\Q$search_key ?
871 foreach my $file (@$found_things) {
872 die "invalid file spec: $!" if $file =~ /[<>|]/;
873 open(INFAQ, "<", $file) # XXX 5.6ism
874 or die "Can't read-open $file: $!\nAborting";
876 if ( m/^=head2\s+.*(?:$search_key)/i ) {
878 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
880 elsif (/^=head[12]/) {
888 die("No documentation for perl FAQ keyword `$search_key' found\n")
895 #..........................................................................
897 sub render_findings {
898 # Return the filename to open
900 my($self, $found_things) = @_;
902 my $formatter_class = $self->{'formatter_class'}
903 || die "No formatter class set!?";
904 my $formatter = $formatter_class->can('new')
905 ? $formatter_class->new
909 if(! @$found_things) {
910 die "Nothing found?!";
911 # should have been caught before here
912 } elsif(@$found_things > 1) {
914 "Perldoc is only really meant for reading one document at a time.\n",
915 "So these parameters are being ignored: ",
916 join(' ', @$found_things[1 .. $#$found_things] ),
920 my $file = $found_things->[0];
922 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
923 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
925 # Set formatter options:
926 if( ref $formatter ) {
927 foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
928 my($switch, $value, $silent_fail) = @$f;
929 if( $formatter->can($switch) ) {
930 eval { $formatter->$switch( defined($value) ? $value : () ) };
931 warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
934 if( $silent_fail or $switch =~ m/^__/s ) {
935 DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
937 warn "$formatter_class doesn't recognize the $switch switch.\n";
943 $self->{'output_is_binary'} =
944 $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
946 my ($out_fh, $out) = $self->new_output_file(
947 ( $formatter->can('output_extension') && $formatter->output_extension )
949 $self->useful_filename_bit,
952 # Now, finally, do the formatting!
955 if(DEBUG() or $self->opt_v) {
956 # feh, let 'em see it
959 # The average user just has no reason to be seeing
960 # $^W-suppressable warnings from the formatting!
963 eval { $formatter->parse_from_file( $file, $out_fh ) };
966 warn "Error while formatting with $formatter_class:\n $@\n" if $@;
967 DEBUG > 2 and print "Back from formatting with $formatter_class\n";
970 or warn "Can't close $out: $!\n(Did $formatter already close it?)";
971 sleep 0; sleep 0; sleep 0;
972 # Give the system a few timeslices to meditate on the fact
973 # that the output file does in fact exist and is closed.
975 $self->unlink_if_temp_file($file);
978 if( $formatter->can( 'if_zero_length' ) ) {
979 # Basically this is just a hook for Pod::Simple::Checker; since
980 # what other class could /happily/ format an input file with Pod
981 # as a 0-length output file?
982 $formatter->if_zero_length( $file, $out, $out_fh );
984 warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
988 DEBUG and print "Finished writing to $out.\n";
989 return($out, $formatter) if wantarray;
993 #..........................................................................
995 sub unlink_if_temp_file {
996 # Unlink the specified file IFF it's in the list of temp files.
997 # Really only used in the case of -f / -q things when we can
998 # throw away the dynamically generated source pod file once
999 # we've formatted it.
1001 my($self, $file) = @_;
1002 return unless defined $file and length $file;
1004 my $temp_file_list = $self->{'temp_file_list'} || return;
1005 if(grep $_ eq $file, @$temp_file_list) {
1006 $self->aside("Unlinking $file\n");
1007 unlink($file) or warn "Odd, couldn't unlink $file: $!";
1009 DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1014 #..........................................................................
1016 sub MSWin_temp_cleanup {
1018 # Nothing particularly MSWin-specific in here, but I don't know if any
1019 # other OS needs its temp dir policed like MSWin does!
1023 my $tempdir = $ENV{'TEMP'};
1024 return unless defined $tempdir and length $tempdir
1025 and -e $tempdir and -d _ and -w _;
1028 "Considering whether any old files of mine in $tempdir need unlinking.\n"
1031 opendir(TMPDIR, $tempdir) || return;
1034 my $limit = time() - $Temp_File_Lifetime;
1036 DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
1041 while(defined($filespec = readdir(TMPDIR))) {
1043 $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
1045 if( hex($1) < $limit ) {
1046 push @to_unlink, "$tempdir/$filespec";
1047 $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
1050 printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
1054 print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
1058 $self->aside(sprintf "Unlinked %s items of mine in %s\n",
1059 scalar(unlink(@to_unlink)),
1065 # . . . . . . . . . . . . . . . . . . . . . . . . .
1067 sub MSWin_perldoc_tempfile {
1068 my($self, $suffix, $infix) = @_;
1070 my $tempdir = $ENV{'TEMP'};
1071 return unless defined $tempdir and length $tempdir
1072 and -e $tempdir and -d _ and -w _;
1077 $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
1078 # Yes, we embed the create-time in the filename!
1083 defined( &Win32::GetTickCount )
1084 ? (Win32::GetTickCount() & 0xff)
1086 # Under MSWin, $$ values get reused quickly! So if we ran
1087 # perldoc foo and then perldoc bar before there was time for
1088 # time() to increment time."_$$" would likely be the same
1089 # for each process! So we tack on the tick count's lower
1090 # bits (or, in a pinch, rand)
1094 } while( -e $spec );
1098 while($counter < 50) {
1100 # If we are running before perl5.6.0, we can't autovivify
1103 $fh = Symbol::gensym();
1105 DEBUG > 3 and print "About to try making temp file $spec\n";
1106 return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
1107 $self->aside("Can't create temp file $spec: $!\n");
1110 $self->aside("Giving up on making a temp file!\n");
1111 die "Can't make a tempfile!?";
1114 #..........................................................................
1117 sub after_rendering {
1119 $self->after_rendering_VMS if IS_VMS;
1120 $self->after_rendering_MSWin32 if IS_MSWin32;
1121 $self->after_rendering_Dos if IS_Dos;
1122 $self->after_rendering_OS2 if IS_OS2;
1126 sub after_rendering_VMS { return }
1127 sub after_rendering_Dos { return }
1128 sub after_rendering_OS2 { return }
1130 sub after_rendering_MSWin32 {
1131 shift->MSWin_temp_cleanup() if $Temp_Files_Created;
1134 #..........................................................................
1136 #..........................................................................
1139 sub minus_f_nocase { # i.e., do like -f, but without regard to case
1141 my($self, $dir, $file) = @_;
1142 my $path = catfile($dir,$file);
1143 return $path if -f $path and -r _;
1146 or IS_VMS or IS_MSWin32
1149 # On a case-forgiving file system, or if case is important,
1150 # that is it, all we can do.
1151 warn "Ignored $path: unreadable\n" if -f _;
1158 foreach $p (splitdir $file){
1159 my $try = catfile @p, $p;
1160 $self->aside("Scrutinizing $try...\n");
1164 if ( $p eq $self->{'target'} ) {
1165 my $tmp_path = catfile @p;
1167 for (@{ $self->{'found'} }) {
1168 $path_f = 1 if $_ eq $tmp_path;
1170 push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1171 $self->aside( "Found as $tmp_path but directory\n" );
1174 elsif (-f _ && -r _) {
1178 warn "Ignored $try: unreadable\n";
1180 elsif (-d catdir(@p)) { # at least we see the containing directory!
1183 my $p_dirspec = catdir(@p);
1184 opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
1185 while(defined( $cip = readdir(DIR) )) {
1186 if (lc $cip eq $lcp){
1188 last; # XXX stop at the first? what if there's others?
1191 closedir DIR or die "closedir $p_dirspec: $!";
1192 return "" unless $found;
1195 my $p_filespec = catfile(@p);
1196 return $p_filespec if -f $p_filespec and -r _;
1197 warn "Ignored $p_filespec: unreadable\n" if -f _;
1203 #..........................................................................
1205 sub pagers_guessing {
1209 push @pagers, $self->pagers;
1210 $self->{'pagers'} = \@pagers;
1213 push @pagers, qw( more< less notepad );
1214 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1217 push @pagers, qw( most more less type/page );
1220 push @pagers, qw( less.exe more.com< );
1221 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1225 unshift @pagers, 'less', 'cmd /c more <';
1227 push @pagers, qw( more less pg view cat );
1228 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1230 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
1235 #..........................................................................
1237 sub page_module_file {
1238 my($self, @found) = @_;
1241 # Don't ever just pass this off to anything like MSWin's "start.exe",
1242 # since we might be calling on a .pl file, and we wouldn't want that
1243 # to actually /execute/ the file that we just want to page thru!
1244 # Also a consideration if one were to use a web browser as a pager;
1245 # doing so could trigger the browser's MIME mapping for whatever
1246 # it thinks .pm/.pl/whatever is. Probably just a (useless and
1247 # annoying) "Save as..." dialog, but potentially executing the file
1248 # in question -- particularly in the case of MSIE and it's, ahem,
1249 # occasionally hazy distinction between OS-local extension
1250 # associations, and browser-specific MIME mappings.
1252 if ($self->{'output_to_stdout'}) {
1253 $self->aside("Sending unpaged output to STDOUT.\n");
1256 foreach my $output (@found) {
1257 unless( open(TMP, "<", $output) ) { # XXX 5.6ism
1258 warn("Can't open $output: $!");
1263 print or die "Can't print to stdout: $!";
1265 close TMP or die "Can't close while $output: $!";
1266 $self->unlink_if_temp_file($output);
1268 return $any_error; # successful
1271 foreach my $pager ( $self->pagers ) {
1272 $self->aside("About to try calling $pager @found\n");
1273 if (system($pager, @found) == 0) {
1274 $self->aside("Yay, it worked.\n");
1277 $self->aside("That didn't work.\n");
1279 # Odd -- when it fails, under Win32, this seems to neither
1280 # return with a fail nor return with a success!!
1281 # That's discouraging!
1285 sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
1287 join(' ', $self->pagers),
1291 DEBUG > 1 and print "Bailing out in a VMSish way.\n";
1293 use vmsish qw(status exit);
1300 # i.e., an UNSUCCESSFUL return value!
1303 #..........................................................................
1306 my($self, $dir, $file) = @_;
1308 unless( ref $self ) {
1309 # Should never get called:
1311 Carp::croak join '',
1312 "Crazy ", __PACKAGE__, " error:\n",
1313 "check_file must be an object_method!\n",
1317 if(length $dir and not -d $dir) {
1318 DEBUG > 3 and print " No dir $dir -- skipping.\n";
1323 return $self->minus_f_nocase($dir,$file);
1327 my $path = $self->minus_f_nocase($dir,$file);
1328 if( length $path and $self->containspod($path) ) {
1330 " The file $path indeed looks promising!\n";
1334 DEBUG > 3 and print " No good: $file in $dir\n";
1339 #..........................................................................
1342 my($self, $file, $readit) = @_;
1343 return 1 if !$readit && $file =~ /\.pod\z/i;
1345 open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
1348 close(TEST) or die "Can't close $file: $!";
1352 close(TEST) or die "Can't close $file: $!";
1356 #..........................................................................
1358 sub maybe_diddle_INC {
1361 # Does this look like a module or extension directory?
1363 if (-f "Makefile.PL") {
1365 # Add "." and "lib" to @INC (if they exist)
1366 eval q{ use lib qw(. lib); 1; } or die;
1368 # don't add if superuser
1369 if ($< && $> && -f "blib") { # don't be looking too hard now!
1370 eval q{ use blib; 1 };
1371 warn $@ if $@ && $self->opt_v;
1378 #..........................................................................
1380 sub new_output_file {
1382 my $outspec = $self->opt_d; # Yes, -d overrides all else!
1383 # So don't call this twice per format-job!
1385 return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1387 # Otherwise open a write-handle on opt_d!f
1390 # If we are running before perl5.6.0, we can't autovivify
1393 $fh = Symbol::gensym();
1395 DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1396 die "Can't write-open $outspec: $!"
1397 unless open($fh, ">", $outspec); # XXX 5.6ism
1399 DEBUG > 3 and print "Successfully opened $outspec\n";
1400 binmode($fh) if $self->{'output_is_binary'};
1401 return($fh, $outspec);
1404 #..........................................................................
1406 sub useful_filename_bit {
1407 # This tries to provide a meaningful bit of text to do with the query,
1408 # such as can be used in naming the file -- since if we're going to be
1409 # opening windows on temp files (as a "pager" may well do!) then it's
1410 # better if the temp file's name (which may well be used as the window
1411 # title) isn't ALL just random garbage!
1412 # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1413 # name than "perldoc_2371981429". So this routine is what tries to
1414 # provide the "LWPSimple" bit.
1417 my $pages = $self->{'pages'} || return undef;
1418 return undef unless @$pages;
1420 my $chunk = $pages->[0];
1421 return undef unless defined $chunk;
1423 $chunk =~ s/\.\w+$//g; # strip any extension
1424 if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1429 $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1430 $chunk = substr($chunk, -10) if length($chunk) > 10;
1434 #..........................................................................
1436 sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
1439 ++$Temp_Files_Created;
1442 my @out = $self->MSWin_perldoc_tempfile(@_);
1443 return @out if @out;
1444 # otherwise fall thru to the normal stuff below...
1448 return File::Temp::tempfile(UNLINK => 1);
1451 #..........................................................................
1453 sub page { # apply a pager to the output file
1454 my ($self, $output, $output_to_stdout, @pagers) = @_;
1455 if ($output_to_stdout) {
1456 $self->aside("Sending unpaged output to STDOUT.\n");
1457 open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
1460 print or die "Can't print to stdout: $!";
1462 close TMP or die "Can't close while $output: $!";
1463 $self->unlink_if_temp_file($output);
1465 # On VMS, quoting prevents logical expansion, and temp files with no
1466 # extension get the wrong default extension (such as .LIS for TYPE)
1468 $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
1469 foreach my $pager (@pagers) {
1470 $self->aside("About to try calling $pager $output\n");
1472 last if system("$pager $output") == 0;
1474 last if system("$pager \"$output\"") == 0;
1481 #..........................................................................
1484 my($self, $recurse,$s,@dirs) = @_;
1486 $s = VMS::Filespec::unixify($s) if IS_VMS;
1487 return $s if -f $s && $self->containspod($s);
1488 $self->aside( "Looking for $s in @dirs\n" );
1492 $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
1493 for ($i=0; $i<@dirs; $i++) {
1495 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
1496 if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1497 or ( $ret = $self->check_file($dir,"$s.pm"))
1498 or ( $ret = $self->check_file($dir,$s))
1500 $ret = $self->check_file($dir,"$s.com"))
1502 $ret = $self->check_file($dir,"$s.cmd"))
1503 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
1504 $ret = $self->check_file($dir,"$s.bat"))
1505 or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1506 or ( $ret = $self->check_file("$dir/pod",$s))
1507 or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1508 or ( $ret = $self->check_file("$dir/pods",$s))
1510 DEBUG > 1 and print " Found $ret\n";
1515 opendir(D,$dir) or die "Can't opendir $dir: $!";
1516 my @newdirs = map catfile($dir, $_), grep {
1518 not /^auto\z/s and # save time! don't search auto dirs
1519 -d catfile($dir, $_)
1521 closedir(D) or die "Can't closedir $dir: $!";
1522 next unless @newdirs;
1523 # what a wicked map!
1524 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
1525 $self->aside( "Also looking in @newdirs\n" );
1526 push(@dirs,@newdirs);
1532 #..........................................................................
1534 my $already_asserted;
1535 sub assert_closing_stdout {
1538 return if $already_asserted;
1540 eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
1541 # What for? to let the pager know that nothing more will come?
1544 $already_asserted = 1;
1549 #..........................................................................
1551 sub tweak_found_pathnames {
1552 my($self, $found) = @_;
1554 foreach (@$found) { s,/,\\,g }
1559 #..........................................................................
1561 #..........................................................................
1563 sub am_taint_checking {
1565 die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
1566 my($k,$v) = each %ENV;
1567 return is_tainted($v);
1570 #..........................................................................
1572 sub is_tainted { # just a function
1574 my $nada = substr($arg, 0, 0); # zero-length!
1575 local $@; # preserve the caller's version of $@
1576 eval { eval "# $nada" };
1577 return length($@) != 0;
1580 #..........................................................................
1582 sub drop_privs_maybe {
1585 # Attempt to drop privs if we should be tainting and aren't
1586 if (!(IS_VMS || IS_MSWin32 || IS_Dos
1589 && ($> == 0 || $< == 0)
1590 && !$self->am_taint_checking()
1592 my $id = eval { getpwnam("nobody") };
1593 $id = eval { getpwnam("nouser") } unless defined $id;
1594 $id = -2 unless defined $id;
1596 # According to Stevens' APUE and various
1597 # (BSD, Solaris, HP-UX) man pages, setting
1598 # the real uid first and effective uid second
1599 # is the way to go if one wants to drop privileges,
1600 # because if one changes into an effective uid of
1601 # non-zero, one cannot change the real uid any more.
1603 # Actually, it gets even messier. There is
1604 # a third uid, called the saved uid, and as
1605 # long as that is zero, one can get back to
1606 # uid of zero. Setting the real-effective *twice*
1607 # helps in *most* systems (FreeBSD and Solaris)
1608 # but apparently in HP-UX even this doesn't help:
1609 # the saved uid stays zero (apparently the only way
1610 # in HP-UX to change saved uid is to call setuid()
1611 # when the effective uid is zero).
1614 $< = $id; # real uid
1615 $> = $id; # effective uid
1616 $< = $id; # real uid
1617 $> = $id; # effective uid
1619 if( !$@ && $< && $> ) {
1620 DEBUG and print "OK, I dropped privileges.\n";
1621 } elsif( $self->opt_U ) {
1622 DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
1624 DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
1625 # We used to die here; but that seemed pointless.
1631 #..........................................................................
1637 # See "perldoc perldoc" for basic details.
1639 # Perldoc -- look up a piece of documentation in .pod format that
1640 # is embedded in the perl installation tree.
1644 # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
1646 # Version 3.01: Sun Nov 10 21:38:09 MST 2002
1647 # Sean M. Burke <sburke@cpan.org>
1648 # Massive refactoring and code-tidying.
1649 # Now it's a module(-family)!
1650 # Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
1651 # Added -T, -d, -o, -M, -w.
1652 # Added some improved MSWin funk.
1656 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
1657 # Hugo van der Sanden <hv@crypt.org>
1658 # Made -U the default, based on patch from Simon Cozens
1659 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
1660 # Randy W. Sims <RandyS@ThePierianSpring.org>
1661 # allow -n to enable nroff under Win32
1662 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
1663 # Hugo van der Sanden <hv@crypt.org>
1664 # don't die when 'use blib' fails
1665 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
1666 # Tom Christiansen <tchrist@perl.com>
1667 # Added -U insecurity option
1668 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
1669 # Tom Christiansen <tchrist@perl.com>, querulously.
1670 # Security and correctness patches.
1671 # What a twisted bit of distasteful spaghetti code.
1676 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
1677 # Charles Wilson <cwilson@ece.gatech.edu>
1678 # changed /pod/ directory to /pods/ for cygwin
1679 # to support cygwin/win32
1680 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
1681 # Robin Barker <rmb1@cise.npl.co.uk>
1682 # -strict, -w cleanups
1683 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
1684 # Gurusamy Sarathy <gsar@activestate.com>
1685 # -doc tweaks for -F and -X options
1686 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
1687 # Gurusamy Sarathy <gsar@activestate.com>
1688 # -various fixes for win32
1689 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
1690 # Kenneth Albanowski <kjahds@kjahds.com>
1691 # -added Charles Bailey's further VMS patches, and -u switch
1692 # -added -t switch, with pod2text support
1694 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
1695 # Kenneth Albanowski <kjahds@kjahds.com>
1696 # -added VMS support
1697 # -added better error recognition (on no found pages, just exit. On
1698 # missing nroff/pod2man, just display raw pod.)
1699 # -added recursive/case-insensitive matching (thanks, Andreas). This
1700 # slows things down a bit, unfortunately. Give a precise name, and
1703 # Version 1.01: Tue May 30 14:47:34 EDT 1995
1704 # Andy Dougherty <doughera@lafayette.edu>
1705 # -added pod documentation.
1706 # -added PATH searching.
1707 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
1714 # Cache the directories read during sloppy match
1715 # (To disk, or just in-memory?)
1717 # Backport this to perl 5.005?
1719 # Implement at least part of the "perlman" interface described
1720 # in Programming Perl 3e?