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', the partial name of a module, like `info', or
128 `makemaker', or the name of a program, like `perldoc'.
131 is the name of a perl function. Will extract documentation from
135 is a regex. Will search perlfaq[1-9] for and extract any
136 questions that match.
138 Any switches in the PERLDOC environment variable will be used before the
139 command line arguments. The optional pod index file contains a list of
140 filenames, one per line.
145 if (defined $ENV{"PERLDOC"}) {
146 require Text::ParseWords;
147 unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
151 my $getopts = "mhtluvriFf:Xq:n:U";
152 print OUT <<"!GET!OPTS!";
154 use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
156 getopts("$getopts") || usage;
159 print OUT <<'!NO!SUBS!';
163 # refuse to run if we should be tainting and aren't
164 # (but regular users deserve protection too, though!)
165 if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0)
166 && !am_taint_checking())
169 my $id = eval { getpwnam("nobody") };
170 $id = eval { getpwnam("nouser") } unless defined $id;
171 $id = -2 unless defined $id;
173 # According to Stevens' APUE and various
174 # (BSD, Solaris, HP-UX) man pages setting
175 # the real uid first and effective uid second
176 # is the way to go if one wants to drop privileges,
177 # because if one changes into an effective uid of
178 # non-zero, one cannot change the real uid any more.
180 # Actually, it gets even messier. There is
181 # a third uid, called the saved uid, and as
182 # long as that is zero, one can get back to
183 # uid of zero. Setting the real-effective *twice*
184 # helps in *most* systems (FreeBSD and Solaris)
185 # but apparently in HP-UX even this doesn't help:
186 # the saved uid stays zero (apparently the only way
187 # in HP-UX to change saved uid is to call setuid()
188 # when the effective uid is zero).
192 $> = $id; # effective uid
194 $> = $id; # effective uid
196 last if !$@ && $< && $>;
198 die "Superuser must not run $0 without security audit and taint checks.\n";
201 $opt_n = "nroff" if !$opt_n;
205 $podidx = "$Config{'archlib'}/pod.idx";
206 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
209 if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
210 usage("only one of -t, -u, -m or -l")
214 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
216 $opt_t = 1 unless $opts;
219 if ($opt_t) { require Pod::Text; import Pod::Text; }
223 @pages = ("perlfunc");
226 @pages = ("perlfaq1" .. "perlfaq9");
232 # Does this look like a module or extension directory?
233 if (-f "Makefile.PL") {
235 # Add ., lib to @INC (if they exist)
236 eval q{ use lib qw(. lib); 1; } or die;
238 # don't add if superuser
239 if ($< && $> && -f "blib") { # don't be looking too hard now!
240 eval q{ use blib; 1 };
241 warn $@ if $@ && $opt_v;
246 my($file, $readit) = @_;
247 return 1 if !$readit && $file =~ /\.pod\z/i;
249 open(TEST,"<", $file) or die "Can't open $file: $!";
252 close(TEST) or die "Can't close $file: $!";
256 close(TEST) or die "Can't close $file: $!";
262 my $path = catfile($dir,$file);
263 return $path if -f $path and -r _;
264 if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
265 # on a case-forgiving file system or if case is important
266 # that is it all we can do
267 warn "Ignored $path: unreadable\n" if -f _;
271 # this is completely wicked. don't mess with $", and if
272 # you do, don't assume / is the dirsep!
276 foreach $p (splitdir $file){
277 my $try = catfile @p, $p;
281 if ( $p eq $global_target) {
282 my $tmp_path = catfile @p;
284 for (@global_found) {
285 $path_f = 1 if $_ eq $tmp_path;
287 push (@global_found, $tmp_path) unless $path_f;
288 print STDERR "Found as @p but directory\n" if $opt_v;
291 elsif (-f _ && -r _) {
295 warn "Ignored $try: unreadable\n";
300 opendir DIR, "@p" or die "opendir @p: $!";
301 while ($cip=readdir(DIR)) {
302 if (lc $cip eq $lcp){
307 closedir DIR or die "closedir @p: $!";
308 return "" unless $found;
310 return "@p" if -f "@p" and -r _;
311 warn "Ignored @p: unreadable\n" if -f _;
320 return "" if length $dir and not -d $dir;
322 return minus_f_nocase($dir,$file);
325 my $path = minus_f_nocase($dir,$file);
326 return $path if length $path and containspod($path);
333 my($recurse,$s,@dirs) = @_;
335 $s = VMS::Filespec::unixify($s) if $Is_VMS;
336 return $s if -f $s && containspod($s);
337 printf STDERR "Looking for $s in @dirs\n" if $opt_v;
341 $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename?
342 for ($i=0; $i<@dirs; $i++) {
344 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
345 if ( (! $opt_m && ( $ret = check_file $dir,"$s.pod"))
346 or ( $ret = check_file $dir,"$s.pm")
347 or ( $ret = check_file $dir,$s)
349 $ret = check_file $dir,"$s.com")
350 or ( $^O eq 'os2' and
351 $ret = check_file $dir,"$s.cmd")
352 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
353 $ret = check_file $dir,"$s.bat")
354 or ( $ret = check_file "$dir/pod","$s.pod")
355 or ( $ret = check_file "$dir/pod",$s)
356 or ( $ret = check_file "$dir/pods","$s.pod")
357 or ( $ret = check_file "$dir/pods",$s)
363 opendir(D,$dir) or die "Can't opendir $dir: $!";
364 my @newdirs = map catfile($dir, $_), grep {
366 not /^auto\z/s and # save time! don't search auto dirs
369 closedir(D) or die "Can't closedir $dir: $!";
370 next unless @newdirs;
372 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
373 print STDERR "Also looking in @newdirs\n" if $opt_v;
374 push(@dirs,@newdirs);
381 my @data = split /\n{2,}/, shift;
382 shift @data while @data and $data[0] !~ /\S/; # Go to header
383 shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
384 pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
385 # 28/Jan/99 perl 5.005, patch 53 1
390 my ($tmp, $no_tty, @pagers) = @_;
392 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
395 print or die "Can't print to stdout: $!";
397 close TMP or die "Can't close while $tmp: $!";
400 # On VMS, quoting prevents logical expansion, and temp files with no
401 # extension get the wrong default extension (such as .LIS for TYPE)
403 $tmp = VMS::Filespec::rmsexpand($tmp, '.') if ($Is_VMS);
404 foreach my $pager (@pagers) {
406 last if system("$pager $tmp") == 0;
408 last if system("$pager \"$tmp\"") == 0;
416 if ($podidx && open(PODIDX, $podidx)) {
417 my $searchfor = catfile split '::';
418 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
422 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
424 close(PODIDX) or die "Can't close $podidx: $!";
427 print STDERR "Searching for $_\n" if $opt_v;
430 push @found, $_ if $opt_m or containspod($_);
433 # We must look both in @INC for library modules and in $bindir
434 # for executables, like h2xs or perldoc itself.
435 my @searchdirs = ($bindir, @INC);
439 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
440 push(@searchdirs,$trn);
442 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
445 push(@searchdirs, grep(-d, split($Config{path_sep},
449 my @files = searchfor(0,$_,@searchdirs);
451 print STDERR "Found as @files\n" if $opt_v;
454 # no match, try recursive search
455 @searchdirs = grep(!/^\.\z/s,@INC);
456 @files= searchfor(1,$_,@searchdirs) if $opt_r;
458 print STDERR "Loosely found as @files\n" if $opt_v;
462 ($opt_m ? "module" : "documentation") . " found for \"$_\".\n";
464 print STDERR "However, try\n";
465 for my $dir (@global_found) {
466 opendir(DIR, $dir) or die "opendir $dir: $!";
467 while (my $file = readdir(DIR)) {
468 next if ($file =~ /^\./s);
469 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
470 print STDERR "\tperldoc $_\::$file\n";
472 closedir DIR or die "closedir $dir: $!";
481 exit ($Is_VMS ? 98962 : 1);
485 print join("\n", @found), "\n";
489 my $lines = $ENV{LINES} || 24;
492 if (! -t STDOUT) { $no_tty = 1 }
493 END { close(STDOUT) || die "Can't close STDOUT: $!" }
496 push @pagers, qw( more< less notepad );
497 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
498 for (@found) { s,/,\\,g }
501 push @pagers, qw( most more less type/page );
504 push @pagers, qw( less.exe more.com< );
505 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
509 unshift @pagers, 'less', 'cmd /c more <';
511 push @pagers, qw( more less pg view cat );
512 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
514 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
517 foreach my $pager (@pagers) {
518 if (system($pager, @found) == 0) {
524 use vmsish qw(status exit);
534 my $perlfunc = shift @found;
535 open(PFUNC, "<", $perlfunc)
536 or die("Can't open $perlfunc: $!");
538 # Functions like -r, -e, etc. are listed under `-X'.
539 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
545 last if /^=head2 Alphabetical Listing of Perl Functions/;
548 # Look for our function
552 if (/^=item\s+\Q$search_string\E\b/o) {
556 last if $found > 1 and not $inlist;
566 ++$found if /^\w/; # found descriptive text
569 die "No documentation for perl function `$opt_f' found\n";
571 close PFUNC or die "Can't open $perlfunc: $!";
575 local @ARGV = @found; # I'm lazy, sue me.
578 my $rx = eval { qr/$opt_q/ } or die <<EOD;
579 Invalid regular expression '$opt_q' given as -q pattern:
581 Did you mean \\Q$opt_q ?
585 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
588 if (/^=head2\s+.*(?:$opt_q)/oi) {
590 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
592 elsif (/^=head[12]/) {
599 die("No documentation for perl FAQ keyword `$opt_q' found\n");
605 my ($tmpfd, $tmp) = File::Temp::tempfile(UNLINK => 1);
610 my ($buffd, $buffer) = File::Temp::tempfile(UNLINK => 1);
611 print $buffd "=over 8\n\n";
612 print $buffd @pod or die "Can't print $buffer: $!";
613 print $buffd "=back\n";
614 close $buffd or die "Can't close $buffer: $!";
624 Pod::Text->new()->parse_from_file($file, $tmpfd);
627 my $cmd = catfile($bindir, $pod2man) . " --lax $file | $opt_n -man";
628 $cmd .= " | col -x" if $^O =~ /hpux/;
630 $rslt = filter_nroff($rslt) if $filter;
631 unless (($err = $?)) {
633 or die "Can't print $tmp: $!";
636 if ($opt_u or $err) {
637 open(IN,"<", $file) or die("Can't open $file: $!");
641 $cut = $1 eq 'cut' if /^=(\w+)/;
644 or die "Can't print $tmp: $!";
646 close IN or die "Can't close $file: $!";
650 or die "Can't close $tmp: $!";
651 page($tmp, $no_tty, @pagers);
657 my $nada = substr($arg, 0, 0); # zero-length
658 local $@; # preserve caller's version
659 eval { eval "# $nada" };
660 return length($@) != 0;
663 sub am_taint_checking {
664 my($k,$v) = each %ENV;
665 return is_tainted($v);
673 perldoc - Look up Perl documentation in pod format.
677 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
679 B<perldoc> B<-f> BuiltinFunction
681 B<perldoc> B<-q> FAQ Keyword
685 I<perldoc> looks up a piece of documentation in .pod format that is embedded
686 in the perl installation tree or in a perl script, and displays it via
687 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
688 C<col -x> will be used.) This is primarily used for the documentation for
689 the perl library modules.
691 Your system may also have man pages installed for those modules, in
692 which case you can probably just use the man(1) command.
700 Prints out a brief help message.
704 Describes search for the item in detail.
706 =item B<-t> text output
708 Display docs using plain text converter, instead of nroff. This may be faster,
709 but it won't look as nice.
711 =item B<-u> unformatted
713 Find docs only; skip reformatting by pod2*
717 Display the entire module: both code and unformatted pod documentation.
718 This may be useful if the docs don't explain a function in the detail
719 you need, and you'd like to inspect the code directly; perldoc will find
720 the file for you and simply hand it off for display.
722 =item B<-l> file name only
724 Display the file name of the module found.
726 =item B<-F> file names
728 Consider arguments as file names, no search in directories will be performed.
732 The B<-f> option followed by the name of a perl built in function will
733 extract the documentation of this function from L<perlfunc>.
737 The B<-q> option takes a regular expression as an argument. It will search
738 the question headings in perlfaq[1-9] and print the entries matching
739 the regular expression.
741 =item B<-X> use an index if present
743 The B<-X> option looks for an entry whose basename matches the name given on the
744 command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
745 contain fully qualified filenames, one per line.
747 =item B<-U> run insecurely
749 Because B<perldoc> does not run properly tainted, and is known to
750 have security issues, it will not normally execute as the superuser.
751 If you use the B<-U> flag, it will do so, but only after setting
752 the effective and real IDs to nobody's or nouser's account, or -2
753 if unavailable. If it cannot relinquish its privileges, it will not
756 =item B<PageName|ModuleName|ProgramName>
758 The item you want to look up. Nested modules (such as C<File::Basename>)
759 are specified either as C<File::Basename> or C<File/Basename>. You may also
760 give a descriptive name of a page, such as C<perlfunc>. You may also give a
761 partial or wrong-case name, such as "basename" for "File::Basename", but
762 this will be slower, if there is more then one page with the same partial
763 name, you will only get the first one.
769 Any switches in the C<PERLDOC> environment variable will be used before the
770 command line arguments. C<perldoc> also searches directories
771 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
772 defined) and C<PATH> environment variables.
773 (The latter is so that embedded pods for executables, such as
774 C<perldoc> itself, are available.) C<perldoc> will use, in order of
775 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
776 C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
777 used if C<perldoc> was told to display plain text or unformatted pod.)
779 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
783 This is perldoc v2.03.
787 Kenneth Albanowski <kjahds@kjahds.com>
789 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
795 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
796 # Hugo van der Sanden <hv@crypt0.demon.co.uk>
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 ':';