This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH: perl@11564] introducing perlivp
[perl5.git] / utils / perldoc.PL
CommitLineData
4633a7c4
LW
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4 6
85880f03
PP
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
4633a7c4 11# $startperl
85880f03 12# to ensure Configure will look for $Config{startperl}.
4633a7c4
LW
13
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.
8a5546a1 16$origdir = cwd;
44a8e56a
PP
17chdir dirname($0);
18$file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4
LW
20
21open OUT,">$file" or die "Can't create $file: $!";
22
23print "Extracting $file (with variable substitutions)\n";
24
25# In this section, perl variables will be expanded during extraction.
26# You can use $Config{...} to use Configure variables.
27
85880f03 28print OUT <<"!GROK!THIS!";
5f05dabc
PP
29$Config{startperl}
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
c5ae3962 31 if 0;
55497cff 32
8167b455 33use warnings;
c5ae3962 34use strict;
8167b455
GS
35
36# make sure creat()s are neither too much nor too little
37INIT { eval { umask(0077) } } # doubtless someone has no mask
38
ed6d8ea1
JH
39(my \$pager = <<'/../') =~ s/\\s*\\z//;
40$Config{pager}
41/../
c5ae3962 42my \@pagers = ();
ed6d8ea1
JH
43push \@pagers, \$pager if -x \$pager;
44
45(my \$bindir = <<'/../') =~ s/\\s*\\z//;
46$Config{scriptdir}
47/../
8167b455 48
4633a7c4
LW
49!GROK!THIS!
50
51# In the following, perl variables are not expanded during extraction.
52
53print OUT <<'!NO!SUBS!';
54
8167b455
GS
55use Fcntl; # for sysopen
56use Getopt::Std;
57use Config '%Config';
14178d34 58use File::Spec::Functions qw(catfile splitdir);
8167b455 59
4633a7c4
LW
60#
61# Perldoc revision #1 -- look up a piece of documentation in .pod format that
62# is embedded in the perl installation tree.
63#
8167b455 64# This is not to be confused with Tom Christiansen's perlman, which is a
4633a7c4
LW
65# man replacement, written in perl. This perldoc is strictly for reading
66# the perl manuals, though it too is written in perl.
8167b455
GS
67#
68# Massive security and correctness patches applied to this
69# noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000
4633a7c4 70
febd60db 71if (@ARGV<1) {
c5ae3962 72 my $me = $0; # Editing $0 is unportable
fb73857a 73 $me =~ s,.*/,,;
4633a7c4 74 die <<EOF;
a85d71bc 75Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName
0b166b66 76 $me -f PerlFunc
a3cb178b 77 $me -q FAQKeywords
4633a7c4 78
89b8affa 79The -h option prints more help. Also try "perldoc perldoc" to get
54884818 80acquainted with the system.
4633a7c4
LW
81EOF
82}
83
c5ae3962
RB
84my @global_found = ();
85my $global_target = "";
fb73857a 86
c5ae3962
RB
87my $Is_VMS = $^O eq 'VMS';
88my $Is_MSWin32 = $^O eq 'MSWin32';
89my $Is_Dos = $^O eq 'dos';
6dbadf30 90my $Is_OS2 = $^O eq 'os2';
4633a7c4
LW
91
92sub usage{
ff0cee69
PP
93 warn "@_\n" if @_;
94 # Erase evidence of previous errors (if any), so exit status is simple.
95 $! = 0;
4633a7c4 96 die <<EOF;
31bdbec1
GA
97perldoc [options] PageName|ModuleName|ProgramName...
98perldoc [options] -f BuiltinFunction
a3cb178b 99perldoc [options] -q FAQRegex
31bdbec1
GA
100
101Options:
137443ea 102 -h Display this help message
5315ba28 103 -r Recursive search (slow)
febd60db 104 -i Ignore case
137443ea
PP
105 -t Display pod using pod2text instead of pod2man and nroff
106 (-t is the default on win32)
85880f03 107 -u Display unformatted pod text
a3cb178b 108 -m Display module's file in its entirety
a85d71bc 109 -n Specify replacement for nroff
a3cb178b 110 -l Display the module's file name
cce34969 111 -F Arguments are file names, not modules
137443ea 112 -v Verbosely describe what's going on
89b8affa 113 -X use index if present (looks for pod.idx at $Config{archlib})
54ac30b1 114 -q Search the text of questions (not answers) in perlfaq[1-9]
c185d8c4 115 -U Run in insecure mode (superuser only)
a3cb178b 116
4633a7c4 117PageName|ModuleName...
febd60db 118 is the name of a piece of documentation that you want to look at. You
4633a7c4 119 may either give a descriptive name of the page (as in the case of
febd60db
GS
120 `perlfunc') the name of a module, either like `Term::Info',
121 `Term/Info', the partial name of a module, like `info', or
4633a7c4 122 `makemaker', or the name of a program, like `perldoc'.
31bdbec1
GA
123
124BuiltinFunction
125 is the name of a perl function. Will extract documentation from
126 `perlfunc'.
a3cb178b
GS
127
128FAQRegex
129 is a regex. Will search perlfaq[1-9] for and extract any
130 questions that match.
131
febd60db 132Any switches in the PERLDOC environment variable will be used before the
89b8affa
GS
133command line arguments. The optional pod index file contains a list of
134filenames, one per line.
4633a7c4
LW
135
136EOF
137}
138
febd60db 139if (defined $ENV{"PERLDOC"}) {
c5ae3962
RB
140 require Text::ParseWords;
141 unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
142}
143!NO!SUBS!
144
c185d8c4 145my $getopts = "mhtluvriFf:Xq:n:U";
c5ae3962 146print OUT <<"!GET!OPTS!";
4633a7c4 147
c5ae3962 148use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
4633a7c4 149
c5ae3962
RB
150getopts("$getopts") || usage;
151!GET!OPTS!
4633a7c4 152
c5ae3962 153print OUT <<'!NO!SUBS!';
85880f03 154
c5ae3962 155usage if $opt_h;
c185d8c4
GS
156
157# refuse to run if we should be tainting and aren't
158# (but regular users deserve protection too, though!)
6dbadf30 159if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0)
c185d8c4
GS
160 && !am_taint_checking())
161{{
162 if ($opt_U) {
163 my $id = eval { getpwnam("nobody") };
164 $id = eval { getpwnam("nouser") } unless defined $id;
165 $id = -2 unless defined $id;
166 eval {
167 $> = $id; # must do this one first!
168 $< = $id;
169 };
170 last if !$@ && $< && $>;
171 }
172 die "Superuser must not run $0 without security audit and taint checks.\n";
173}}
174
a85d71bc 175$opt_n = "nroff" if !$opt_n;
4633a7c4 176
c5ae3962 177my $podidx;
febd60db 178if ($opt_X) {
0d3da1c8
RB
179 $podidx = "$Config{'archlib'}/pod.idx";
180 $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
181}
89b8affa 182
8167b455 183if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
137443ea 184 usage("only one of -t, -u, -m or -l")
febd60db 185}
d49321e7
GS
186elsif ($Is_MSWin32
187 || $Is_Dos
8167b455 188 || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
d49321e7 189{
8167b455 190 $opt_t = 1 unless $opts;
137443ea 191}
4633a7c4 192
7eda7aea 193if ($opt_t) { require Pod::Text; import Pod::Text; }
4633a7c4 194
c5ae3962 195my @pages;
31bdbec1 196if ($opt_f) {
febd60db
GS
197 @pages = ("perlfunc");
198}
199elsif ($opt_q) {
200 @pages = ("perlfaq1" .. "perlfaq9");
201}
202else {
203 @pages = @ARGV;
31bdbec1
GA
204}
205
fb73857a
PP
206# Does this look like a module or extension directory?
207if (-f "Makefile.PL") {
8167b455
GS
208
209 # Add ., lib to @INC (if they exist)
210 eval q{ use lib qw(. lib); 1; } or die;
211
212 # don't add if superuser
aafed681 213 if ($< && $> && -f "blib") { # don't be looking too hard now!
6d0835e5
GS
214 eval q{ use blib; 1 };
215 warn $@ if $@ && $opt_v;
8167b455 216 }
fb73857a
PP
217}
218
4633a7c4 219sub containspod {
fb73857a 220 my($file, $readit) = @_;
8167b455 221 return 1 if !$readit && $file =~ /\.pod\z/i;
fb73857a 222 local($_);
8167b455 223 open(TEST,"<", $file) or die "Can't open $file: $!";
febd60db
GS
224 while (<TEST>) {
225 if (/^=head/) {
8167b455 226 close(TEST) or die "Can't close $file: $!";
fb73857a 227 return 1;
4633a7c4 228 }
fb73857a 229 }
8167b455 230 close(TEST) or die "Can't close $file: $!";
fb73857a 231 return 0;
4633a7c4
LW
232}
233
84902520 234sub minus_f_nocase {
5315ba28 235 my($dir,$file) = @_;
14178d34 236 my $path = catfile($dir,$file);
5315ba28
NIS
237 return $path if -f $path and -r _;
238 if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
febd60db 239 # on a case-forgiving file system or if case is important
5315ba28 240 # that is it all we can do
0cf744f2 241 warn "Ignored $path: unreadable\n" if -f _;
fb73857a 242 return '';
84902520 243 }
4633a7c4 244 local *DIR;
8167b455
GS
245 # this is completely wicked. don't mess with $", and if
246 # you do, don't assume / is the dirsep!
4633a7c4 247 local($")="/";
5315ba28
NIS
248 my @p = ($dir);
249 my($p,$cip);
14178d34
GS
250 foreach $p (splitdir $file){
251 my $try = catfile @p, $p;
fb73857a 252 stat $try;
febd60db 253 if (-d _) {
4633a7c4 254 push @p, $p;
fb73857a 255 if ( $p eq $global_target) {
14178d34 256 my $tmp_path = catfile @p;
fb73857a
PP
257 my $path_f = 0;
258 for (@global_found) {
259 $path_f = 1 if $_ eq $tmp_path;
260 }
261 push (@global_found, $tmp_path) unless $path_f;
262 print STDERR "Found as @p but directory\n" if $opt_v;
263 }
febd60db
GS
264 }
265 elsif (-f _ && -r _) {
fb73857a 266 return $try;
febd60db
GS
267 }
268 elsif (-f _) {
fb73857a 269 warn "Ignored $try: unreadable\n";
febd60db 270 }
8167b455 271 elsif (-d "@p") {
4633a7c4
LW
272 my $found=0;
273 my $lcp = lc $p;
8167b455 274 opendir DIR, "@p" or die "opendir @p: $!";
4633a7c4
LW
275 while ($cip=readdir(DIR)) {
276 if (lc $cip eq $lcp){
277 $found++;
278 last;
279 }
280 }
8167b455 281 closedir DIR or die "closedir @p: $!";
4633a7c4
LW
282 return "" unless $found;
283 push @p, $cip;
fb73857a 284 return "@p" if -f "@p" and -r _;
0cf744f2 285 warn "Ignored @p: unreadable\n" if -f _;
4633a7c4
LW
286 }
287 }
5315ba28 288 return "";
fb73857a 289}
eb459f90 290
fb73857a
PP
291
292sub check_file {
5315ba28 293 my($dir,$file) = @_;
7ec2cea4 294 return "" if length $dir and not -d $dir;
3046dd9f 295 if ($opt_m) {
5315ba28 296 return minus_f_nocase($dir,$file);
febd60db
GS
297 }
298 else {
5315ba28 299 my $path = minus_f_nocase($dir,$file);
249edfdf 300 return $path if length $path and containspod($path);
3046dd9f 301 }
5315ba28 302 return "";
fb73857a
PP
303}
304
305
306sub searchfor {
307 my($recurse,$s,@dirs) = @_;
308 $s =~ s!::!/!g;
309 $s = VMS::Filespec::unixify($s) if $Is_VMS;
310 return $s if -f $s && containspod($s);
311 printf STDERR "Looking for $s in @dirs\n" if $opt_v;
312 my $ret;
313 my $i;
314 my $dir;
14178d34 315 $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename?
fb73857a
PP
316 for ($i=0; $i<@dirs; $i++) {
317 $dir = $dirs[$i];
8167b455 318 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
5315ba28
NIS
319 if ( ( $ret = check_file $dir,"$s.pod")
320 or ( $ret = check_file $dir,"$s.pm")
321 or ( $ret = check_file $dir,$s)
fb73857a 322 or ( $Is_VMS and
5315ba28 323 $ret = check_file $dir,"$s.com")
febd60db 324 or ( $^O eq 'os2' and
5315ba28 325 $ret = check_file $dir,"$s.cmd")
0151c6ef 326 or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
5315ba28
NIS
327 $ret = check_file $dir,"$s.bat")
328 or ( $ret = check_file "$dir/pod","$s.pod")
329 or ( $ret = check_file "$dir/pod",$s)
7ec2cea4
GS
330 or ( $ret = check_file "$dir/pods","$s.pod")
331 or ( $ret = check_file "$dir/pods",$s)
fb73857a
PP
332 ) {
333 return $ret;
334 }
eb459f90 335
fb73857a 336 if ($recurse) {
8167b455 337 opendir(D,$dir) or die "Can't opendir $dir: $!";
14178d34 338 my @newdirs = map catfile($dir, $_), grep {
8167b455
GS
339 not /^\.\.?\z/s and
340 not /^auto\z/s and # save time! don't search auto dirs
14178d34 341 -d catfile($dir, $_)
fb73857a 342 } readdir D;
8167b455 343 closedir(D) or die "Can't closedir $dir: $!";
fb73857a 344 next unless @newdirs;
8167b455
GS
345 # what a wicked map!
346 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
fb73857a
PP
347 print STDERR "Also looking in @newdirs\n" if $opt_v;
348 push(@dirs,@newdirs);
349 }
350 }
351 return ();
352}
4633a7c4 353
eb459f90
IZ
354sub filter_nroff {
355 my @data = split /\n{2,}/, shift;
356 shift @data while @data and $data[0] !~ /\S/; # Go to header
357 shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
358 pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
359 # 28/Jan/99 perl 5.005, patch 53 1
360 join "\n\n", @data;
361}
362
febd60db
GS
363sub printout {
364 my ($file, $tmp, $filter) = @_;
365 my $err;
366
367 if ($opt_t) {
8167b455
GS
368 # why was this append?
369 sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
370 or die ("Can't open $tmp: $!");
94e33e97 371 Pod::Text->new()->parse_from_file($file,\*OUT);
8167b455 372 close OUT or die "can't close $tmp: $!";
febd60db
GS
373 }
374 elsif (not $opt_u) {
14178d34 375 my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man";
febd60db
GS
376 $cmd .= " | col -x" if $^O =~ /hpux/;
377 my $rslt = `$cmd`;
378 $rslt = filter_nroff($rslt) if $filter;
379 unless (($err = $?)) {
8167b455
GS
380 # why was this append?
381 sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
382 or die "Can't open $tmp: $!";
383 print TMP $rslt
384 or die "Can't print $tmp: $!";
385 close TMP
386 or die "Can't close $tmp: $!";
febd60db
GS
387 }
388 }
8167b455
GS
389 if ($opt_u or $err or -z $tmp) { # XXX: race with -z
390 # why was this append?
391 sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
392 or die "Can't open $tmp: $!";
393 open(IN,"<", $file) or die("Can't open $file: $!");
febd60db 394 my $cut = 1;
8167b455 395 local $_;
febd60db
GS
396 while (<IN>) {
397 $cut = $1 eq 'cut' if /^=(\w+)/;
398 next if $cut;
8167b455
GS
399 print OUT
400 or die "Can't print $tmp: $!";
febd60db 401 }
8167b455
GS
402 close IN or die "Can't close $file: $!";
403 close OUT or die "Can't close $tmp: $!";
febd60db
GS
404 }
405}
406
407sub page {
408 my ($tmp, $no_tty, @pagers) = @_;
409 if ($no_tty) {
8167b455
GS
410 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
411 local $_;
412 while (<TMP>) {
413 print or die "Can't print to stdout: $!";
414 }
415 close TMP or die "Can't close while $tmp: $!";
febd60db
GS
416 }
417 else {
418 foreach my $pager (@pagers) {
e0d5f7b4
CB
419 if ($Is_VMS) {
420 last if system("$pager $tmp") == 0; # quoting prevents logical expansion
421 } else {
a79ff105 422 last if system("$pager \"$tmp\"") == 0;
e0d5f7b4 423 }
febd60db
GS
424 }
425 }
426}
427
428sub cleanup {
429 my @files = @_;
430 for (@files) {
8167b455
GS
431 if ($Is_VMS) {
432 1 while unlink($_); # XXX: expect failure
433 } else {
434 unlink($_); # or die "Can't unlink $_: $!";
435 }
febd60db
GS
436 }
437}
438
c5ae3962 439my @found;
4633a7c4 440foreach (@pages) {
febd60db 441 if ($podidx && open(PODIDX, $podidx)) {
14178d34 442 my $searchfor = catfile split '::';
febd60db 443 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
8167b455 444 local $_;
febd60db
GS
445 while (<PODIDX>) {
446 chomp;
8167b455 447 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
cce34969 448 }
8167b455 449 close(PODIDX) or die "Can't close $podidx: $!";
febd60db
GS
450 next;
451 }
452 print STDERR "Searching for $_\n" if $opt_v;
a2d48270 453 # We must look both in @INC for library modules and in $bindir
febd60db 454 # for executables, like h2xs or perldoc itself.
a2d48270 455 my @searchdirs = ($bindir, @INC);
febd60db
GS
456 if ($opt_F) {
457 next unless -r;
458 push @found, $_ if $opt_m or containspod($_);
459 next;
460 }
461 unless ($opt_m) {
462 if ($Is_VMS) {
463 my($i,$trn);
464 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
465 push(@searchdirs,$trn);
7eda7aea 466 }
febd60db
GS
467 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
468 }
469 else {
470 push(@searchdirs, grep(-d, split($Config{path_sep},
471 $ENV{'PATH'})));
85880f03 472 }
febd60db
GS
473 }
474 my @files = searchfor(0,$_,@searchdirs);
475 if (@files) {
476 print STDERR "Found as @files\n" if $opt_v;
477 }
478 else {
479 # no match, try recursive search
8167b455 480 @searchdirs = grep(!/^\.\z/s,@INC);
febd60db
GS
481 @files= searchfor(1,$_,@searchdirs) if $opt_r;
482 if (@files) {
483 print STDERR "Loosely found as @files\n" if $opt_v;
484 }
485 else {
486 print STDERR "No documentation found for \"$_\".\n";
487 if (@global_found) {
488 print STDERR "However, try\n";
489 for my $dir (@global_found) {
8167b455 490 opendir(DIR, $dir) or die "opendir $dir: $!";
febd60db 491 while (my $file = readdir(DIR)) {
8167b455
GS
492 next if ($file =~ /^\./s);
493 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
febd60db
GS
494 print STDERR "\tperldoc $_\::$file\n";
495 }
8167b455 496 closedir DIR or die "closedir $dir: $!";
4633a7c4 497 }
febd60db 498 }
4633a7c4 499 }
febd60db
GS
500 }
501 push(@found,@files);
4633a7c4
LW
502}
503
febd60db
GS
504if (!@found) {
505 exit ($Is_VMS ? 98962 : 1);
4633a7c4
LW
506}
507
44a8e56a
PP
508if ($opt_l) {
509 print join("\n", @found), "\n";
510 exit;
511}
512
877622ba
RB
513my $lines = $ENV{LINES} || 24;
514
c5ae3962 515my $no_tty;
febd60db 516if (! -t STDOUT) { $no_tty = 1 }
8167b455 517END { close(STDOUT) || die "Can't close STDOUT: $!" }
febd60db
GS
518
519# until here we could simply exit or die
520# now we create temporary files that we have to clean up
521# namely $tmp, $buffer
8167b455 522# that's because you did it wrong, should be descriptor based --tchrist
4633a7c4 523
c5ae3962 524my $tmp;
febd60db 525my $buffer;
137443ea 526if ($Is_MSWin32) {
febd60db
GS
527 $tmp = "$ENV{TEMP}\\perldoc1.$$";
528 $buffer = "$ENV{TEMP}\\perldoc1.b$$";
529 push @pagers, qw( more< less notepad );
530 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
531 for (@found) { s,/,\\,g }
532}
533elsif ($Is_VMS) {
534 $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
535 $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
536 push @pagers, qw( most more less type/page );
537}
538elsif ($Is_Dos) {
539 $tmp = "$ENV{TEMP}/perldoc1.$$";
540 $buffer = "$ENV{TEMP}/perldoc1.b$$";
541 $tmp =~ tr!\\/!//!s;
542 $buffer =~ tr!\\/!//!s;
543 push @pagers, qw( less.exe more.com< );
544 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
545}
546else {
547 if ($^O eq 'os2') {
548 require POSIX;
549 $tmp = POSIX::tmpnam();
550 $buffer = POSIX::tmpnam();
551 unshift @pagers, 'less', 'cmd /c more <';
552 }
553 else {
8167b455
GS
554 # XXX: this is not secure, because it doesn't open it
555 ($tmp, $buffer) = eval { require POSIX }
556 ? (POSIX::tmpnam(), POSIX::tmpnam() )
557 : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" );
febd60db
GS
558 }
559 push @pagers, qw( more less pg view cat );
560 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
4633a7c4 561}
44a8e56a 562unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
4633a7c4 563
8167b455
GS
564# make sure cleanup called
565eval q{
566 sub END { cleanup($tmp, $buffer) }
567 1;
568} || die;
2eb25c99
JH
569
570# exit/die in a windows sighandler is dangerous, so let it do the
571# default thing, which is to exit
572eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32';
febd60db 573
7eda7aea 574if ($opt_m) {
febd60db 575 foreach my $pager (@pagers) {
8167b455
GS
576 if (system($pager, @found) == 0) {
577 exit;
578 }
febd60db 579 }
8167b455
GS
580 if ($Is_VMS) {
581 eval q{
582 use vmsish qw(status exit);
583 exit $?;
584 1;
585 } or die;
586 }
587 exit(1);
eb459f90 588}
7eda7aea 589
eb459f90 590my @pod;
31bdbec1 591if ($opt_f) {
febd60db 592 my $perlfunc = shift @found;
8167b455
GS
593 open(PFUNC, "<", $perlfunc)
594 or die("Can't open $perlfunc: $!");
31bdbec1 595
febd60db
GS
596 # Functions like -r, -e, etc. are listed under `-X'.
597 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
598 ? 'I<-X' : $opt_f ;
a3cb178b 599
febd60db 600 # Skip introduction
8167b455 601 local $_;
febd60db
GS
602 while (<PFUNC>) {
603 last if /^=head2 Alphabetical Listing of Perl Functions/;
604 }
7eda7aea 605
febd60db
GS
606 # Look for our function
607 my $found = 0;
608 my $inlist = 0;
609 while (<PFUNC>) {
610 if (/^=item\s+\Q$search_string\E\b/o) {
611 $found = 1;
85880f03 612 }
febd60db
GS
613 elsif (/^=item/) {
614 last if $found > 1 and not $inlist;
615 }
616 next unless $found;
617 if (/^=over/) {
618 ++$inlist;
619 }
620 elsif (/^=back/) {
621 --$inlist;
4633a7c4 622 }
febd60db
GS
623 push @pod, $_;
624 ++$found if /^\w/; # found descriptive text
625 }
626 if (!@pod) {
627 die "No documentation for perl function `$opt_f' found\n";
628 }
8167b455 629 close PFUNC or die "Can't open $perlfunc: $!";
4633a7c4
LW
630}
631
febd60db
GS
632if ($opt_q) {
633 local @ARGV = @found; # I'm lazy, sue me.
634 my $found = 0;
635 my %found_in;
8167b455 636 my $rx = eval { qr/$opt_q/ } or die <<EOD;
b62b7eeb
GS
637Invalid regular expression '$opt_q' given as -q pattern:
638 $@
639Did you mean \\Q$opt_q ?
640
641EOD
febd60db 642
8167b455
GS
643 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
644 local $_;
febd60db
GS
645 while (<>) {
646 if (/^=head2\s+.*(?:$opt_q)/oi) {
647 $found = 1;
648 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
4633a7c4 649 }
febd60db
GS
650 elsif (/^=head2/) {
651 $found = 0;
652 }
653 next unless $found;
654 push @pod, $_;
655 }
656 if (!@pod) {
8167b455 657 die("No documentation for perl FAQ keyword `$opt_q' found\n");
febd60db
GS
658 }
659}
660
661my $filter;
662
663if (@pod) {
8167b455
GS
664 sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
665 or die("Can't open $buffer: $!");
febd60db 666 print TMP "=over 8\n\n";
8167b455 667 print TMP @pod or die "Can't print $buffer: $!";
febd60db 668 print TMP "=back\n";
8167b455 669 close TMP or die "Can't close $buffer: $!";
febd60db
GS
670 @found = $buffer;
671 $filter = 1;
4633a7c4
LW
672}
673
febd60db
GS
674foreach (@found) {
675 printout($_, $tmp, $filter);
eb459f90 676}
febd60db 677page($tmp, $no_tty, @pagers);
4633a7c4 678
8167b455
GS
679exit;
680
681sub is_tainted {
682 my $arg = shift;
683 my $nada = substr($arg, 0, 0); # zero-length
684 local $@; # preserve caller's version
685 eval { eval "# $nada" };
686 return length($@) != 0;
687}
688
689sub am_taint_checking {
690 my($k,$v) = each %ENV;
691 return is_tainted($v);
692}
693
7eda7aea
PP
694
695__END__
696
697=head1 NAME
698
699perldoc - Look up Perl documentation in pod format.
700
701=head1 SYNOPSIS
702
89b8affa 703B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
7eda7aea 704
31bdbec1
GA
705B<perldoc> B<-f> BuiltinFunction
706
c8950503
DG
707B<perldoc> B<-q> FAQ Keyword
708
7eda7aea
PP
709=head1 DESCRIPTION
710
40fc7247
PP
711I<perldoc> looks up a piece of documentation in .pod format that is embedded
712in the perl installation tree or in a perl script, and displays it via
713C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
714C<col -x> will be used.) This is primarily used for the documentation for
715the perl library modules.
7eda7aea
PP
716
717Your system may also have man pages installed for those modules, in
718which case you can probably just use the man(1) command.
719
720=head1 OPTIONS
721
722=over 5
723
724=item B<-h> help
725
726Prints out a brief help message.
727
728=item B<-v> verbose
729
730Describes search for the item in detail.
731
732=item B<-t> text output
733
734Display docs using plain text converter, instead of nroff. This may be faster,
735but it won't look as nice.
736
737=item B<-u> unformatted
738
739Find docs only; skip reformatting by pod2*
740
741=item B<-m> module
742
743Display the entire module: both code and unformatted pod documentation.
744This may be useful if the docs don't explain a function in the detail
745you need, and you'd like to inspect the code directly; perldoc will find
746the file for you and simply hand it off for display.
747
44a8e56a
PP
748=item B<-l> file name only
749
750Display the file name of the module found.
751
cce34969
IZ
752=item B<-F> file names
753
89b8affa 754Consider arguments as file names, no search in directories will be performed.
cce34969 755
31bdbec1
GA
756=item B<-f> perlfunc
757
758The B<-f> option followed by the name of a perl built in function will
759extract the documentation of this function from L<perlfunc>.
760
c8950503
DG
761=item B<-q> perlfaq
762
763The B<-q> option takes a regular expression as an argument. It will search
764the question headings in perlfaq[1-9] and print the entries matching
765the regular expression.
766
89b8affa
GS
767=item B<-X> use an index if present
768
769The B<-X> option looks for a entry whose basename matches the name given on the
770command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
771contain fully qualified filenames, one per line.
772
c185d8c4
GS
773=item B<-U> run insecurely
774
775Because B<perldoc> does not run properly tainted, and is known to
776have security issues, it will not normally execute as the superuser.
777If you use the B<-U> flag, it will do so, but only after setting
778the effective and real IDs to nobody's or nouser's account, or -2
779if unavailable. If it cannot relinguish its privileges, it will not
780run.
781
7eda7aea
PP
782=item B<PageName|ModuleName|ProgramName>
783
784The item you want to look up. Nested modules (such as C<File::Basename>)
785are specified either as C<File::Basename> or C<File/Basename>. You may also
1b420867 786give a descriptive name of a page, such as C<perlfunc>. You may also give a
7eda7aea
PP
787partial or wrong-case name, such as "basename" for "File::Basename", but
788this will be slower, if there is more then one page with the same partial
789name, you will only get the first one.
790
791=back
792
793=head1 ENVIRONMENT
794
febd60db 795Any switches in the C<PERLDOC> environment variable will be used before the
7eda7aea
PP
796command line arguments. C<perldoc> also searches directories
797specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
798defined) and C<PATH> environment variables.
799(The latter is so that embedded pods for executables, such as
a3cb178b
GS
800C<perldoc> itself, are available.) C<perldoc> will use, in order of
801preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
802C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
803used if C<perldoc> was told to display plain text or unformatted pod.)
7eda7aea 804
eb459f90
IZ
805One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
806
febd60db
GS
807=head1 VERSION
808
6d0835e5 809This is perldoc v2.03.
febd60db 810
7eda7aea
PP
811=head1 AUTHOR
812
813Kenneth Albanowski <kjahds@kjahds.com>
814
febd60db
GS
815Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
816and others.
7eda7aea 817
7eda7aea
PP
818=cut
819
820#
6d0835e5
GS
821# Version 2.03: Sun Apr 23 16:56:34 BST 2000
822# Hugo van der Sanden <hv@crypt0.demon.co.uk>
823# don't die when 'use blib' fails
c185d8c4
GS
824# Version 2.02: Mon Mar 13 18:03:04 MST 2000
825# Tom Christiansen <tchrist@perl.com>
826# Added -U insecurity option
8167b455
GS
827# Version 2.01: Sat Mar 11 15:22:33 MST 2000
828# Tom Christiansen <tchrist@perl.com>, querulously.
829# Security and correctness patches.
830# What a twisted bit of distasteful spaghetti code.
831# Version 2.0: ????
7ec2cea4
GS
832# Version 1.15: Tue Aug 24 01:50:20 EST 1999
833# Charles Wilson <cwilson@ece.gatech.edu>
834# changed /pod/ directory to /pods/ for cygwin
835# to support cygwin/win32
c5ae3962
RB
836# Version 1.14: Wed Jul 15 01:50:20 EST 1998
837# Robin Barker <rmb1@cise.npl.co.uk>
838# -strict, -w cleanups
89b8affa 839# Version 1.13: Fri Feb 27 16:20:50 EST 1997
6e238990 840# Gurusamy Sarathy <gsar@activestate.com>
89b8affa 841# -doc tweaks for -F and -X options
137443ea 842# Version 1.12: Sat Apr 12 22:41:09 EST 1997
6e238990 843# Gurusamy Sarathy <gsar@activestate.com>
137443ea 844# -various fixes for win32
7eda7aea
PP
845# Version 1.11: Tue Dec 26 09:54:33 EST 1995
846# Kenneth Albanowski <kjahds@kjahds.com>
847# -added Charles Bailey's further VMS patches, and -u switch
848# -added -t switch, with pod2text support
febd60db 849#
7eda7aea
PP
850# Version 1.10: Thu Nov 9 07:23:47 EST 1995
851# Kenneth Albanowski <kjahds@kjahds.com>
852# -added VMS support
853# -added better error recognition (on no found pages, just exit. On
854# missing nroff/pod2man, just display raw pod.)
855# -added recursive/case-insensitive matching (thanks, Andreas). This
856# slows things down a bit, unfortunately. Give a precise name, and
857# it'll run faster.
858#
859# Version 1.01: Tue May 30 14:47:34 EDT 1995
860# Andy Dougherty <doughera@lafcol.lafayette.edu>
861# -added pod documentation.
862# -added PATH searching.
863# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
864# and friends.
865#
866#
867# TODO:
868#
869# Cache directories read during sloppy match
4633a7c4
LW
870!NO!SUBS!
871
872close OUT or die "Can't close $file: $!";
873chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
874exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 875chdir $origdir;