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;
42 *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
43 *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
46 $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
47 # If it's older than five days, it's quite unlikely
48 # that anyone's still looking at it!!
49 # (Currently used only by the MSWin cleanup routine)
52 #..........................................................................
53 { my $pager = $Config{'pager'};
54 push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
56 $Bindir = $Config{'scriptdirexp'};
57 $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
59 # End of class-init stuff
61 ###########################################################################
65 foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) {
67 *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
70 # And these are so that GetOptsOO knows they take options:
71 sub opt_f_with { shift->_elem('opt_f', @_) }
72 sub opt_q_with { shift->_elem('opt_q', @_) }
73 sub opt_d_with { shift->_elem('opt_d', @_) }
75 sub opt_w_with { # Specify an option for the formatter subclass
76 my($self, $value) = @_;
77 if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
79 my $option_value = defined($2) ? $2 : "TRUE";
80 $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
81 $self->add_formatter_option( $option, $option_value );
83 warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
88 sub opt_M_with { # specify formatter class name(s)
89 my($self, $classes) = @_;
90 return unless defined $classes and length $classes;
91 DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
93 foreach my $classname (split m/[,;]+/s, $classes) {
94 next unless $classname =~ m/\S/;
95 if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
96 # A mildly restrictive concept of what modulenames are valid.
97 push @classes_to_add, $1; # untaint
99 warn "\"$classname\" isn't a valid classname. Ignoring.\n";
103 unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
106 "Adding @classes_to_add to the list of formatter classes, "
107 . "making them @{ $self->{'formatter_classes'} }.\n"
113 sub opt_V { # report version and exit
115 "Perldoc v$VERSION, under perl v$] for $^O",
117 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
118 ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
120 (chr(65) eq 'A') ? () : " (non-ASCII)",
127 sub opt_t { # choose plaintext as output format
129 $self->opt_o_with('text') if @_ and $_[0];
130 return $self->_elem('opt_t', @_);
133 sub opt_u { # choose raw pod as output format
135 $self->opt_o_with('pod') if @_ and $_[0];
136 return $self->_elem('opt_u', @_);
140 # choose man as the output format, and specify the proggy to run
142 $self->opt_o_with('man') if @_ and $_[0];
143 $self->_elem('opt_n', @_);
146 sub opt_o_with { # "o" for output format
147 my($self, $rest) = @_;
148 return unless defined $rest and length $rest;
149 if($rest =~ m/^(\w+)$/s) {
152 warn "\"$rest\" isn't a valid output format. Skipping.\n";
156 $self->aside("Noting \"$rest\" as desired output format...\n");
158 # Figure out what class(es) that could actually mean...
161 foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
164 $rest, # Yes, try it first with the given capitalization
165 "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
168 push @classes, $prefix . $stem;
169 #print "Considering $prefix$stem\n";
172 # Tidier, but misses too much:
173 #push @classes, $prefix . ucfirst(lc($rest));
175 $self->opt_M_with( join ";", @classes );
179 ###########################################################################
180 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
182 sub run { # to be called by the "perldoc" executable
185 print "Parameters to $class\->run:\n";
188 $x[1] = '<undef>' unless defined $x[1];
189 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
190 print " [$x[0]] => [$x[1]]\n";
195 return $class -> new(@_) -> process() || 0;
198 # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
199 ###########################################################################
201 sub new { # yeah, nothing fancy
203 my $new = bless {@_}, (ref($class) || $class);
204 DEBUG > 1 and print "New $class object $new\n";
209 #..........................................................................
211 sub aside { # If we're in -v or DEBUG mode, say this.
213 if( DEBUG or $self->opt_v ) {
216 my $callsub = (caller(1))[3];
217 my $package = quotemeta(__PACKAGE__ . '::');
218 $callsub =~ s/^$package/'/os;
219 # the o is justified, as $package really won't change.
224 if(DEBUG) { print $out } else { print STDERR $out }
229 #..........................................................................
235 # Erase evidence of previous errors (if any), so exit status is simple.
239 perldoc [options] PageName|ModuleName|ProgramName...
240 perldoc [options] -f BuiltinFunction
241 perldoc [options] -q FAQRegex
244 -h Display this help message
246 -r Recursive search (slow)
248 -t Display pod using pod2text instead of pod2man and nroff
249 (-t is the default on win32 unless -n is specified)
250 -u Display unformatted pod text
251 -m Display module's file in its entirety
252 -n Specify replacement for nroff
253 -l Display the module's file name
254 -F Arguments are file names, not modules
255 -v Verbosely describe what's going on
256 -T Send output to STDOUT without any pager
257 -d output_filename_to_send_to
258 -o output_format_name
259 -M FormatterModuleNameToUse
260 -w formatter_option:option_value
261 -X use index if present (looks for pod.idx at $Config{archlib})
262 -q Search the text of questions (not answers) in perlfaq[1-9]
264 PageName|ModuleName...
265 is the name of a piece of documentation that you want to look at. You
266 may either give a descriptive name of the page (as in the case of
267 `perlfunc') the name of a module, either like `Term::Info' or like
268 `Term/Info', or the name of a program, like `perldoc'.
271 is the name of a perl function. Will extract documentation from
275 is a regex. Will search perlfaq[1-9] for and extract any
276 questions that match.
278 Any switches in the PERLDOC environment variable will be used before the
279 command line arguments. The optional pod index file contains a list of
280 filenames, one per line.
286 #..........................................................................
289 my $me = $0; # Editing $0 is unportable
291 $me =~ s,.*[/\\],,; # get basename
294 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
298 The -h option prints more help. Also try "perldoc perldoc" to get
299 acquainted with the system. [Perldoc v$VERSION]
304 #..........................................................................
306 sub pagers { @{ shift->{'pagers'} } }
308 #..........................................................................
310 sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
311 if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
312 else { return $_[0]{ $_[1] } }
314 #..........................................................................
315 ###########################################################################
317 # Init formatter switches, and start it off with __bindir and all that
318 # other stuff that ToMan.pm needs.
324 # Make sure creat()s are neither too much nor too little
325 eval { umask(0077) }; # doubtless someone has no mask
327 $self->{'args'} ||= \@ARGV;
328 $self->{'found'} ||= [];
329 $self->{'temp_file_list'} ||= [];
332 $self->{'target'} = undef;
334 $self->init_formatter_class_list;
336 $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
337 $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
338 $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
340 push @{ $self->{'formatter_switches'} = [] }, (
341 # Yeah, we could use a hashref, but maybe there's some class where options
342 # have to be ordered; so we'll use an arrayref.
344 [ '__bindir' => $self->{'bindir' } ],
345 [ '__pod2man' => $self->{'pod2man'} ],
348 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
349 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
354 #..........................................................................
356 sub init_formatter_class_list {
358 $self->{'formatter_classes'} ||= [];
360 # Remember, no switches have been read yet, when
361 # we've started this routine.
363 $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
364 $self->opt_o_with('text');
365 $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
367 ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
373 #..........................................................................
376 # if this ever returns, its retval will be used for exit(RETVAL)
379 DEBUG > 1 and print " Beginning process.\n";
380 DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
382 print "Object contents:\n";
385 $x[1] = '<undef>' unless defined $x[1];
386 $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
387 print " [$x[0]] => [$x[1]]\n";
393 # TODO: make it deal with being invoked as various different things
396 return $self->usage_brief unless @{ $self->{'args'} };
397 $self->pagers_guessing;
398 $self->options_reading;
399 $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
400 $self->drop_privs_maybe;
401 $self->options_processing;
403 # Hm, we have @pages and @found, but we only really act on one
404 # file per call, with the exception of the opt_q hack, and with
410 $self->{'pages'} = \@pages;
411 if( $self->opt_f) { @pages = ("perlfunc") }
412 elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
413 else { @pages = @{$self->{'args'}};
415 # if @pages == 1 and $pages[0] eq 'perldoc';
418 return $self->usage_brief unless @pages;
420 $self->find_good_formatter_class();
421 $self->formatter_sanity_check();
423 $self->maybe_diddle_INC();
424 # for when we're apparently in a module or extension directory
426 my @found = $self->grand_search_init(\@pages);
427 exit (IS_VMS ? 98962 : 1) unless @found;
430 DEBUG and print "We're in -l mode, so byebye after this:\n";
431 print join("\n", @found), "\n";
435 $self->tweak_found_pathnames(\@found);
436 $self->assert_closing_stdout;
437 return $self->page_module_file(@found) if $self->opt_m;
438 DEBUG > 2 and print "Found: [@found]\n";
440 return $self->render_and_page(\@found);
443 #..........................................................................
446 my( %class_seen, %class_loaded );
447 sub find_good_formatter_class {
449 my @class_list = @{ $self->{'formatter_classes'} || [] };
450 die "WHAT? Nothing in the formatter class list!?" unless @class_list;
452 my $good_class_found;
453 foreach my $c (@class_list) {
454 DEBUG > 4 and print "Trying to load $c...\n";
455 if($class_loaded{$c}) {
456 DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
457 $good_class_found = $c;
461 if($class_seen{$c}) {
463 "I've tried $c before, and it's no good. Skipping.\n";
469 if( $c->can('parse_from_file') ) {
471 "Interesting, the formatter class $c is already loaded!\n";
474 (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
475 # the alway case-insensitive fs's
476 and $class_seen{lc("~$c")}++
479 "We already used something quite like \"\L$c\E\", so no point using $c\n";
480 # This avoids redefining the package.
482 DEBUG > 4 and print "Trying to eval 'require $c'...\n";
485 if(DEBUG() or $self->opt_v) {
486 # feh, let 'em see it
489 # The average user just has no reason to be seeing
490 # $^W-suppressable warnings from the the require!
495 DEBUG > 4 and print "Couldn't load $c: $!\n";
500 if( $c->can('parse_from_file') ) {
501 DEBUG > 4 and print "Settling on $c\n";
503 $v = ( defined $v and length $v ) ? " version $v" : '';
504 $self->aside("Formatter class $c$v successfully loaded!\n");
505 $good_class_found = $c;
508 DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
512 die "Can't find any loadable formatter class in @class_list?!\nAborting"
513 unless $good_class_found;
515 $self->{'formatter_class'} = $good_class_found;
516 $self->aside("Will format with the class $good_class_found\n");
522 #..........................................................................
524 sub formatter_sanity_check {
526 my $formatter_class = $self->{'formatter_class'}
527 || die "NO FORMATTER CLASS YET!?";
529 if(!$self->opt_T # so -T can FORCE sending to STDOUT
530 and $formatter_class->can('is_pageable')
531 and !$formatter_class->is_pageable
532 and !$formatter_class->can('page_for_perldoc')
535 ($formatter_class->can('output_extension')
536 && $formatter_class->output_extension
538 $ext = ".$ext" if length $ext;
541 "When using Perldoc to format with $formatter_class, you have to\n"
542 . "specify -T or -dsomefile$ext\n"
543 . "See `perldoc perldoc' for more information on those switches.\n"
548 #..........................................................................
550 sub render_and_page {
551 my($self, $found_list) = @_;
553 $self->maybe_generate_dynamic_pod($found_list);
555 my($out, $formatter) = $self->render_findings($found_list);
558 printf "Perldoc (%s) output saved to %s\n",
559 $self->{'formatter_class'} || ref($self),
561 print "But notice that it's 0 bytes long!\n" unless -s $out;
564 } elsif( # Allow the formatter to "page" itself, if it wants.
565 $formatter->can('page_for_perldoc')
567 $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
568 if( $formatter->page_for_perldoc($out, $self) ) {
569 $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
572 $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
577 # Do nothing, since the formatter has "paged" it for itself.
580 # Page it normally (internally)
582 if( -s $out ) { # Usual case:
583 $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
587 $self->aside("Skipping $out (from $$found_list[0] "
588 . "via $$self{'formatter_class'}) as it is 0-length.\n");
590 push @{ $self->{'temp_file_list'} }, $out;
591 $self->unlink_if_temp_file($out);
595 $self->after_rendering(); # any extra cleanup or whatever
600 #..........................................................................
602 sub options_reading {
605 if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
606 require Text::ParseWords;
607 $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
608 # Yes, appends to the beginning
609 unshift @{ $self->{'args'} },
610 Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
612 DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
614 DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
618 and print " Args right before switch processing: @{$self->{'args'}}\n";
620 Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
621 or return $self->usage;
624 and print " Args after switch processing: @{$self->{'args'}}\n";
626 return $self->usage if $self->opt_h;
631 #..........................................................................
633 sub options_processing {
637 my $podidx = "$Config{'archlib'}/pod.idx";
638 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
639 $self->{'podidx'} = $podidx;
642 $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
644 $self->options_sanity;
646 $self->opt_n("nroff") unless $self->opt_n;
647 $self->add_formatter_option( '__nroffer' => $self->opt_n );
652 #..........................................................................
657 # The opts-counting stuff interacts quite badly with
658 # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
659 # set to -t, and I specify -u on the command line, I don't want
660 # to be hectored at that -u and -t don't make sense together.
662 #my $opts = grep $_ && 1, # yes, the count of the set ones
663 # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
666 #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
669 # Any sanity-checking need doing here?
674 #..........................................................................
676 sub grand_search_init {
677 my($self, $pages, @found) = @_;
680 if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
681 my $searchfor = catfile split '::', $_;
682 $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
686 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
688 close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
692 $self->aside( "Searching for $_\n" );
696 push @found, $_ if $self->opt_m or $self->containspod($_);
700 # We must look both in @INC for library modules and in $bindir
701 # for executables, like h2xs or perldoc itself.
703 my @searchdirs = ($self->{'bindir'}, @INC);
704 unless ($self->opt_m) {
707 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
708 push(@searchdirs,$trn);
710 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
713 push(@searchdirs, grep(-d, split($Config{path_sep},
717 my @files = $self->searchfor(0,$_,@searchdirs);
719 $self->aside( "Found as @files\n" );
722 # no match, try recursive search
723 @searchdirs = grep(!/^\.\z/s,@INC);
724 @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
726 $self->aside( "Loosely found as @files\n" );
730 ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
731 if ( @{ $self->{'found'} } ) {
732 print STDERR "However, try\n";
733 for my $dir (@{ $self->{'found'} }) {
734 opendir(DIR, $dir) or die "opendir $dir: $!";
735 while (my $file = readdir(DIR)) {
736 next if ($file =~ /^\./s);
737 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
738 print STDERR "\tperldoc $_\::$file\n";
740 closedir(DIR) or die "closedir $dir: $!";
750 #..........................................................................
752 sub maybe_generate_dynamic_pod {
753 my($self, $found_things) = @_;
756 $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
758 $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
760 if( ! $self->opt_f and ! $self->opt_q ) {
761 DEBUG > 4 and print "That's a non-dynamic pod search.\n";
762 } elsif ( @dynamic_pod ) {
763 $self->aside("Hm, I found some Pod from that search!\n");
764 my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
766 push @{ $self->{'temp_file_list'} }, $buffer;
767 # I.e., it MIGHT be deleted at the end.
769 my $in_list = $self->opt_f;
771 print $buffd "=over 8\n\n" if $in_list;
772 print $buffd @dynamic_pod or die "Can't print $buffer: $!";
773 print $buffd "=back\n" if $in_list;
775 close $buffd or die "Can't close $buffer: $!";
777 @$found_things = $buffer;
778 # Yes, so found_things never has more than one thing in
779 # it, by time we leave here
781 $self->add_formatter_option('__filter_nroff' => 1);
785 $self->aside("I found no Pod from that search!\n");
791 #..........................................................................
793 sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
795 push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
797 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
798 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
803 #..........................................................................
805 sub search_perlfunc {
806 my($self, $found_things, $pod) = @_;
808 DEBUG > 2 and print "Search: @$found_things\n";
810 my $perlfunc = shift @$found_things;
811 open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
812 or die("Can't open $perlfunc: $!");
814 # Functions like -r, -e, etc. are listed under `-X'.
815 my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
816 ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
819 print "Going to perlfunc-scan for $search_re in $perlfunc\n";
824 last if /^=head2 Alphabetical Listing of Perl Functions/;
827 # Look for our function
830 while (<PFUNC>) { # "The Mothership Connection is here!"
831 if ( m/^=item\s+$search_re\b/ ) {
835 last if $found > 1 and not $inlist;
845 ++$found if /^\w/; # found descriptive text
849 "No documentation for perl function `%s' found\n",
853 close PFUNC or die "Can't open $perlfunc: $!";
858 #..........................................................................
860 sub search_perlfaqs {
861 my( $self, $found_things, $pod) = @_;
865 my $search_key = $self->opt_q;
867 my $rx = eval { qr/$search_key/ }
869 Invalid regular expression '$search_key' given as -q pattern:
871 Did you mean \\Q$search_key ?
876 foreach my $file (@$found_things) {
877 die "invalid file spec: $!" if $file =~ /[<>|]/;
878 open(INFAQ, "<", $file) # XXX 5.6ism
879 or die "Can't read-open $file: $!\nAborting";
881 if ( m/^=head2\s+.*(?:$search_key)/i ) {
883 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
885 elsif (/^=head[12]/) {
893 die("No documentation for perl FAQ keyword `$search_key' found\n")
900 #..........................................................................
902 sub render_findings {
903 # Return the filename to open
905 my($self, $found_things) = @_;
907 my $formatter_class = $self->{'formatter_class'}
908 || die "No formatter class set!?";
909 my $formatter = $formatter_class->can('new')
910 ? $formatter_class->new
914 if(! @$found_things) {
915 die "Nothing found?!";
916 # should have been caught before here
917 } elsif(@$found_things > 1) {
919 "Perldoc is only really meant for reading one document at a time.\n",
920 "So these parameters are being ignored: ",
921 join(' ', @$found_things[1 .. $#$found_things] ),
925 my $file = $found_things->[0];
927 DEBUG > 3 and printf "Formatter switches now: [%s]\n",
928 join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
930 # Set formatter options:
931 if( ref $formatter ) {
932 foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
933 my($switch, $value, $silent_fail) = @$f;
934 if( $formatter->can($switch) ) {
935 eval { $formatter->$switch( defined($value) ? $value : () ) };
936 warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
939 if( $silent_fail or $switch =~ m/^__/s ) {
940 DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
942 warn "$formatter_class doesn't recognize the $switch switch.\n";
948 $self->{'output_is_binary'} =
949 $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
951 my ($out_fh, $out) = $self->new_output_file(
952 ( $formatter->can('output_extension') && $formatter->output_extension )
954 $self->useful_filename_bit,
957 # Now, finally, do the formatting!
960 if(DEBUG() or $self->opt_v) {
961 # feh, let 'em see it
964 # The average user just has no reason to be seeing
965 # $^W-suppressable warnings from the formatting!
968 eval { $formatter->parse_from_file( $file, $out_fh ) };
971 warn "Error while formatting with $formatter_class:\n $@\n" if $@;
972 DEBUG > 2 and print "Back from formatting with $formatter_class\n";
975 or warn "Can't close $out: $!\n(Did $formatter already close it?)";
976 sleep 0; sleep 0; sleep 0;
977 # Give the system a few timeslices to meditate on the fact
978 # that the output file does in fact exist and is closed.
980 $self->unlink_if_temp_file($file);
983 if( $formatter->can( 'if_zero_length' ) ) {
984 # Basically this is just a hook for Pod::Simple::Checker; since
985 # what other class could /happily/ format an input file with Pod
986 # as a 0-length output file?
987 $formatter->if_zero_length( $file, $out, $out_fh );
989 warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
993 DEBUG and print "Finished writing to $out.\n";
994 return($out, $formatter) if wantarray;
998 #..........................................................................
1000 sub unlink_if_temp_file {
1001 # Unlink the specified file IFF it's in the list of temp files.
1002 # Really only used in the case of -f / -q things when we can
1003 # throw away the dynamically generated source pod file once
1004 # we've formatted it.
1006 my($self, $file) = @_;
1007 return unless defined $file and length $file;
1009 my $temp_file_list = $self->{'temp_file_list'} || return;
1010 if(grep $_ eq $file, @$temp_file_list) {
1011 $self->aside("Unlinking $file\n");
1012 unlink($file) or warn "Odd, couldn't unlink $file: $!";
1014 DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
1019 #..........................................................................
1021 sub MSWin_temp_cleanup {
1023 # Nothing particularly MSWin-specific in here, but I don't know if any
1024 # other OS needs its temp dir policed like MSWin does!
1028 my $tempdir = $ENV{'TEMP'};
1029 return unless defined $tempdir and length $tempdir
1030 and -e $tempdir and -d _ and -w _;
1033 "Considering whether any old files of mine in $tempdir need unlinking.\n"
1036 opendir(TMPDIR, $tempdir) || return;
1039 my $limit = time() - $Temp_File_Lifetime;
1041 DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
1046 while(defined($filespec = readdir(TMPDIR))) {
1048 $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
1050 if( hex($1) < $limit ) {
1051 push @to_unlink, "$tempdir/$filespec";
1052 $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
1055 printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
1059 print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
1063 $self->aside(sprintf "Unlinked %s items of mine in %s\n",
1064 scalar(unlink(@to_unlink)),
1070 # . . . . . . . . . . . . . . . . . . . . . . . . .
1072 sub MSWin_perldoc_tempfile {
1073 my($self, $suffix, $infix) = @_;
1075 my $tempdir = $ENV{'TEMP'};
1076 return unless defined $tempdir and length $tempdir
1077 and -e $tempdir and -d _ and -w _;
1082 $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
1083 # Yes, we embed the create-time in the filename!
1088 defined( &Win32::GetTickCount )
1089 ? (Win32::GetTickCount() & 0xff)
1091 # Under MSWin, $$ values get reused quickly! So if we ran
1092 # perldoc foo and then perldoc bar before there was time for
1093 # time() to increment time."_$$" would likely be the same
1094 # for each process! So we tack on the tick count's lower
1095 # bits (or, in a pinch, rand)
1099 } while( -e $spec );
1103 while($counter < 50) {
1105 # If we are running before perl5.6.0, we can't autovivify
1108 $fh = Symbol::gensym();
1110 DEBUG > 3 and print "About to try making temp file $spec\n";
1111 return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
1112 $self->aside("Can't create temp file $spec: $!\n");
1115 $self->aside("Giving up on making a temp file!\n");
1116 die "Can't make a tempfile!?";
1119 #..........................................................................
1122 sub after_rendering {
1124 $self->after_rendering_VMS if IS_VMS;
1125 $self->after_rendering_MSWin32 if IS_MSWin32;
1126 $self->after_rendering_Dos if IS_Dos;
1127 $self->after_rendering_OS2 if IS_OS2;
1131 sub after_rendering_VMS { return }
1132 sub after_rendering_Dos { return }
1133 sub after_rendering_OS2 { return }
1135 sub after_rendering_MSWin32 {
1136 shift->MSWin_temp_cleanup() if $Temp_Files_Created;
1139 #..........................................................................
1141 #..........................................................................
1144 sub minus_f_nocase { # i.e., do like -f, but without regard to case
1146 my($self, $dir, $file) = @_;
1147 my $path = catfile($dir,$file);
1148 return $path if -f $path and -r _;
1151 or IS_VMS or IS_MSWin32
1154 # On a case-forgiving file system, or if case is important,
1155 # that is it, all we can do.
1156 warn "Ignored $path: unreadable\n" if -f _;
1163 foreach $p (splitdir $file){
1164 my $try = catfile @p, $p;
1165 $self->aside("Scrutinizing $try...\n");
1169 if ( $p eq $self->{'target'} ) {
1170 my $tmp_path = catfile @p;
1172 for (@{ $self->{'found'} }) {
1173 $path_f = 1 if $_ eq $tmp_path;
1175 push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
1176 $self->aside( "Found as $tmp_path but directory\n" );
1179 elsif (-f _ && -r _) {
1183 warn "Ignored $try: unreadable\n";
1185 elsif (-d catdir(@p)) { # at least we see the containing directory!
1188 my $p_dirspec = catdir(@p);
1189 opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
1190 while(defined( $cip = readdir(DIR) )) {
1191 if (lc $cip eq $lcp){
1193 last; # XXX stop at the first? what if there's others?
1196 closedir DIR or die "closedir $p_dirspec: $!";
1197 return "" unless $found;
1200 my $p_filespec = catfile(@p);
1201 return $p_filespec if -f $p_filespec and -r _;
1202 warn "Ignored $p_filespec: unreadable\n" if -f _;
1208 #..........................................................................
1210 sub pagers_guessing {
1214 push @pagers, $self->pagers;
1215 $self->{'pagers'} = \@pagers;
1218 push @pagers, qw( more< less notepad );
1219 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1222 push @pagers, qw( most more less type/page );
1225 push @pagers, qw( less.exe more.com< );
1226 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1230 unshift @pagers, 'less', 'cmd /c more <';
1232 push @pagers, qw( more less pg view cat );
1233 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
1237 if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
1238 unshift @pagers, '/usr/bin/less -isrR';
1242 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
1247 #..........................................................................
1249 sub page_module_file {
1250 my($self, @found) = @_;
1253 # Don't ever just pass this off to anything like MSWin's "start.exe",
1254 # since we might be calling on a .pl file, and we wouldn't want that
1255 # to actually /execute/ the file that we just want to page thru!
1256 # Also a consideration if one were to use a web browser as a pager;
1257 # doing so could trigger the browser's MIME mapping for whatever
1258 # it thinks .pm/.pl/whatever is. Probably just a (useless and
1259 # annoying) "Save as..." dialog, but potentially executing the file
1260 # in question -- particularly in the case of MSIE and it's, ahem,
1261 # occasionally hazy distinction between OS-local extension
1262 # associations, and browser-specific MIME mappings.
1264 if ($self->{'output_to_stdout'}) {
1265 $self->aside("Sending unpaged output to STDOUT.\n");
1268 foreach my $output (@found) {
1269 unless( open(TMP, "<", $output) ) { # XXX 5.6ism
1270 warn("Can't open $output: $!");
1275 print or die "Can't print to stdout: $!";
1277 close TMP or die "Can't close while $output: $!";
1278 $self->unlink_if_temp_file($output);
1280 return $any_error; # successful
1283 foreach my $pager ( $self->pagers ) {
1284 $self->aside("About to try calling $pager @found\n");
1285 if (system($pager, @found) == 0) {
1286 $self->aside("Yay, it worked.\n");
1289 $self->aside("That didn't work.\n");
1291 # Odd -- when it fails, under Win32, this seems to neither
1292 # return with a fail nor return with a success!!
1293 # That's discouraging!
1297 sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
1299 join(' ', $self->pagers),
1303 DEBUG > 1 and print "Bailing out in a VMSish way.\n";
1305 use vmsish qw(status exit);
1312 # i.e., an UNSUCCESSFUL return value!
1315 #..........................................................................
1318 my($self, $dir, $file) = @_;
1320 unless( ref $self ) {
1321 # Should never get called:
1324 Carp::croak( join '',
1325 "Crazy ", __PACKAGE__, " error:\n",
1326 "check_file must be an object_method!\n",
1331 if(length $dir and not -d $dir) {
1332 DEBUG > 3 and print " No dir $dir -- skipping.\n";
1337 return $self->minus_f_nocase($dir,$file);
1341 my $path = $self->minus_f_nocase($dir,$file);
1342 if( length $path and $self->containspod($path) ) {
1344 " The file $path indeed looks promising!\n";
1348 DEBUG > 3 and print " No good: $file in $dir\n";
1353 #..........................................................................
1356 my($self, $file, $readit) = @_;
1357 return 1 if !$readit && $file =~ /\.pod\z/i;
1360 # Under cygwin the /usr/bin/perl is legal executable, but
1361 # you cannot open a file with that name. It must be spelled
1362 # out as "/usr/bin/perl.exe".
1364 # The following if-case under cygwin prevents error
1367 # Cannot open /usr/bin/perl: no such file or directory
1369 # This would work though
1371 # $ perldoc perl.pod
1373 if ( IS_Cygwin and -x $file and -f "$file.exe" )
1375 warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v;
1380 open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
1383 close(TEST) or die "Can't close $file: $!";
1387 close(TEST) or die "Can't close $file: $!";
1391 #..........................................................................
1393 sub maybe_diddle_INC {
1396 # Does this look like a module or extension directory?
1398 if (-f "Makefile.PL") {
1400 # Add "." and "lib" to @INC (if they exist)
1401 eval q{ use lib qw(. lib); 1; } or die;
1403 # don't add if superuser
1404 if ($< && $> && -f "blib") { # don't be looking too hard now!
1405 eval q{ use blib; 1 };
1406 warn $@ if $@ && $self->opt_v;
1413 #..........................................................................
1415 sub new_output_file {
1417 my $outspec = $self->opt_d; # Yes, -d overrides all else!
1418 # So don't call this twice per format-job!
1420 return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
1422 # Otherwise open a write-handle on opt_d!f
1425 # If we are running before perl5.6.0, we can't autovivify
1428 $fh = Symbol::gensym();
1430 DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
1431 die "Can't write-open $outspec: $!"
1432 unless open($fh, ">", $outspec); # XXX 5.6ism
1434 DEBUG > 3 and print "Successfully opened $outspec\n";
1435 binmode($fh) if $self->{'output_is_binary'};
1436 return($fh, $outspec);
1439 #..........................................................................
1441 sub useful_filename_bit {
1442 # This tries to provide a meaningful bit of text to do with the query,
1443 # such as can be used in naming the file -- since if we're going to be
1444 # opening windows on temp files (as a "pager" may well do!) then it's
1445 # better if the temp file's name (which may well be used as the window
1446 # title) isn't ALL just random garbage!
1447 # In other words "perldoc_LWPSimple_2371981429" is a better temp file
1448 # name than "perldoc_2371981429". So this routine is what tries to
1449 # provide the "LWPSimple" bit.
1452 my $pages = $self->{'pages'} || return undef;
1453 return undef unless @$pages;
1455 my $chunk = $pages->[0];
1456 return undef unless defined $chunk;
1458 $chunk =~ s/\.\w+$//g; # strip any extension
1459 if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
1464 $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
1465 $chunk = substr($chunk, -10) if length($chunk) > 10;
1469 #..........................................................................
1471 sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
1474 ++$Temp_Files_Created;
1477 my @out = $self->MSWin_perldoc_tempfile(@_);
1478 return @out if @out;
1479 # otherwise fall thru to the normal stuff below...
1483 return File::Temp::tempfile(UNLINK => 1);
1486 #..........................................................................
1488 sub page { # apply a pager to the output file
1489 my ($self, $output, $output_to_stdout, @pagers) = @_;
1490 if ($output_to_stdout) {
1491 $self->aside("Sending unpaged output to STDOUT.\n");
1492 open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
1495 print or die "Can't print to stdout: $!";
1497 close TMP or die "Can't close while $output: $!";
1498 $self->unlink_if_temp_file($output);
1500 # On VMS, quoting prevents logical expansion, and temp files with no
1501 # extension get the wrong default extension (such as .LIS for TYPE)
1503 $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
1505 $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
1506 # Altho "/" under MSWin is in theory good as a pathsep,
1507 # many many corners of the OS don't like it. So we
1508 # have to force it to be "\" to make everyone happy.
1510 foreach my $pager (@pagers) {
1511 $self->aside("About to try calling $pager $output\n");
1513 last if system("$pager $output") == 0;
1515 last if system("$pager \"$output\"") == 0;
1522 #..........................................................................
1525 my($self, $recurse,$s,@dirs) = @_;
1527 $s = VMS::Filespec::unixify($s) if IS_VMS;
1528 return $s if -f $s && $self->containspod($s);
1529 $self->aside( "Looking for $s in @dirs\n" );
1533 $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
1534 for ($i=0; $i<@dirs; $i++) {
1536 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
1537 if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
1538 or ( $ret = $self->check_file($dir,"$s.pm"))
1539 or ( $ret = $self->check_file($dir,$s))
1541 $ret = $self->check_file($dir,"$s.com"))
1543 $ret = $self->check_file($dir,"$s.cmd"))
1544 or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
1545 $ret = $self->check_file($dir,"$s.bat"))
1546 or ( $ret = $self->check_file("$dir/pod","$s.pod"))
1547 or ( $ret = $self->check_file("$dir/pod",$s))
1548 or ( $ret = $self->check_file("$dir/pods","$s.pod"))
1549 or ( $ret = $self->check_file("$dir/pods",$s))
1551 DEBUG > 1 and print " Found $ret\n";
1556 opendir(D,$dir) or die "Can't opendir $dir: $!";
1557 my @newdirs = map catfile($dir, $_), grep {
1559 not /^auto\z/s and # save time! don't search auto dirs
1560 -d catfile($dir, $_)
1562 closedir(D) or die "Can't closedir $dir: $!";
1563 next unless @newdirs;
1564 # what a wicked map!
1565 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
1566 $self->aside( "Also looking in @newdirs\n" );
1567 push(@dirs,@newdirs);
1573 #..........................................................................
1575 my $already_asserted;
1576 sub assert_closing_stdout {
1579 return if $already_asserted;
1581 eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
1582 # What for? to let the pager know that nothing more will come?
1585 $already_asserted = 1;
1590 #..........................................................................
1592 sub tweak_found_pathnames {
1593 my($self, $found) = @_;
1595 foreach (@$found) { s,/,\\,g }
1600 #..........................................................................
1602 #..........................................................................
1604 sub am_taint_checking {
1606 die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
1607 my($k,$v) = each %ENV;
1608 return is_tainted($v);
1611 #..........................................................................
1613 sub is_tainted { # just a function
1615 my $nada = substr($arg, 0, 0); # zero-length!
1616 local $@; # preserve the caller's version of $@
1617 eval { eval "# $nada" };
1618 return length($@) != 0;
1621 #..........................................................................
1623 sub drop_privs_maybe {
1626 # Attempt to drop privs if we should be tainting and aren't
1627 if (!(IS_VMS || IS_MSWin32 || IS_Dos
1630 && ($> == 0 || $< == 0)
1631 && !$self->am_taint_checking()
1633 my $id = eval { getpwnam("nobody") };
1634 $id = eval { getpwnam("nouser") } unless defined $id;
1635 $id = -2 unless defined $id;
1637 # According to Stevens' APUE and various
1638 # (BSD, Solaris, HP-UX) man pages, setting
1639 # the real uid first and effective uid second
1640 # is the way to go if one wants to drop privileges,
1641 # because if one changes into an effective uid of
1642 # non-zero, one cannot change the real uid any more.
1644 # Actually, it gets even messier. There is
1645 # a third uid, called the saved uid, and as
1646 # long as that is zero, one can get back to
1647 # uid of zero. Setting the real-effective *twice*
1648 # helps in *most* systems (FreeBSD and Solaris)
1649 # but apparently in HP-UX even this doesn't help:
1650 # the saved uid stays zero (apparently the only way
1651 # in HP-UX to change saved uid is to call setuid()
1652 # when the effective uid is zero).
1655 $< = $id; # real uid
1656 $> = $id; # effective uid
1657 $< = $id; # real uid
1658 $> = $id; # effective uid
1660 if( !$@ && $< && $> ) {
1661 DEBUG and print "OK, I dropped privileges.\n";
1662 } elsif( $self->opt_U ) {
1663 DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
1665 DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
1666 # We used to die here; but that seemed pointless.
1672 #..........................................................................
1678 # See "perldoc perldoc" for basic details.
1680 # Perldoc -- look up a piece of documentation in .pod format that
1681 # is embedded in the perl installation tree.
1685 # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
1687 # Version 3.01: Sun Nov 10 21:38:09 MST 2002
1688 # Sean M. Burke <sburke@cpan.org>
1689 # Massive refactoring and code-tidying.
1690 # Now it's a module(-family)!
1691 # Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
1692 # Added -T, -d, -o, -M, -w.
1693 # Added some improved MSWin funk.
1697 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
1698 # Hugo van der Sanden <hv@crypt.org>
1699 # Made -U the default, based on patch from Simon Cozens
1700 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
1701 # Randy W. Sims <RandyS@ThePierianSpring.org>
1702 # allow -n to enable nroff under Win32
1703 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
1704 # Hugo van der Sanden <hv@crypt.org>
1705 # don't die when 'use blib' fails
1706 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
1707 # Tom Christiansen <tchrist@perl.com>
1708 # Added -U insecurity option
1709 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
1710 # Tom Christiansen <tchrist@perl.com>, querulously.
1711 # Security and correctness patches.
1712 # What a twisted bit of distasteful spaghetti code.
1717 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
1718 # Charles Wilson <cwilson@ece.gatech.edu>
1719 # changed /pod/ directory to /pods/ for cygwin
1720 # to support cygwin/win32
1721 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
1722 # Robin Barker <rmb1@cise.npl.co.uk>
1723 # -strict, -w cleanups
1724 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
1725 # Gurusamy Sarathy <gsar@activestate.com>
1726 # -doc tweaks for -F and -X options
1727 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
1728 # Gurusamy Sarathy <gsar@activestate.com>
1729 # -various fixes for win32
1730 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
1731 # Kenneth Albanowski <kjahds@kjahds.com>
1732 # -added Charles Bailey's further VMS patches, and -u switch
1733 # -added -t switch, with pod2text support
1735 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
1736 # Kenneth Albanowski <kjahds@kjahds.com>
1737 # -added VMS support
1738 # -added better error recognition (on no found pages, just exit. On
1739 # missing nroff/pod2man, just display raw pod.)
1740 # -added recursive/case-insensitive matching (thanks, Andreas). This
1741 # slows things down a bit, unfortunately. Give a precise name, and
1744 # Version 1.01: Tue May 30 14:47:34 EDT 1995
1745 # Andy Dougherty <doughera@lafcol.lafayette.edu>
1746 # -added pod documentation.
1747 # -added PATH searching.
1748 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
1755 # Cache the directories read during sloppy match
1756 # (To disk, or just in-memory?)
1758 # Backport this to perl 5.005?
1760 # Implement at least part of the "perlman" interface described
1761 # in Programming Perl 3e?