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 my $versiononly = $Config{versiononly} ? $Config{version} : '';
30 print OUT <<"!GROK!THIS!";
32 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
38 # make sure creat()s are neither too much nor too little
39 INIT { eval { umask(0077) } } # doubtless someone has no mask
41 (my \$pager = <<'/../') =~ s/\\s*\\z//;
45 push \@pagers, \$pager if -x (split /\\s+/, \$pager)[0];
47 (my \$bindir = <<'/../') =~ s/\\s*\\z//;
51 (my \$pod2man = <<'/../') =~ s/\\s*\\z//;
57 # In the following, perl variables are not expanded during extraction.
59 print OUT <<'!NO!SUBS!';
61 use Fcntl; # for sysopen
64 use File::Spec::Functions qw(catfile splitdir);
67 # Perldoc revision #1 -- look up a piece of documentation in .pod format that
68 # is embedded in the perl installation tree.
70 # This is not to be confused with Tom Christiansen's perlman, which is a
71 # man replacement, written in perl. This perldoc is strictly for reading
72 # the perl manuals, though it too is written in perl.
74 # Massive security and correctness patches applied to this
75 # noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000
78 my $me = $0; # Editing $0 is unportable
81 Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName
85 The -h option prints more help. Also try "perldoc perldoc" to get
86 acquainted with the system.
90 my @global_found = ();
91 my $global_target = "";
93 my $Is_VMS = $^O eq 'VMS';
94 my $Is_MSWin32 = $^O eq 'MSWin32';
95 my $Is_Dos = $^O eq 'dos';
96 my $Is_OS2 = $^O eq 'os2';
97 my $Is_BeOS = $^O eq 'beos';
101 # Erase evidence of previous errors (if any), so exit status is simple.
104 perldoc [options] PageName|ModuleName|ProgramName...
105 perldoc [options] -f BuiltinFunction
106 perldoc [options] -q FAQRegex
109 -h Display this help message
110 -r Recursive search (slow)
112 -t Display pod using pod2text instead of pod2man and nroff
113 (-t is the default on win32 unless -n is specified)
114 -u Display unformatted pod text
115 -m Display module's file in its entirety
116 -n Specify replacement for nroff
117 -l Display the module's file name
118 -F Arguments are file names, not modules
119 -v Verbosely describe what's going on
120 -X use index if present (looks for pod.idx at $Config{archlib})
121 -q Search the text of questions (not answers) in perlfaq[1-9]
123 PageName|ModuleName...
124 is the name of a piece of documentation that you want to look at. You
125 may either give a descriptive name of the page (as in the case of
126 `perlfunc') the name of a module, either like `Term::Info' or like
127 `Term/Info', or the name of a program, like `perldoc'.
130 is the name of a perl function. Will extract documentation from
134 is a regex. Will search perlfaq[1-9] for and extract any
135 questions that match.
137 Any switches in the PERLDOC environment variable will be used before the
138 command line arguments. The optional pod index file contains a list of
139 filenames, one per line.
144 if (defined $ENV{"PERLDOC"}) {
145 require Text::ParseWords;
146 unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
150 my $getopts = "mhtluvriFf:Xq:n:";
151 print OUT <<"!GET!OPTS!";
153 use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
155 getopts("$getopts") || usage;
158 print OUT <<'!NO!SUBS!';
162 # attempt to drop privs if we should be tainting and aren't
163 if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2 || $Is_BeOS)
164 && ($> == 0 || $< == 0) && !am_taint_checking())
166 my $id = eval { getpwnam("nobody") };
167 $id = eval { getpwnam("nouser") } unless defined $id;
168 $id = -2 unless defined $id;
170 # According to Stevens' APUE and various
171 # (BSD, Solaris, HP-UX) man pages setting
172 # the real uid first and effective uid second
173 # is the way to go if one wants to drop privileges,
174 # because if one changes into an effective uid of
175 # non-zero, one cannot change the real uid any more.
177 # Actually, it gets even messier. There is
178 # a third uid, called the saved uid, and as
179 # long as that is zero, one can get back to
180 # uid of zero. Setting the real-effective *twice*
181 # helps in *most* systems (FreeBSD and Solaris)
182 # but apparently in HP-UX even this doesn't help:
183 # the saved uid stays zero (apparently the only way
184 # in HP-UX to change saved uid is to call setuid()
185 # when the effective uid is zero).
189 $> = $id; # effective uid
191 $> = $id; # effective uid
193 die "Superuser must not run $0 without security audit and taint checks.\n"
194 unless !$@ && $< && $>;
199 $podidx = "$Config{'archlib'}/pod.idx";
200 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
203 if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
204 usage("only one of -t, -u, -m or -l")
206 elsif ($Is_MSWin32 || $Is_Dos || $Is_BeOS
207 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
209 $opt_t = 1 unless ( $opts || $opt_n );
212 if ($opt_t) { require Pod::Text; import Pod::Text; }
214 $opt_n = "nroff" if !$opt_n;
218 @pages = ("perlfunc");
221 @pages = ("perlfaq1" .. "perlfaq9");
227 # Does this look like a module or extension directory?
228 if (-f "Makefile.PL") {
230 # Add ., lib to @INC (if they exist)
231 eval q{ use lib qw(. lib); 1; } or die;
233 # don't add if superuser
234 if ($< && $> && -f "blib") { # don't be looking too hard now!
235 eval q{ use blib; 1 };
236 warn $@ if $@ && $opt_v;
241 my($file, $readit) = @_;
242 return 1 if !$readit && $file =~ /\.pod\z/i;
244 open(TEST,"<", $file) or die "Can't open $file: $!";
247 close(TEST) or die "Can't close $file: $!";
251 close(TEST) or die "Can't close $file: $!";
257 my $path = catfile($dir,$file);
258 return $path if -f $path and -r _;
259 if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
260 # on a case-forgiving file system or if case is important
261 # that is it all we can do
262 warn "Ignored $path: unreadable\n" if -f _;
266 # this is completely wicked. don't mess with $", and if
267 # you do, don't assume / is the dirsep!
271 foreach $p (splitdir $file){
272 my $try = catfile @p, $p;
276 if ( $p eq $global_target) {
277 my $tmp_path = catfile @p;
279 for (@global_found) {
280 $path_f = 1 if $_ eq $tmp_path;
282 push (@global_found, $tmp_path) unless $path_f;
283 print STDERR "Found as @p but directory\n" if $opt_v;
286 elsif (-f _ && -r _) {
290 warn "Ignored $try: unreadable\n";
295 opendir DIR, "@p" or die "opendir @p: $!";
296 while ($cip=readdir(DIR)) {
297 if (lc $cip eq $lcp){
302 closedir DIR or die "closedir @p: $!";
303 return "" unless $found;
305 return "@p" if -f "@p" and -r _;
306 warn "Ignored @p: unreadable\n" if -f _;
315 return "" if length $dir and not -d $dir;
317 return minus_f_nocase($dir,$file);
320 my $path = minus_f_nocase($dir,$file);
321 return $path if length $path and containspod($path);
328 my($recurse,$s,@dirs) = @_;
330 $s = VMS::Filespec::unixify($s) if $Is_VMS;
331 return $s if -f $s && containspod($s);
332 printf STDERR "Looking for $s in @dirs\n" if $opt_v;
336 $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename?
337 for ($i=0; $i<@dirs; $i++) {
339 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
340 if ( (! $opt_m && ( $ret = check_file $dir,"$s.pod"))
341 or ( $ret = check_file $dir,"$s.pm")
342 or ( $ret = check_file $dir,$s)
344 $ret = check_file $dir,"$s.com")
345 or ( $^O eq 'os2' and
346 $ret = check_file $dir,"$s.cmd")
347 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
348 $ret = check_file $dir,"$s.bat")
349 or ( $ret = check_file "$dir/pod","$s.pod")
350 or ( $ret = check_file "$dir/pod",$s)
351 or ( $ret = check_file "$dir/pods","$s.pod")
352 or ( $ret = check_file "$dir/pods",$s)
358 opendir(D,$dir) or die "Can't opendir $dir: $!";
359 my @newdirs = map catfile($dir, $_), grep {
361 not /^auto\z/s and # save time! don't search auto dirs
364 closedir(D) or die "Can't closedir $dir: $!";
365 next unless @newdirs;
367 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
368 print STDERR "Also looking in @newdirs\n" if $opt_v;
369 push(@dirs,@newdirs);
376 my @data = split /\n{2,}/, shift;
377 shift @data while @data and $data[0] !~ /\S/; # Go to header
378 shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
379 pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
380 # 28/Jan/99 perl 5.005, patch 53 1
385 my ($tmp, $no_tty, @pagers) = @_;
387 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
390 print or die "Can't print to stdout: $!";
392 close TMP or die "Can't close while $tmp: $!";
395 # On VMS, quoting prevents logical expansion, and temp files with no
396 # extension get the wrong default extension (such as .LIS for TYPE)
398 $tmp = VMS::Filespec::rmsexpand($tmp, '.') if ($Is_VMS);
399 foreach my $pager (@pagers) {
401 last if system("$pager $tmp") == 0;
403 last if system("$pager \"$tmp\"") == 0;
411 if ($podidx && open(PODIDX, $podidx)) {
412 my $searchfor = catfile split '::';
413 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
417 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
419 close(PODIDX) or die "Can't close $podidx: $!";
422 print STDERR "Searching for $_\n" if $opt_v;
425 push @found, $_ if $opt_m or containspod($_);
428 # We must look both in @INC for library modules and in $bindir
429 # for executables, like h2xs or perldoc itself.
430 my @searchdirs = ($bindir, @INC);
434 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
435 push(@searchdirs,$trn);
437 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
440 push(@searchdirs, grep(-d, split($Config{path_sep},
444 my @files = searchfor(0,$_,@searchdirs);
446 print STDERR "Found as @files\n" if $opt_v;
449 # no match, try recursive search
450 @searchdirs = grep(!/^\.\z/s,@INC);
451 @files= searchfor(1,$_,@searchdirs) if $opt_r;
453 print STDERR "Loosely found as @files\n" if $opt_v;
457 ($opt_m ? "module" : "documentation") . " found for \"$_\".\n";
459 print STDERR "However, try\n";
460 for my $dir (@global_found) {
461 opendir(DIR, $dir) or die "opendir $dir: $!";
462 while (my $file = readdir(DIR)) {
463 next if ($file =~ /^\./s);
464 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
465 print STDERR "\tperldoc $_\::$file\n";
467 closedir DIR or die "closedir $dir: $!";
476 exit ($Is_VMS ? 98962 : 1);
480 print join("\n", @found), "\n";
484 my $lines = $ENV{LINES} || 24;
487 if (! -t STDOUT) { $no_tty = 1 }
488 END { close(STDOUT) || die "Can't close STDOUT: $!" }
491 push @pagers, qw( more< less notepad );
492 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
493 for (@found) { s,/,\\,g }
496 push @pagers, qw( most more less type/page );
499 push @pagers, qw( less.exe more.com< );
500 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
504 unshift @pagers, 'less', 'cmd /c more <';
506 push @pagers, qw( more less pg view cat );
507 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
509 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
512 foreach my $pager (@pagers) {
513 if (system($pager, @found) == 0) {
519 use vmsish qw(status exit);
529 my $perlfunc = shift @found;
530 open(PFUNC, "<", $perlfunc)
531 or die("Can't open $perlfunc: $!");
533 # Functions like -r, -e, etc. are listed under `-X'.
534 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
540 last if /^=head2 Alphabetical Listing of Perl Functions/;
543 # Look for our function
547 if (/^=item\s+\Q$search_string\E\b/o) {
551 last if $found > 1 and not $inlist;
561 ++$found if /^\w/; # found descriptive text
564 die "No documentation for perl function `$opt_f' found\n";
566 close PFUNC or die "Can't open $perlfunc: $!";
570 local @ARGV = @found; # I'm lazy, sue me.
573 my $rx = eval { qr/$opt_q/ } or die <<EOD;
574 Invalid regular expression '$opt_q' given as -q pattern:
576 Did you mean \\Q$opt_q ?
580 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
583 if (/^=head2\s+.*(?:$opt_q)/oi) {
585 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
587 elsif (/^=head[12]/) {
594 die("No documentation for perl FAQ keyword `$opt_q' found\n");
600 my ($tmpfd, $tmp) = File::Temp::tempfile(UNLINK => 1);
605 my ($buffd, $buffer) = File::Temp::tempfile(UNLINK => 1);
606 print $buffd "=over 8\n\n";
607 print $buffd @pod or die "Can't print $buffer: $!";
608 print $buffd "=back\n";
609 close $buffd or die "Can't close $buffer: $!";
619 Pod::Text->new()->parse_from_file($file, $tmpfd);
622 my $cmd = catfile($bindir, $pod2man) . " --lax $file | $opt_n -man";
623 $cmd .= " | col -x" if $^O =~ /hpux/;
625 $rslt = filter_nroff($rslt) if $filter;
626 unless (($err = $?)) {
628 or die "Can't print $tmp: $!";
631 if ($opt_u or $err) {
632 open(IN,"<", $file) or die("Can't open $file: $!");
636 $cut = $1 eq 'cut' if /^=(\w+)/;
639 or die "Can't print $tmp: $!";
641 close IN or die "Can't close $file: $!";
645 or die "Can't close $tmp: $!";
646 page($tmp, $no_tty, @pagers);
652 my $nada = substr($arg, 0, 0); # zero-length
653 local $@; # preserve caller's version
654 eval { eval "# $nada" };
655 return length($@) != 0;
658 sub am_taint_checking {
659 my($k,$v) = each %ENV;
660 return is_tainted($v);
668 perldoc - Look up Perl documentation in pod format.
672 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
674 B<perldoc> B<-f> BuiltinFunction
676 B<perldoc> B<-q> FAQ Keyword
680 I<perldoc> looks up a piece of documentation in .pod format that is embedded
681 in the perl installation tree or in a perl script, and displays it via
682 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
683 C<col -x> will be used.) This is primarily used for the documentation for
684 the perl library modules.
686 Your system may also have man pages installed for those modules, in
687 which case you can probably just use the man(1) command.
689 If you are looking for a table of contents to the Perl library modules
690 documentation, see the L<perltoc> page.
698 Prints out a brief help message.
702 Describes search for the item in detail.
704 =item B<-t> text output
706 Display docs using plain text converter, instead of nroff. This may be faster,
707 but it won't look as nice.
709 =item B<-u> unformatted
711 Find docs only; skip reformatting by pod2*
715 Display the entire module: both code and unformatted pod documentation.
716 This may be useful if the docs don't explain a function in the detail
717 you need, and you'd like to inspect the code directly; perldoc will find
718 the file for you and simply hand it off for display.
720 =item B<-l> file name only
722 Display the file name of the module found.
724 =item B<-F> file names
726 Consider arguments as file names, no search in directories will be performed.
730 The B<-f> option followed by the name of a perl built in function will
731 extract the documentation of this function from L<perlfunc>.
735 The B<-q> option takes a regular expression as an argument. It will search
736 the question headings in perlfaq[1-9] and print the entries matching
737 the regular expression.
739 =item B<-X> use an index if present
741 The B<-X> option looks for an entry whose basename matches the name given on the
742 command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
743 contain fully qualified filenames, one per line.
745 =item B<PageName|ModuleName|ProgramName>
747 The item you want to look up. Nested modules (such as C<File::Basename>)
748 are specified either as C<File::Basename> or C<File/Basename>. You may also
749 give a descriptive name of a page, such as C<perlfunc>.
755 Because B<perldoc> does not run properly tainted, and is known to
756 have security issues, when run as the superuser it will attempt to
757 drop privileges by setting the effective and real IDs to nobody's
758 or nouser's account, or -2 if unavailable. If it cannot relinquish
759 its privileges, it will not run.
763 Any switches in the C<PERLDOC> environment variable will be used before the
764 command line arguments. C<perldoc> also searches directories
765 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
766 defined) and C<PATH> environment variables.
767 (The latter is so that embedded pods for executables, such as
768 C<perldoc> itself, are available.) C<perldoc> will use, in order of
769 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
770 C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
771 used if C<perldoc> was told to display plain text or unformatted pod.)
773 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
777 This is perldoc v2.05.
781 Kenneth Albanowski <kjahds@kjahds.com>
783 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
789 # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
790 # Hugo van der Sanden <hv@crypt.org>
791 # Made -U the default, based on patch from Simon Cozens
792 # Version 2.04: Sun Aug 18 13:27:12 BST 2002
793 # Randy W. Sims <RandyS@ThePierianSpring.org>
794 # allow -n to enable nroff under Win32
795 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
796 # Hugo van der Sanden <hv@crypt.org>
797 # don't die when 'use blib' fails
798 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
799 # Tom Christiansen <tchrist@perl.com>
800 # Added -U insecurity option
801 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
802 # Tom Christiansen <tchrist@perl.com>, querulously.
803 # Security and correctness patches.
804 # What a twisted bit of distasteful spaghetti code.
806 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
807 # Charles Wilson <cwilson@ece.gatech.edu>
808 # changed /pod/ directory to /pods/ for cygwin
809 # to support cygwin/win32
810 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
811 # Robin Barker <rmb1@cise.npl.co.uk>
812 # -strict, -w cleanups
813 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
814 # Gurusamy Sarathy <gsar@activestate.com>
815 # -doc tweaks for -F and -X options
816 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
817 # Gurusamy Sarathy <gsar@activestate.com>
818 # -various fixes for win32
819 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
820 # Kenneth Albanowski <kjahds@kjahds.com>
821 # -added Charles Bailey's further VMS patches, and -u switch
822 # -added -t switch, with pod2text support
824 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
825 # Kenneth Albanowski <kjahds@kjahds.com>
827 # -added better error recognition (on no found pages, just exit. On
828 # missing nroff/pod2man, just display raw pod.)
829 # -added recursive/case-insensitive matching (thanks, Andreas). This
830 # slows things down a bit, unfortunately. Give a precise name, and
833 # Version 1.01: Tue May 30 14:47:34 EDT 1995
834 # Andy Dougherty <doughera@lafcol.lafayette.edu>
835 # -added pod documentation.
836 # -added PATH searching.
837 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
843 # Cache directories read during sloppy match
846 close OUT or die "Can't close $file: $!";
847 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
848 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';