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 \$pager;
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';
100 # Erase evidence of previous errors (if any), so exit status is simple.
103 perldoc [options] PageName|ModuleName|ProgramName...
104 perldoc [options] -f BuiltinFunction
105 perldoc [options] -q FAQRegex
108 -h Display this help message
109 -r Recursive search (slow)
111 -t Display pod using pod2text instead of pod2man and nroff
112 (-t is the default on win32)
113 -u Display unformatted pod text
114 -m Display module's file in its entirety
115 -n Specify replacement for nroff
116 -l Display the module's file name
117 -F Arguments are file names, not modules
118 -v Verbosely describe what's going on
119 -X use index if present (looks for pod.idx at $Config{archlib})
120 -q Search the text of questions (not answers) in perlfaq[1-9]
121 -U Run in insecure mode (superuser only)
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',
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:U";
151 print OUT <<"!GET!OPTS!";
153 use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
155 getopts("$getopts") || usage;
158 print OUT <<'!NO!SUBS!';
162 # refuse to run if we should be tainting and aren't
163 # (but regular users deserve protection too, though!)
164 if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0)
165 && !am_taint_checking())
168 my $id = eval { getpwnam("nobody") };
169 $id = eval { getpwnam("nouser") } unless defined $id;
170 $id = -2 unless defined $id;
172 # According to Stevens' APUE and various
173 # (BSD, Solaris, HP-UX) man pages setting
174 # the real uid first and effective uid second
175 # is the way to go if one wants to drop privileges,
176 # because if one changes into an effective uid of
177 # non-zero, one cannot change the real uid any more.
179 # Actually, it gets even messier. There is
180 # a third uid, called the saved uid, and as
181 # long as that is zero, one can get back to
182 # uid of zero. Setting the real-effective *twice*
183 # helps in *most* systems (FreeBSD and Solaris)
184 # but apparently in HP-UX even this doesn't help:
185 # the saved uid stays zero (apparently the only way
186 # in HP-UX to change saved uid is to call setuid()
187 # when the effective uid is zero).
191 $> = $id; # effective uid
193 $> = $id; # effective uid
195 last if !$@ && $< && $>;
197 die "Superuser must not run $0 without security audit and taint checks.\n";
200 $opt_n = "nroff" if !$opt_n;
204 $podidx = "$Config{'archlib'}/pod.idx";
205 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
208 if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
209 usage("only one of -t, -u, -m or -l")
213 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
215 $opt_t = 1 unless $opts;
218 if ($opt_t) { require Pod::Text; import Pod::Text; }
222 @pages = ("perlfunc");
225 @pages = ("perlfaq1" .. "perlfaq9");
231 # Does this look like a module or extension directory?
232 if (-f "Makefile.PL") {
234 # Add ., lib to @INC (if they exist)
235 eval q{ use lib qw(. lib); 1; } or die;
237 # don't add if superuser
238 if ($< && $> && -f "blib") { # don't be looking too hard now!
239 eval q{ use blib; 1 };
240 warn $@ if $@ && $opt_v;
245 my($file, $readit) = @_;
246 return 1 if !$readit && $file =~ /\.pod\z/i;
248 open(TEST,"<", $file) or die "Can't open $file: $!";
251 close(TEST) or die "Can't close $file: $!";
255 close(TEST) or die "Can't close $file: $!";
261 my $path = catfile($dir,$file);
262 return $path if -f $path and -r _;
263 if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
264 # on a case-forgiving file system or if case is important
265 # that is it all we can do
266 warn "Ignored $path: unreadable\n" if -f _;
270 # this is completely wicked. don't mess with $", and if
271 # you do, don't assume / is the dirsep!
275 foreach $p (splitdir $file){
276 my $try = catfile @p, $p;
280 if ( $p eq $global_target) {
281 my $tmp_path = catfile @p;
283 for (@global_found) {
284 $path_f = 1 if $_ eq $tmp_path;
286 push (@global_found, $tmp_path) unless $path_f;
287 print STDERR "Found as @p but directory\n" if $opt_v;
290 elsif (-f _ && -r _) {
294 warn "Ignored $try: unreadable\n";
299 opendir DIR, "@p" or die "opendir @p: $!";
300 while ($cip=readdir(DIR)) {
301 if (lc $cip eq $lcp){
306 closedir DIR or die "closedir @p: $!";
307 return "" unless $found;
309 return "@p" if -f "@p" and -r _;
310 warn "Ignored @p: unreadable\n" if -f _;
319 return "" if length $dir and not -d $dir;
321 return minus_f_nocase($dir,$file);
324 my $path = minus_f_nocase($dir,$file);
325 return $path if length $path and containspod($path);
332 my($recurse,$s,@dirs) = @_;
334 $s = VMS::Filespec::unixify($s) if $Is_VMS;
335 return $s if -f $s && containspod($s);
336 printf STDERR "Looking for $s in @dirs\n" if $opt_v;
340 $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename?
341 for ($i=0; $i<@dirs; $i++) {
343 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
344 if ( (! $opt_m && ( $ret = check_file $dir,"$s.pod"))
345 or ( $ret = check_file $dir,"$s.pm")
346 or ( $ret = check_file $dir,$s)
348 $ret = check_file $dir,"$s.com")
349 or ( $^O eq 'os2' and
350 $ret = check_file $dir,"$s.cmd")
351 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
352 $ret = check_file $dir,"$s.bat")
353 or ( $ret = check_file "$dir/pod","$s.pod")
354 or ( $ret = check_file "$dir/pod",$s)
355 or ( $ret = check_file "$dir/pods","$s.pod")
356 or ( $ret = check_file "$dir/pods",$s)
362 opendir(D,$dir) or die "Can't opendir $dir: $!";
363 my @newdirs = map catfile($dir, $_), grep {
365 not /^auto\z/s and # save time! don't search auto dirs
368 closedir(D) or die "Can't closedir $dir: $!";
369 next unless @newdirs;
371 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
372 print STDERR "Also looking in @newdirs\n" if $opt_v;
373 push(@dirs,@newdirs);
380 my @data = split /\n{2,}/, shift;
381 shift @data while @data and $data[0] !~ /\S/; # Go to header
382 shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
383 pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
384 # 28/Jan/99 perl 5.005, patch 53 1
389 my ($tmp, $no_tty, @pagers) = @_;
391 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
394 print or die "Can't print to stdout: $!";
396 close TMP or die "Can't close while $tmp: $!";
399 # On VMS, quoting prevents logical expansion, and temp files with no
400 # extension get the wrong default extension (such as .LIS for TYPE)
402 $tmp = VMS::Filespec::rmsexpand($tmp, '.') if ($Is_VMS);
403 foreach my $pager (@pagers) {
405 last if system("$pager $tmp") == 0;
407 last if system("$pager \"$tmp\"") == 0;
415 if ($podidx && open(PODIDX, $podidx)) {
416 my $searchfor = catfile split '::';
417 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
421 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
423 close(PODIDX) or die "Can't close $podidx: $!";
426 print STDERR "Searching for $_\n" if $opt_v;
429 push @found, $_ if $opt_m or containspod($_);
432 # We must look both in @INC for library modules and in $bindir
433 # for executables, like h2xs or perldoc itself.
434 my @searchdirs = ($bindir, @INC);
438 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
439 push(@searchdirs,$trn);
441 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
444 push(@searchdirs, grep(-d, split($Config{path_sep},
448 my @files = searchfor(0,$_,@searchdirs);
450 print STDERR "Found as @files\n" if $opt_v;
453 # no match, try recursive search
454 @searchdirs = grep(!/^\.\z/s,@INC);
455 @files= searchfor(1,$_,@searchdirs) if $opt_r;
457 print STDERR "Loosely found as @files\n" if $opt_v;
461 ($opt_m ? "module" : "documentation") . " found for \"$_\".\n";
463 print STDERR "However, try\n";
464 for my $dir (@global_found) {
465 opendir(DIR, $dir) or die "opendir $dir: $!";
466 while (my $file = readdir(DIR)) {
467 next if ($file =~ /^\./s);
468 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
469 print STDERR "\tperldoc $_\::$file\n";
471 closedir DIR or die "closedir $dir: $!";
480 exit ($Is_VMS ? 98962 : 1);
484 print join("\n", @found), "\n";
488 my $lines = $ENV{LINES} || 24;
491 if (! -t STDOUT) { $no_tty = 1 }
492 END { close(STDOUT) || die "Can't close STDOUT: $!" }
495 push @pagers, qw( more< less notepad );
496 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
497 for (@found) { s,/,\\,g }
500 push @pagers, qw( most more less type/page );
503 push @pagers, qw( less.exe more.com< );
504 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
508 unshift @pagers, 'less', 'cmd /c more <';
510 push @pagers, qw( more less pg view cat );
511 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
513 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
516 foreach my $pager (@pagers) {
517 if (system($pager, @found) == 0) {
523 use vmsish qw(status exit);
533 my $perlfunc = shift @found;
534 open(PFUNC, "<", $perlfunc)
535 or die("Can't open $perlfunc: $!");
537 # Functions like -r, -e, etc. are listed under `-X'.
538 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
544 last if /^=head2 Alphabetical Listing of Perl Functions/;
547 # Look for our function
551 if (/^=item\s+\Q$search_string\E\b/o) {
555 last if $found > 1 and not $inlist;
565 ++$found if /^\w/; # found descriptive text
568 die "No documentation for perl function `$opt_f' found\n";
570 close PFUNC or die "Can't open $perlfunc: $!";
574 local @ARGV = @found; # I'm lazy, sue me.
577 my $rx = eval { qr/$opt_q/ } or die <<EOD;
578 Invalid regular expression '$opt_q' given as -q pattern:
580 Did you mean \\Q$opt_q ?
584 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
587 if (/^=head2\s+.*(?:$opt_q)/oi) {
589 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
591 elsif (/^=head[12]/) {
598 die("No documentation for perl FAQ keyword `$opt_q' found\n");
604 my ($tmpfd, $tmp) = File::Temp::tempfile(UNLINK => 1);
609 my ($buffd, $buffer) = File::Temp::tempfile(UNLINK => 1);
610 print $buffd "=over 8\n\n";
611 print $buffd @pod or die "Can't print $buffer: $!";
612 print $buffd "=back\n";
613 close $buffd or die "Can't close $buffer: $!";
623 Pod::Text->new()->parse_from_file($file, $tmpfd);
626 my $cmd = catfile($bindir, $pod2man) . " --lax $file | $opt_n -man";
627 $cmd .= " | col -x" if $^O =~ /hpux/;
629 $rslt = filter_nroff($rslt) if $filter;
630 unless (($err = $?)) {
632 or die "Can't print $tmp: $!";
635 if ($opt_u or $err) {
636 open(IN,"<", $file) or die("Can't open $file: $!");
640 $cut = $1 eq 'cut' if /^=(\w+)/;
643 or die "Can't print $tmp: $!";
645 close IN or die "Can't close $file: $!";
649 or die "Can't close $tmp: $!";
650 page($tmp, $no_tty, @pagers);
656 my $nada = substr($arg, 0, 0); # zero-length
657 local $@; # preserve caller's version
658 eval { eval "# $nada" };
659 return length($@) != 0;
662 sub am_taint_checking {
663 my($k,$v) = each %ENV;
664 return is_tainted($v);
672 perldoc - Look up Perl documentation in pod format.
676 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
678 B<perldoc> B<-f> BuiltinFunction
680 B<perldoc> B<-q> FAQ Keyword
684 I<perldoc> looks up a piece of documentation in .pod format that is embedded
685 in the perl installation tree or in a perl script, and displays it via
686 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
687 C<col -x> will be used.) This is primarily used for the documentation for
688 the perl library modules.
690 Your system may also have man pages installed for those modules, in
691 which case you can probably just use the man(1) command.
693 If you are looking for a table of contents to the Perl library modules
694 documentation, see the L<perltoc> page.
702 Prints out a brief help message.
706 Describes search for the item in detail.
708 =item B<-t> text output
710 Display docs using plain text converter, instead of nroff. This may be faster,
711 but it won't look as nice.
713 =item B<-u> unformatted
715 Find docs only; skip reformatting by pod2*
719 Display the entire module: both code and unformatted pod documentation.
720 This may be useful if the docs don't explain a function in the detail
721 you need, and you'd like to inspect the code directly; perldoc will find
722 the file for you and simply hand it off for display.
724 =item B<-l> file name only
726 Display the file name of the module found.
728 =item B<-F> file names
730 Consider arguments as file names, no search in directories will be performed.
734 The B<-f> option followed by the name of a perl built in function will
735 extract the documentation of this function from L<perlfunc>.
739 The B<-q> option takes a regular expression as an argument. It will search
740 the question headings in perlfaq[1-9] and print the entries matching
741 the regular expression.
743 =item B<-X> use an index if present
745 The B<-X> option looks for an entry whose basename matches the name given on the
746 command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
747 contain fully qualified filenames, one per line.
749 =item B<-U> run insecurely
751 Because B<perldoc> does not run properly tainted, and is known to
752 have security issues, it will not normally execute as the superuser.
753 If you use the B<-U> flag, it will do so, but only after setting
754 the effective and real IDs to nobody's or nouser's account, or -2
755 if unavailable. If it cannot relinquish its privileges, it will not
758 =item B<PageName|ModuleName|ProgramName>
760 The item you want to look up. Nested modules (such as C<File::Basename>)
761 are specified either as C<File::Basename> or C<File/Basename>. You may also
762 give a descriptive name of a page, such as C<perlfunc>.
768 Any switches in the C<PERLDOC> environment variable will be used before the
769 command line arguments. C<perldoc> also searches directories
770 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
771 defined) and C<PATH> environment variables.
772 (The latter is so that embedded pods for executables, such as
773 C<perldoc> itself, are available.) C<perldoc> will use, in order of
774 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
775 C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
776 used if C<perldoc> was told to display plain text or unformatted pod.)
778 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
782 This is perldoc v2.03.
786 Kenneth Albanowski <kjahds@kjahds.com>
788 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
794 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
795 # Hugo van der Sanden <hv@crypt0.demon.co.uk>
796 # don't die when 'use blib' fails
797 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
798 # Tom Christiansen <tchrist@perl.com>
799 # Added -U insecurity option
800 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
801 # Tom Christiansen <tchrist@perl.com>, querulously.
802 # Security and correctness patches.
803 # What a twisted bit of distasteful spaghetti code.
805 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
806 # Charles Wilson <cwilson@ece.gatech.edu>
807 # changed /pod/ directory to /pods/ for cygwin
808 # to support cygwin/win32
809 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
810 # Robin Barker <rmb1@cise.npl.co.uk>
811 # -strict, -w cleanups
812 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
813 # Gurusamy Sarathy <gsar@activestate.com>
814 # -doc tweaks for -F and -X options
815 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
816 # Gurusamy Sarathy <gsar@activestate.com>
817 # -various fixes for win32
818 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
819 # Kenneth Albanowski <kjahds@kjahds.com>
820 # -added Charles Bailey's further VMS patches, and -u switch
821 # -added -t switch, with pod2text support
823 # Version 1.10: Thu Nov 9 07:23:47 EST 1995
824 # Kenneth Albanowski <kjahds@kjahds.com>
826 # -added better error recognition (on no found pages, just exit. On
827 # missing nroff/pod2man, just display raw pod.)
828 # -added recursive/case-insensitive matching (thanks, Andreas). This
829 # slows things down a bit, unfortunately. Give a precise name, and
832 # Version 1.01: Tue May 30 14:47:34 EDT 1995
833 # Andy Dougherty <doughera@lafcol.lafayette.edu>
834 # -added pod documentation.
835 # -added PATH searching.
836 # -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
842 # Cache directories read during sloppy match
845 close OUT or die "Can't close $file: $!";
846 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
847 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';