4 use File::Basename qw(&basename &dirname);
7 # List explicitly here the variables you want Configure to
8 # generate. Metaconfig only looks for shell variables, so you
9 # have to mention them as if they were shell variables, not
10 # %Config entries. Thus you write
12 # to ensure Configure will look for $Config{startperl}.
14 # This forces PL files to create target in same directory as PL file.
15 # This is so that make depend always knows where to find PL derivatives.
18 $file = basename($0, '.PL');
19 $file .= '.com' if $^O eq 'VMS';
21 open OUT,">$file" or die "Can't create $file: $!";
23 print "Extracting $file (with variable substitutions)\n";
25 # In this section, perl variables will be expanded during extraction.
26 # You can use $Config{...} to use Configure variables.
28 print OUT <<"!GROK!THIS!";
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
36 # make sure creat()s are neither too much nor too little
37 INIT { eval { umask(0077) } } # doubtless someone has no mask
40 push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
44 # In the following, perl variables are not expanded during extraction.
46 print OUT <<'!NO!SUBS!';
48 use Fcntl; # for sysopen
53 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
54 # is embedded in the perl installation tree.
56 # This is not to be confused with Tom Christiansen's perlman, which is a
57 # man replacement, written in perl. This perldoc is strictly for reading
58 # the perl manuals, though it too is written in perl.
60 # Massive security and correctness patches applied to this
61 # noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000
64 my $me = $0; # Editing $0 is unportable
67 Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName
71 The -h option prints more help. Also try "perldoc perldoc" to get
72 acquainted with the system.
76 my @global_found = ();
77 my $global_target = "";
79 my $Is_VMS = $^O eq 'VMS';
80 my $Is_MSWin32 = $^O eq 'MSWin32';
81 my $Is_Dos = $^O eq 'dos';
85 # Erase evidence of previous errors (if any), so exit status is simple.
88 perldoc [options] PageName|ModuleName|ProgramName...
89 perldoc [options] -f BuiltinFunction
90 perldoc [options] -q FAQRegex
93 -h Display this help message
94 -r Recursive search (slow)
96 -t Display pod using pod2text instead of pod2man and nroff
97 (-t is the default on win32)
98 -u Display unformatted pod text
99 -m Display module's file in its entirety
100 -n Specify replacement for nroff
101 -l Display the module's file name
102 -F Arguments are file names, not modules
103 -v Verbosely describe what's going on
104 -X use index if present (looks for pod.idx at $Config{archlib})
105 -q Search the text of questions (not answers) in perlfaq[1-9]
106 -U Run in insecure mode (superuser only)
108 PageName|ModuleName...
109 is the name of a piece of documentation that you want to look at. You
110 may either give a descriptive name of the page (as in the case of
111 `perlfunc') the name of a module, either like `Term::Info',
112 `Term/Info', the partial name of a module, like `info', or
113 `makemaker', or the name of a program, like `perldoc'.
116 is the name of a perl function. Will extract documentation from
120 is a regex. Will search perlfaq[1-9] for and extract any
121 questions that match.
123 Any switches in the PERLDOC environment variable will be used before the
124 command line arguments. The optional pod index file contains a list of
125 filenames, one per line.
130 if (defined $ENV{"PERLDOC"}) {
131 require Text::ParseWords;
132 unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
136 my $getopts = "mhtluvriFf:Xq:n:U";
137 print OUT <<"!GET!OPTS!";
139 use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
141 getopts("$getopts") || usage;
144 print OUT <<'!NO!SUBS!';
148 # refuse to run if we should be tainting and aren't
149 # (but regular users deserve protection too, though!)
150 if (!($Is_VMS || $Is_MSWin32 || $Is_Dos) && ($> == 0 || $< == 0)
151 && !am_taint_checking())
154 my $id = eval { getpwnam("nobody") };
155 $id = eval { getpwnam("nouser") } unless defined $id;
156 $id = -2 unless defined $id;
158 $> = $id; # must do this one first!
161 last if !$@ && $< && $>;
163 die "Superuser must not run $0 without security audit and taint checks.\n";
166 $opt_n = "nroff" if !$opt_n;
170 $podidx = "$Config{'archlib'}/pod.idx";
171 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
174 if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
175 usage("only one of -t, -u, -m or -l")
179 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
181 $opt_t = 1 unless $opts;
184 if ($opt_t) { require Pod::Text; import Pod::Text; }
188 @pages = ("perlfunc");
191 @pages = ("perlfaq1" .. "perlfaq9");
197 # Does this look like a module or extension directory?
198 if (-f "Makefile.PL") {
200 # Add ., lib to @INC (if they exist)
201 eval q{ use lib qw(. lib); 1; } or die;
203 # don't add if superuser
204 if ($< && $>) { # don't be looking too hard now!
205 eval q{ use blib; 1 } or die;
210 my($file, $readit) = @_;
211 return 1 if !$readit && $file =~ /\.pod\z/i;
213 open(TEST,"<", $file) or die "Can't open $file: $!";
216 close(TEST) or die "Can't close $file: $!";
220 close(TEST) or die "Can't close $file: $!";
226 my $path = join('/',$dir,$file); # XXX: dirseps
227 return $path if -f $path and -r _;
228 if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
229 # on a case-forgiving file system or if case is important
230 # that is it all we can do
231 warn "Ignored $path: unreadable\n" if -f _;
235 # this is completely wicked. don't mess with $", and if
236 # you do, don't assume / is the dirsep!
240 foreach $p (split(m!/!, $file)){ # XXX: dirseps
245 if ( $p eq $global_target) {
246 my $tmp_path = join ('/', @p); # XXX: dirseps
248 for (@global_found) {
249 $path_f = 1 if $_ eq $tmp_path;
251 push (@global_found, $tmp_path) unless $path_f;
252 print STDERR "Found as @p but directory\n" if $opt_v;
255 elsif (-f _ && -r _) {
259 warn "Ignored $try: unreadable\n";
264 opendir DIR, "@p" or die "opendir @p: $!";
265 while ($cip=readdir(DIR)) {
266 if (lc $cip eq $lcp){
271 closedir DIR or die "closedir @p: $!";
272 return "" unless $found;
274 return "@p" if -f "@p" and -r _;
275 warn "Ignored @p: unreadable\n" if -f _;
284 return "" if length $dir and not -d $dir;
286 return minus_f_nocase($dir,$file);
289 my $path = minus_f_nocase($dir,$file);
290 return $path if length $path and containspod($path);
297 my($recurse,$s,@dirs) = @_;
299 $s = VMS::Filespec::unixify($s) if $Is_VMS;
300 return $s if -f $s && containspod($s);
301 printf STDERR "Looking for $s in @dirs\n" if $opt_v;
305 $global_target = (split(m!/!, $s))[-1]; # XXX: dirseps
306 for ($i=0; $i<@dirs; $i++) {
308 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
309 if ( ( $ret = check_file $dir,"$s.pod")
310 or ( $ret = check_file $dir,"$s.pm")
311 or ( $ret = check_file $dir,$s)
313 $ret = check_file $dir,"$s.com")
314 or ( $^O eq 'os2' and
315 $ret = check_file $dir,"$s.cmd")
316 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
317 $ret = check_file $dir,"$s.bat")
318 or ( $ret = check_file "$dir/pod","$s.pod")
319 or ( $ret = check_file "$dir/pod",$s)
320 or ( $ret = check_file "$dir/pods","$s.pod")
321 or ( $ret = check_file "$dir/pods",$s)
327 opendir(D,$dir) or die "Can't opendir $dir: $!";
328 my @newdirs = map "$dir/$_", grep { # XXX: dirseps
330 not /^auto\z/s and # save time! don't search auto dirs
331 -d "$dir/$_" # XXX: dirseps
333 closedir(D) or die "Can't closedir $dir: $!";
334 next unless @newdirs;
336 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
337 print STDERR "Also looking in @newdirs\n" if $opt_v;
338 push(@dirs,@newdirs);
345 my @data = split /\n{2,}/, shift;
346 shift @data while @data and $data[0] !~ /\S/; # Go to header
347 shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
348 pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
349 # 28/Jan/99 perl 5.005, patch 53 1
354 my ($file, $tmp, $filter) = @_;
358 # why was this append?
359 sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
360 or die ("Can't open $tmp: $!");
361 Pod::Text->new()->parse_from_file($file,\*OUT);
362 close OUT or die "can't close $tmp: $!";
365 my $cmd = "pod2man --lax $file | $opt_n -man";
366 $cmd .= " | col -x" if $^O =~ /hpux/;
368 $rslt = filter_nroff($rslt) if $filter;
369 unless (($err = $?)) {
370 # why was this append?
371 sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
372 or die "Can't open $tmp: $!";
374 or die "Can't print $tmp: $!";
376 or die "Can't close $tmp: $!";
379 if ($opt_u or $err or -z $tmp) { # XXX: race with -z
380 # why was this append?
381 sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
382 or die "Can't open $tmp: $!";
383 open(IN,"<", $file) or die("Can't open $file: $!");
387 $cut = $1 eq 'cut' if /^=(\w+)/;
390 or die "Can't print $tmp: $!";
392 close IN or die "Can't close $file: $!";
393 close OUT or die "Can't close $tmp: $!";
398 my ($tmp, $no_tty, @pagers) = @_;
400 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
403 print or die "Can't print to stdout: $!";
405 close TMP or die "Can't close while $tmp: $!";
408 foreach my $pager (@pagers) {
409 last if system("$pager $tmp") == 0;
418 1 while unlink($_); # XXX: expect failure
420 unlink($_); # or die "Can't unlink $_: $!";
427 if ($podidx && open(PODIDX, $podidx)) {
429 $searchfor =~ s,::,/,g; # XXX: dirseps
430 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
434 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
436 close(PODIDX) or die "Can't close $podidx: $!";
439 print STDERR "Searching for $_\n" if $opt_v;
440 # We must look both in @INC for library modules and in PATH
441 # for executables, like h2xs or perldoc itself.
442 my @searchdirs = @INC;
445 push @found, $_ if $opt_m or containspod($_);
451 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
452 push(@searchdirs,$trn);
454 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
457 push(@searchdirs, grep(-d, split($Config{path_sep},
461 my @files = searchfor(0,$_,@searchdirs);
463 print STDERR "Found as @files\n" if $opt_v;
466 # no match, try recursive search
467 @searchdirs = grep(!/^\.\z/s,@INC);
468 @files= searchfor(1,$_,@searchdirs) if $opt_r;
470 print STDERR "Loosely found as @files\n" if $opt_v;
473 print STDERR "No documentation found for \"$_\".\n";
475 print STDERR "However, try\n";
476 for my $dir (@global_found) {
477 opendir(DIR, $dir) or die "opendir $dir: $!";
478 while (my $file = readdir(DIR)) {
479 next if ($file =~ /^\./s);
480 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
481 print STDERR "\tperldoc $_\::$file\n";
483 closedir DIR or die "closedir $dir: $!";
492 exit ($Is_VMS ? 98962 : 1);
496 print join("\n", @found), "\n";
500 my $lines = $ENV{LINES} || 24;
503 if (! -t STDOUT) { $no_tty = 1 }
504 END { close(STDOUT) || die "Can't close STDOUT: $!" }
506 # until here we could simply exit or die
507 # now we create temporary files that we have to clean up
508 # namely $tmp, $buffer
509 # that's because you did it wrong, should be descriptor based --tchrist
514 $tmp = "$ENV{TEMP}\\perldoc1.$$";
515 $buffer = "$ENV{TEMP}\\perldoc1.b$$";
516 push @pagers, qw( more< less notepad );
517 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
518 for (@found) { s,/,\\,g }
521 $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
522 $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
523 push @pagers, qw( most more less type/page );
526 $tmp = "$ENV{TEMP}/perldoc1.$$";
527 $buffer = "$ENV{TEMP}/perldoc1.b$$";
529 $buffer =~ tr!\\/!//!s;
530 push @pagers, qw( less.exe more.com< );
531 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
536 $tmp = POSIX::tmpnam();
537 $buffer = POSIX::tmpnam();
538 unshift @pagers, 'less', 'cmd /c more <';
541 # XXX: this is not secure, because it doesn't open it
542 ($tmp, $buffer) = eval { require POSIX }
543 ? (POSIX::tmpnam(), POSIX::tmpnam() )
544 : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" );
546 push @pagers, qw( more less pg view cat );
547 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
549 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
551 # make sure cleanup called
553 sub END { cleanup($tmp, $buffer) }
556 eval q{ use sigtrap qw(die INT TERM HUP QUIT) };
559 foreach my $pager (@pagers) {
560 if (system($pager, @found) == 0) {
566 use vmsish qw(status exit);
576 my $perlfunc = shift @found;
577 open(PFUNC, "<", $perlfunc)
578 or die("Can't open $perlfunc: $!");
580 # Functions like -r, -e, etc. are listed under `-X'.
581 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
587 last if /^=head2 Alphabetical Listing of Perl Functions/;
590 # Look for our function
594 if (/^=item\s+\Q$search_string\E\b/o) {
598 last if $found > 1 and not $inlist;
608 ++$found if /^\w/; # found descriptive text
611 die "No documentation for perl function `$opt_f' found\n";
613 close PFUNC or die "Can't open $perlfunc: $!";
617 local @ARGV = @found; # I'm lazy, sue me.
620 my $rx = eval { qr/$opt_q/ } or die <<EOD;
621 Invalid regular expression '$opt_q' given as -q pattern:
623 Did you mean \\Q$opt_q ?
627 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
630 if (/^=head2\s+.*(?:$opt_q)/oi) {
632 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
641 die("No documentation for perl FAQ keyword `$opt_q' found\n");
648 sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
649 or die("Can't open $buffer: $!");
650 print TMP "=over 8\n\n";
651 print TMP @pod or die "Can't print $buffer: $!";
653 close TMP or die "Can't close $buffer: $!";
659 printout($_, $tmp, $filter);
661 page($tmp, $no_tty, @pagers);
667 my $nada = substr($arg, 0, 0); # zero-length
668 local $@; # preserve caller's version
669 eval { eval "# $nada" };
670 return length($@) != 0;
673 sub am_taint_checking {
674 my($k,$v) = each %ENV;
675 return is_tainted($v);
683 perldoc - Look up Perl documentation in pod format.
687 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
689 B<perldoc> B<-f> BuiltinFunction
691 B<perldoc> B<-q> FAQ Keyword
695 I<perldoc> looks up a piece of documentation in .pod format that is embedded
696 in the perl installation tree or in a perl script, and displays it via
697 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
698 C<col -x> will be used.) This is primarily used for the documentation for
699 the perl library modules.
701 Your system may also have man pages installed for those modules, in
702 which case you can probably just use the man(1) command.
710 Prints out a brief help message.
714 Describes search for the item in detail.
716 =item B<-t> text output
718 Display docs using plain text converter, instead of nroff. This may be faster,
719 but it won't look as nice.
721 =item B<-u> unformatted
723 Find docs only; skip reformatting by pod2*
727 Display the entire module: both code and unformatted pod documentation.
728 This may be useful if the docs don't explain a function in the detail
729 you need, and you'd like to inspect the code directly; perldoc will find
730 the file for you and simply hand it off for display.
732 =item B<-l> file name only
734 Display the file name of the module found.
736 =item B<-F> file names
738 Consider arguments as file names, no search in directories will be performed.
742 The B<-f> option followed by the name of a perl built in function will
743 extract the documentation of this function from L<perlfunc>.
747 The B<-q> option takes a regular expression as an argument. It will search
748 the question headings in perlfaq[1-9] and print the entries matching
749 the regular expression.
751 =item B<-X> use an index if present
753 The B<-X> option looks for a entry whose basename matches the name given on the
754 command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
755 contain fully qualified filenames, one per line.
757 =item B<-U> run insecurely
759 Because B<perldoc> does not run properly tainted, and is known to
760 have security issues, it will not normally execute as the superuser.
761 If you use the B<-U> flag, it will do so, but only after setting
762 the effective and real IDs to nobody's or nouser's account, or -2
763 if unavailable. If it cannot relinguish its privileges, it will not
766 =item B<PageName|ModuleName|ProgramName>
768 The item you want to look up. Nested modules (such as C<File::Basename>)
769 are specified either as C<File::Basename> or C<File/Basename>. You may also
770 give a descriptive name of a page, such as C<perlfunc>. You may also give a
771 partial or wrong-case name, such as "basename" for "File::Basename", but
772 this will be slower, if there is more then one page with the same partial
773 name, you will only get the first one.
779 Any switches in the C<PERLDOC> environment variable will be used before the
780 command line arguments. C<perldoc> also searches directories
781 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
782 defined) and C<PATH> environment variables.
783 (The latter is so that embedded pods for executables, such as
784 C<perldoc> itself, are available.) C<perldoc> will use, in order of
785 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
786 C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
787 used if C<perldoc> was told to display plain text or unformatted pod.)
789 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
793 This is perldoc v2.01.
797 Kenneth Albanowski <kjahds@kjahds.com>
799 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
805 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
806 # Tom Christiansen <tchrist@perl.com>
807 # Added -U insecurity option
808 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
809 # Tom Christiansen <tchrist@perl.com>, querulously.
810 # Security and correctness patches.
811 # What a twisted bit of distasteful spaghetti code.
813 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
814 # Charles Wilson <cwilson@ece.gatech.edu>
815 # changed /pod/ directory to /pods/ for cygwin
816 # to support cygwin/win32
817 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
818 # Robin Barker <rmb1@cise.npl.co.uk>
819 # -strict, -w cleanups
820 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
821 # Gurusamy Sarathy <gsar@activestate.com>
822 # -doc tweaks for -F and -X options
823 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
824 # Gurusamy Sarathy <gsar@activestate.com>
825 # -various fixes for win32
826 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
827 # Kenneth Albanowski <kjahds@kjahds.com>
828 # -added Charles Bailey's further VMS patches, and -u switch
829 # -added -t switch, with pod2text support
831 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
832 # Kenneth Albanowski <kjahds@kjahds.com>
834 # -added better error recognition (on no found pages, just exit. On
835 # missing nroff/pod2man, just display raw pod.)
836 # -added recursive/case-insensitive matching (thanks, Andreas). This
837 # slows things down a bit, unfortunately. Give a precise name, and
840 # Version 1.01: Tue May 30 14:47:34 EDT 1995
841 # Andy Dougherty <doughera@lafcol.lafayette.edu>
842 # -added pod documentation.
843 # -added PATH searching.
844 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
850 # Cache directories read during sloppy match
853 close OUT or die "Can't close $file: $!";
854 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
855 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';