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'}";
41 my \$bindir = '$Config{scriptdir}';
45 # In the following, perl variables are not expanded during extraction.
47 print OUT <<'!NO!SUBS!';
49 use Fcntl; # for sysopen
52 use File::Spec::Functions qw(catfile splitdir);
55 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
56 # is embedded in the perl installation tree.
58 # This is not to be confused with Tom Christiansen's perlman, which is a
59 # man replacement, written in perl. This perldoc is strictly for reading
60 # the perl manuals, though it too is written in perl.
62 # Massive security and correctness patches applied to this
63 # noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000
66 my $me = $0; # Editing $0 is unportable
69 Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName
73 The -h option prints more help. Also try "perldoc perldoc" to get
74 acquainted with the system.
78 my @global_found = ();
79 my $global_target = "";
81 my $Is_VMS = $^O eq 'VMS';
82 my $Is_MSWin32 = $^O eq 'MSWin32';
83 my $Is_Dos = $^O eq 'dos';
84 my $Is_OS2 = $^O eq 'os2';
88 # Erase evidence of previous errors (if any), so exit status is simple.
91 perldoc [options] PageName|ModuleName|ProgramName...
92 perldoc [options] -f BuiltinFunction
93 perldoc [options] -q FAQRegex
96 -h Display this help message
97 -r Recursive search (slow)
99 -t Display pod using pod2text instead of pod2man and nroff
100 (-t is the default on win32)
101 -u Display unformatted pod text
102 -m Display module's file in its entirety
103 -n Specify replacement for nroff
104 -l Display the module's file name
105 -F Arguments are file names, not modules
106 -v Verbosely describe what's going on
107 -X use index if present (looks for pod.idx at $Config{archlib})
108 -q Search the text of questions (not answers) in perlfaq[1-9]
109 -U Run in insecure mode (superuser only)
111 PageName|ModuleName...
112 is the name of a piece of documentation that you want to look at. You
113 may either give a descriptive name of the page (as in the case of
114 `perlfunc') the name of a module, either like `Term::Info',
115 `Term/Info', the partial name of a module, like `info', or
116 `makemaker', or the name of a program, like `perldoc'.
119 is the name of a perl function. Will extract documentation from
123 is a regex. Will search perlfaq[1-9] for and extract any
124 questions that match.
126 Any switches in the PERLDOC environment variable will be used before the
127 command line arguments. The optional pod index file contains a list of
128 filenames, one per line.
133 if (defined $ENV{"PERLDOC"}) {
134 require Text::ParseWords;
135 unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
139 my $getopts = "mhtluvriFf:Xq:n:U";
140 print OUT <<"!GET!OPTS!";
142 use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
144 getopts("$getopts") || usage;
147 print OUT <<'!NO!SUBS!';
151 # refuse to run if we should be tainting and aren't
152 # (but regular users deserve protection too, though!)
153 if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0)
154 && !am_taint_checking())
157 my $id = eval { getpwnam("nobody") };
158 $id = eval { getpwnam("nouser") } unless defined $id;
159 $id = -2 unless defined $id;
161 $> = $id; # must do this one first!
164 last if !$@ && $< && $>;
166 die "Superuser must not run $0 without security audit and taint checks.\n";
169 $opt_n = "nroff" if !$opt_n;
173 $podidx = "$Config{'archlib'}/pod.idx";
174 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
177 if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
178 usage("only one of -t, -u, -m or -l")
182 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
184 $opt_t = 1 unless $opts;
187 if ($opt_t) { require Pod::Text; import Pod::Text; }
191 @pages = ("perlfunc");
194 @pages = ("perlfaq1" .. "perlfaq9");
200 # Does this look like a module or extension directory?
201 if (-f "Makefile.PL") {
203 # Add ., lib to @INC (if they exist)
204 eval q{ use lib qw(. lib); 1; } or die;
206 # don't add if superuser
207 if ($< && $> && -f "blib") { # don't be looking too hard now!
208 eval q{ use blib; 1 };
209 warn $@ if $@ && $opt_v;
214 my($file, $readit) = @_;
215 return 1 if !$readit && $file =~ /\.pod\z/i;
217 open(TEST,"<", $file) or die "Can't open $file: $!";
220 close(TEST) or die "Can't close $file: $!";
224 close(TEST) or die "Can't close $file: $!";
230 my $path = catfile($dir,$file);
231 return $path if -f $path and -r _;
232 if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
233 # on a case-forgiving file system or if case is important
234 # that is it all we can do
235 warn "Ignored $path: unreadable\n" if -f _;
239 # this is completely wicked. don't mess with $", and if
240 # you do, don't assume / is the dirsep!
244 foreach $p (splitdir $file){
245 my $try = catfile @p, $p;
249 if ( $p eq $global_target) {
250 my $tmp_path = catfile @p;
252 for (@global_found) {
253 $path_f = 1 if $_ eq $tmp_path;
255 push (@global_found, $tmp_path) unless $path_f;
256 print STDERR "Found as @p but directory\n" if $opt_v;
259 elsif (-f _ && -r _) {
263 warn "Ignored $try: unreadable\n";
268 opendir DIR, "@p" or die "opendir @p: $!";
269 while ($cip=readdir(DIR)) {
270 if (lc $cip eq $lcp){
275 closedir DIR or die "closedir @p: $!";
276 return "" unless $found;
278 return "@p" if -f "@p" and -r _;
279 warn "Ignored @p: unreadable\n" if -f _;
288 return "" if length $dir and not -d $dir;
290 return minus_f_nocase($dir,$file);
293 my $path = minus_f_nocase($dir,$file);
294 return $path if length $path and containspod($path);
301 my($recurse,$s,@dirs) = @_;
303 $s = VMS::Filespec::unixify($s) if $Is_VMS;
304 return $s if -f $s && containspod($s);
305 printf STDERR "Looking for $s in @dirs\n" if $opt_v;
309 $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename?
310 for ($i=0; $i<@dirs; $i++) {
312 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
313 if ( ( $ret = check_file $dir,"$s.pod")
314 or ( $ret = check_file $dir,"$s.pm")
315 or ( $ret = check_file $dir,$s)
317 $ret = check_file $dir,"$s.com")
318 or ( $^O eq 'os2' and
319 $ret = check_file $dir,"$s.cmd")
320 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
321 $ret = check_file $dir,"$s.bat")
322 or ( $ret = check_file "$dir/pod","$s.pod")
323 or ( $ret = check_file "$dir/pod",$s)
324 or ( $ret = check_file "$dir/pods","$s.pod")
325 or ( $ret = check_file "$dir/pods",$s)
331 opendir(D,$dir) or die "Can't opendir $dir: $!";
332 my @newdirs = map catfile($dir, $_), grep {
334 not /^auto\z/s and # save time! don't search auto dirs
337 closedir(D) or die "Can't closedir $dir: $!";
338 next unless @newdirs;
340 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
341 print STDERR "Also looking in @newdirs\n" if $opt_v;
342 push(@dirs,@newdirs);
349 my @data = split /\n{2,}/, shift;
350 shift @data while @data and $data[0] !~ /\S/; # Go to header
351 shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
352 pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
353 # 28/Jan/99 perl 5.005, patch 53 1
358 my ($file, $tmp, $filter) = @_;
362 # why was this append?
363 sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
364 or die ("Can't open $tmp: $!");
365 Pod::Text->new()->parse_from_file($file,\*OUT);
366 close OUT or die "can't close $tmp: $!";
369 my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man";
370 $cmd .= " | col -x" if $^O =~ /hpux/;
372 $rslt = filter_nroff($rslt) if $filter;
373 unless (($err = $?)) {
374 # why was this append?
375 sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
376 or die "Can't open $tmp: $!";
378 or die "Can't print $tmp: $!";
380 or die "Can't close $tmp: $!";
383 if ($opt_u or $err or -z $tmp) { # XXX: race with -z
384 # why was this append?
385 sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
386 or die "Can't open $tmp: $!";
387 open(IN,"<", $file) or die("Can't open $file: $!");
391 $cut = $1 eq 'cut' if /^=(\w+)/;
394 or die "Can't print $tmp: $!";
396 close IN or die "Can't close $file: $!";
397 close OUT or die "Can't close $tmp: $!";
402 my ($tmp, $no_tty, @pagers) = @_;
404 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
407 print or die "Can't print to stdout: $!";
409 close TMP or die "Can't close while $tmp: $!";
412 foreach my $pager (@pagers) {
414 last if system("$pager $tmp") == 0; # quoting prevents logical expansion
416 last if system("$pager \"$tmp\"") == 0;
426 1 while unlink($_); # XXX: expect failure
428 unlink($_); # or die "Can't unlink $_: $!";
435 if ($podidx && open(PODIDX, $podidx)) {
436 my $searchfor = catfile split '::';
437 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
441 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
443 close(PODIDX) or die "Can't close $podidx: $!";
446 print STDERR "Searching for $_\n" if $opt_v;
447 # We must look both in @INC for library modules and in $bindir
448 # for executables, like h2xs or perldoc itself.
449 my @searchdirs = ($bindir, @INC);
452 push @found, $_ if $opt_m or containspod($_);
458 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
459 push(@searchdirs,$trn);
461 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
464 push(@searchdirs, grep(-d, split($Config{path_sep},
468 my @files = searchfor(0,$_,@searchdirs);
470 print STDERR "Found as @files\n" if $opt_v;
473 # no match, try recursive search
474 @searchdirs = grep(!/^\.\z/s,@INC);
475 @files= searchfor(1,$_,@searchdirs) if $opt_r;
477 print STDERR "Loosely found as @files\n" if $opt_v;
480 print STDERR "No documentation found for \"$_\".\n";
482 print STDERR "However, try\n";
483 for my $dir (@global_found) {
484 opendir(DIR, $dir) or die "opendir $dir: $!";
485 while (my $file = readdir(DIR)) {
486 next if ($file =~ /^\./s);
487 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
488 print STDERR "\tperldoc $_\::$file\n";
490 closedir DIR or die "closedir $dir: $!";
499 exit ($Is_VMS ? 98962 : 1);
503 print join("\n", @found), "\n";
507 my $lines = $ENV{LINES} || 24;
510 if (! -t STDOUT) { $no_tty = 1 }
511 END { close(STDOUT) || die "Can't close STDOUT: $!" }
513 # until here we could simply exit or die
514 # now we create temporary files that we have to clean up
515 # namely $tmp, $buffer
516 # that's because you did it wrong, should be descriptor based --tchrist
521 $tmp = "$ENV{TEMP}\\perldoc1.$$";
522 $buffer = "$ENV{TEMP}\\perldoc1.b$$";
523 push @pagers, qw( more< less notepad );
524 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
525 for (@found) { s,/,\\,g }
528 $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
529 $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
530 push @pagers, qw( most more less type/page );
533 $tmp = "$ENV{TEMP}/perldoc1.$$";
534 $buffer = "$ENV{TEMP}/perldoc1.b$$";
536 $buffer =~ tr!\\/!//!s;
537 push @pagers, qw( less.exe more.com< );
538 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
543 $tmp = POSIX::tmpnam();
544 $buffer = POSIX::tmpnam();
545 unshift @pagers, 'less', 'cmd /c more <';
548 # XXX: this is not secure, because it doesn't open it
549 ($tmp, $buffer) = eval { require POSIX }
550 ? (POSIX::tmpnam(), POSIX::tmpnam() )
551 : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" );
553 push @pagers, qw( more less pg view cat );
554 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
556 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
558 # make sure cleanup called
560 sub END { cleanup($tmp, $buffer) }
564 # exit/die in a windows sighandler is dangerous, so let it do the
565 # default thing, which is to exit
566 eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32';
569 foreach my $pager (@pagers) {
570 if (system($pager, @found) == 0) {
576 use vmsish qw(status exit);
586 my $perlfunc = shift @found;
587 open(PFUNC, "<", $perlfunc)
588 or die("Can't open $perlfunc: $!");
590 # Functions like -r, -e, etc. are listed under `-X'.
591 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
597 last if /^=head2 Alphabetical Listing of Perl Functions/;
600 # Look for our function
604 if (/^=item\s+\Q$search_string\E\b/o) {
608 last if $found > 1 and not $inlist;
618 ++$found if /^\w/; # found descriptive text
621 die "No documentation for perl function `$opt_f' found\n";
623 close PFUNC or die "Can't open $perlfunc: $!";
627 local @ARGV = @found; # I'm lazy, sue me.
630 my $rx = eval { qr/$opt_q/ } or die <<EOD;
631 Invalid regular expression '$opt_q' given as -q pattern:
633 Did you mean \\Q$opt_q ?
637 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
640 if (/^=head2\s+.*(?:$opt_q)/oi) {
642 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
651 die("No documentation for perl FAQ keyword `$opt_q' found\n");
658 sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
659 or die("Can't open $buffer: $!");
660 print TMP "=over 8\n\n";
661 print TMP @pod or die "Can't print $buffer: $!";
663 close TMP or die "Can't close $buffer: $!";
669 printout($_, $tmp, $filter);
671 page($tmp, $no_tty, @pagers);
677 my $nada = substr($arg, 0, 0); # zero-length
678 local $@; # preserve caller's version
679 eval { eval "# $nada" };
680 return length($@) != 0;
683 sub am_taint_checking {
684 my($k,$v) = each %ENV;
685 return is_tainted($v);
693 perldoc - Look up Perl documentation in pod format.
697 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
699 B<perldoc> B<-f> BuiltinFunction
701 B<perldoc> B<-q> FAQ Keyword
705 I<perldoc> looks up a piece of documentation in .pod format that is embedded
706 in the perl installation tree or in a perl script, and displays it via
707 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
708 C<col -x> will be used.) This is primarily used for the documentation for
709 the perl library modules.
711 Your system may also have man pages installed for those modules, in
712 which case you can probably just use the man(1) command.
720 Prints out a brief help message.
724 Describes search for the item in detail.
726 =item B<-t> text output
728 Display docs using plain text converter, instead of nroff. This may be faster,
729 but it won't look as nice.
731 =item B<-u> unformatted
733 Find docs only; skip reformatting by pod2*
737 Display the entire module: both code and unformatted pod documentation.
738 This may be useful if the docs don't explain a function in the detail
739 you need, and you'd like to inspect the code directly; perldoc will find
740 the file for you and simply hand it off for display.
742 =item B<-l> file name only
744 Display the file name of the module found.
746 =item B<-F> file names
748 Consider arguments as file names, no search in directories will be performed.
752 The B<-f> option followed by the name of a perl built in function will
753 extract the documentation of this function from L<perlfunc>.
757 The B<-q> option takes a regular expression as an argument. It will search
758 the question headings in perlfaq[1-9] and print the entries matching
759 the regular expression.
761 =item B<-X> use an index if present
763 The B<-X> option looks for a entry whose basename matches the name given on the
764 command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
765 contain fully qualified filenames, one per line.
767 =item B<-U> run insecurely
769 Because B<perldoc> does not run properly tainted, and is known to
770 have security issues, it will not normally execute as the superuser.
771 If you use the B<-U> flag, it will do so, but only after setting
772 the effective and real IDs to nobody's or nouser's account, or -2
773 if unavailable. If it cannot relinguish its privileges, it will not
776 =item B<PageName|ModuleName|ProgramName>
778 The item you want to look up. Nested modules (such as C<File::Basename>)
779 are specified either as C<File::Basename> or C<File/Basename>. You may also
780 give a descriptive name of a page, such as C<perlfunc>. You may also give a
781 partial or wrong-case name, such as "basename" for "File::Basename", but
782 this will be slower, if there is more then one page with the same partial
783 name, you will only get the first one.
789 Any switches in the C<PERLDOC> environment variable will be used before the
790 command line arguments. C<perldoc> also searches directories
791 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
792 defined) and C<PATH> environment variables.
793 (The latter is so that embedded pods for executables, such as
794 C<perldoc> itself, are available.) C<perldoc> will use, in order of
795 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
796 C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
797 used if C<perldoc> was told to display plain text or unformatted pod.)
799 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
803 This is perldoc v2.03.
807 Kenneth Albanowski <kjahds@kjahds.com>
809 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
815 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
816 # Hugo van der Sanden <hv@crypt0.demon.co.uk>
817 # don't die when 'use blib' fails
818 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
819 # Tom Christiansen <tchrist@perl.com>
820 # Added -U insecurity option
821 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
822 # Tom Christiansen <tchrist@perl.com>, querulously.
823 # Security and correctness patches.
824 # What a twisted bit of distasteful spaghetti code.
826 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
827 # Charles Wilson <cwilson@ece.gatech.edu>
828 # changed /pod/ directory to /pods/ for cygwin
829 # to support cygwin/win32
830 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
831 # Robin Barker <rmb1@cise.npl.co.uk>
832 # -strict, -w cleanups
833 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
834 # Gurusamy Sarathy <gsar@activestate.com>
835 # -doc tweaks for -F and -X options
836 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
837 # Gurusamy Sarathy <gsar@activestate.com>
838 # -various fixes for win32
839 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
840 # Kenneth Albanowski <kjahds@kjahds.com>
841 # -added Charles Bailey's further VMS patches, and -u switch
842 # -added -t switch, with pod2text support
844 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
845 # Kenneth Albanowski <kjahds@kjahds.com>
847 # -added better error recognition (on no found pages, just exit. On
848 # missing nroff/pod2man, just display raw pod.)
849 # -added recursive/case-insensitive matching (thanks, Andreas). This
850 # slows things down a bit, unfortunately. Give a precise name, and
853 # Version 1.01: Tue May 30 14:47:34 EDT 1995
854 # Andy Dougherty <doughera@lafcol.lafayette.edu>
855 # -added pod documentation.
856 # -added PATH searching.
857 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
863 # Cache directories read during sloppy match
866 close OUT or die "Can't close $file: $!";
867 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
868 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';