[no reason given] is not good.
[p5sagit/p5-mst-13.2.git] / utils / perldoc.PL
CommitLineData
4633a7c4 1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4 6
85880f03 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 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 17chdir dirname($0);
18$file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4 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 29$Config{startperl}
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
c5ae3962 31 if 0;
55497cff 32
8167b455 33use warnings;
c5ae3962 34use strict;
8167b455 35
36# make sure creat()s are neither too much nor too little
37INIT { eval { umask(0077) } } # doubtless someone has no mask
38
ed6d8ea1 39(my \$pager = <<'/../') =~ s/\\s*\\z//;
40$Config{pager}
41/../
c5ae3962 42my \@pagers = ();
ed6d8ea1 43push \@pagers, \$pager if -x \$pager;
44
45(my \$bindir = <<'/../') =~ s/\\s*\\z//;
46$Config{scriptdir}
47/../
8167b455 48
4633a7c4 49!GROK!THIS!
50
51# In the following, perl variables are not expanded during extraction.
52
53print OUT <<'!NO!SUBS!';
54
8167b455 55use Fcntl; # for sysopen
56use Getopt::Std;
57use Config '%Config';
14178d34 58use File::Spec::Functions qw(catfile splitdir);
8167b455 59
4633a7c4 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 65# man replacement, written in perl. This perldoc is strictly for reading
66# the perl manuals, though it too is written in perl.
8167b455 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 81EOF
82}
83
c5ae3962 84my @global_found = ();
85my $global_target = "";
fb73857a 86
c5ae3962 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 91
92sub usage{
ff0cee69 93 warn "@_\n" if @_;
94 # Erase evidence of previous errors (if any), so exit status is simple.
95 $! = 0;
4633a7c4 96 die <<EOF;
31bdbec1 97perldoc [options] PageName|ModuleName|ProgramName...
98perldoc [options] -f BuiltinFunction
a3cb178b 99perldoc [options] -q FAQRegex
31bdbec1 100
101Options:
137443ea 102 -h Display this help message
5315ba28 103 -r Recursive search (slow)
febd60db 104 -i Ignore case
137443ea 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 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 123
124BuiltinFunction
125 is the name of a perl function. Will extract documentation from
126 `perlfunc'.
a3cb178b 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 133command line arguments. The optional pod index file contains a list of
134filenames, one per line.
4633a7c4 135
136EOF
137}
138
febd60db 139if (defined $ENV{"PERLDOC"}) {
c5ae3962 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 150getopts("$getopts") || usage;
151!GET!OPTS!
4633a7c4 152
c5ae3962 153print OUT <<'!NO!SUBS!';
85880f03 154
c5ae3962 155usage if $opt_h;
c185d8c4 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 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 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 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 197 @pages = ("perlfunc");
198}
199elsif ($opt_q) {
200 @pages = ("perlfaq1" .. "perlfaq9");
201}
202else {
203 @pages = @ARGV;
31bdbec1 204}
205
fb73857a 206# Does this look like a module or extension directory?
207if (-f "Makefile.PL") {
8167b455 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 214 eval q{ use blib; 1 };
215 warn $@ if $@ && $opt_v;
8167b455 216 }
fb73857a 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 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 232}
233
84902520 234sub minus_f_nocase {
5315ba28 235 my($dir,$file) = @_;
14178d34 236 my $path = catfile($dir,$file);
5315ba28 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 245 # this is completely wicked. don't mess with $", and if
246 # you do, don't assume / is the dirsep!
4633a7c4 247 local($")="/";
5315ba28 248 my @p = ($dir);
249 my($p,$cip);
14178d34 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 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 264 }
265 elsif (-f _ && -r _) {
fb73857a 266 return $try;
febd60db 267 }
268 elsif (-f _) {
fb73857a 269 warn "Ignored $try: unreadable\n";
febd60db 270 }
8167b455 271 elsif (-d "@p") {
4633a7c4 272 my $found=0;
273 my $lcp = lc $p;
8167b455 274 opendir DIR, "@p" or die "opendir @p: $!";
4633a7c4 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 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 286 }
287 }
5315ba28 288 return "";
fb73857a 289}
eb459f90 290
fb73857a 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 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 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 316 for ($i=0; $i<@dirs; $i++) {
317 $dir = $dirs[$i];
8167b455 318 ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
5315ba28 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 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 330 or ( $ret = check_file "$dir/pods","$s.pod")
331 or ( $ret = check_file "$dir/pods",$s)
fb73857a 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 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 345 # what a wicked map!
346 @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
fb73857a 347 print STDERR "Also looking in @newdirs\n" if $opt_v;
348 push(@dirs,@newdirs);
349 }
350 }
351 return ();
352}
4633a7c4 353
eb459f90 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 363sub page {
364 my ($tmp, $no_tty, @pagers) = @_;
365 if ($no_tty) {
8167b455 366 open(TMP,"<", $tmp) or die "Can't open $tmp: $!";
367 local $_;
368 while (<TMP>) {
369 print or die "Can't print to stdout: $!";
370 }
371 close TMP or die "Can't close while $tmp: $!";
febd60db 372 }
373 else {
f3298698 374 # On VMS, quoting prevents logical expansion, and temp files with no
375 # extension get the wrong default extension (such as .LIS for TYPE)
376
377 $tmp = VMS::Filespec::rmsexpand($tmp, '.') if ($Is_VMS);
378 foreach my $pager (@pagers) {
e0d5f7b4 379 if ($Is_VMS) {
f3298698 380 last if system("$pager $tmp") == 0;
e0d5f7b4 381 } else {
a79ff105 382 last if system("$pager \"$tmp\"") == 0;
e0d5f7b4 383 }
febd60db 384 }
385 }
386}
387
c5ae3962 388my @found;
4633a7c4 389foreach (@pages) {
febd60db 390 if ($podidx && open(PODIDX, $podidx)) {
14178d34 391 my $searchfor = catfile split '::';
febd60db 392 print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
8167b455 393 local $_;
febd60db 394 while (<PODIDX>) {
395 chomp;
8167b455 396 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
cce34969 397 }
8167b455 398 close(PODIDX) or die "Can't close $podidx: $!";
febd60db 399 next;
400 }
401 print STDERR "Searching for $_\n" if $opt_v;
febd60db 402 if ($opt_F) {
403 next unless -r;
404 push @found, $_ if $opt_m or containspod($_);
405 next;
406 }
6a43d2f9 407 # We must look both in @INC for library modules and in $bindir
408 # for executables, like h2xs or perldoc itself.
409 my @searchdirs = ($bindir, @INC);
febd60db 410 unless ($opt_m) {
411 if ($Is_VMS) {
412 my($i,$trn);
413 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
414 push(@searchdirs,$trn);
7eda7aea 415 }
febd60db 416 push(@searchdirs,'perl_root:[lib.pod]') # installed pods
417 }
418 else {
419 push(@searchdirs, grep(-d, split($Config{path_sep},
420 $ENV{'PATH'})));
85880f03 421 }
febd60db 422 }
423 my @files = searchfor(0,$_,@searchdirs);
424 if (@files) {
425 print STDERR "Found as @files\n" if $opt_v;
426 }
427 else {
428 # no match, try recursive search
8167b455 429 @searchdirs = grep(!/^\.\z/s,@INC);
febd60db 430 @files= searchfor(1,$_,@searchdirs) if $opt_r;
431 if (@files) {
432 print STDERR "Loosely found as @files\n" if $opt_v;
433 }
434 else {
435 print STDERR "No documentation found for \"$_\".\n";
436 if (@global_found) {
437 print STDERR "However, try\n";
438 for my $dir (@global_found) {
8167b455 439 opendir(DIR, $dir) or die "opendir $dir: $!";
febd60db 440 while (my $file = readdir(DIR)) {
8167b455 441 next if ($file =~ /^\./s);
442 $file =~ s/\.(pm|pod)\z//; # XXX: badfs
febd60db 443 print STDERR "\tperldoc $_\::$file\n";
444 }
8167b455 445 closedir DIR or die "closedir $dir: $!";
4633a7c4 446 }
febd60db 447 }
4633a7c4 448 }
febd60db 449 }
450 push(@found,@files);
4633a7c4 451}
452
febd60db 453if (!@found) {
454 exit ($Is_VMS ? 98962 : 1);
4633a7c4 455}
456
44a8e56a 457if ($opt_l) {
458 print join("\n", @found), "\n";
459 exit;
460}
461
877622ba 462my $lines = $ENV{LINES} || 24;
463
c5ae3962 464my $no_tty;
febd60db 465if (! -t STDOUT) { $no_tty = 1 }
8167b455 466END { close(STDOUT) || die "Can't close STDOUT: $!" }
febd60db 467
137443ea 468if ($Is_MSWin32) {
febd60db 469 push @pagers, qw( more< less notepad );
470 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
471 for (@found) { s,/,\\,g }
472}
473elsif ($Is_VMS) {
febd60db 474 push @pagers, qw( most more less type/page );
475}
476elsif ($Is_Dos) {
febd60db 477 push @pagers, qw( less.exe more.com< );
478 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
479}
480else {
481 if ($^O eq 'os2') {
febd60db 482 unshift @pagers, 'less', 'cmd /c more <';
483 }
febd60db 484 push @pagers, qw( more less pg view cat );
485 unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
4633a7c4 486}
44a8e56a 487unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
4633a7c4 488
7eda7aea 489if ($opt_m) {
febd60db 490 foreach my $pager (@pagers) {
8167b455 491 if (system($pager, @found) == 0) {
492 exit;
493 }
febd60db 494 }
8167b455 495 if ($Is_VMS) {
496 eval q{
497 use vmsish qw(status exit);
498 exit $?;
499 1;
500 } or die;
501 }
502 exit(1);
eb459f90 503}
7eda7aea 504
eb459f90 505my @pod;
31bdbec1 506if ($opt_f) {
febd60db 507 my $perlfunc = shift @found;
8167b455 508 open(PFUNC, "<", $perlfunc)
509 or die("Can't open $perlfunc: $!");
31bdbec1 510
febd60db 511 # Functions like -r, -e, etc. are listed under `-X'.
512 my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
513 ? 'I<-X' : $opt_f ;
a3cb178b 514
febd60db 515 # Skip introduction
8167b455 516 local $_;
febd60db 517 while (<PFUNC>) {
518 last if /^=head2 Alphabetical Listing of Perl Functions/;
519 }
7eda7aea 520
febd60db 521 # Look for our function
522 my $found = 0;
523 my $inlist = 0;
524 while (<PFUNC>) {
525 if (/^=item\s+\Q$search_string\E\b/o) {
526 $found = 1;
85880f03 527 }
febd60db 528 elsif (/^=item/) {
529 last if $found > 1 and not $inlist;
530 }
531 next unless $found;
532 if (/^=over/) {
533 ++$inlist;
534 }
535 elsif (/^=back/) {
536 --$inlist;
4633a7c4 537 }
febd60db 538 push @pod, $_;
539 ++$found if /^\w/; # found descriptive text
540 }
541 if (!@pod) {
542 die "No documentation for perl function `$opt_f' found\n";
543 }
8167b455 544 close PFUNC or die "Can't open $perlfunc: $!";
4633a7c4 545}
546
febd60db 547if ($opt_q) {
548 local @ARGV = @found; # I'm lazy, sue me.
549 my $found = 0;
550 my %found_in;
8167b455 551 my $rx = eval { qr/$opt_q/ } or die <<EOD;
b62b7eeb 552Invalid regular expression '$opt_q' given as -q pattern:
553 $@
554Did you mean \\Q$opt_q ?
555
556EOD
febd60db 557
8167b455 558 for (@found) { die "invalid file spec: $!" if /[<>|]/ }
559 local $_;
febd60db 560 while (<>) {
561 if (/^=head2\s+.*(?:$opt_q)/oi) {
562 $found = 1;
563 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
4633a7c4 564 }
febd60db 565 elsif (/^=head2/) {
566 $found = 0;
567 }
568 next unless $found;
569 push @pod, $_;
570 }
571 if (!@pod) {
8167b455 572 die("No documentation for perl FAQ keyword `$opt_q' found\n");
febd60db 573 }
574}
575
6a43d2f9 576require File::Temp;
577
008d9c33 578my ($tmpfd, $tmp) = File::Temp::tempfile(UNLINK => 1);
6a43d2f9 579
febd60db 580my $filter;
581
582if (@pod) {
008d9c33 583 my ($buffd, $buffer) = File::Temp::tempfile(UNLINK => 1);
6a43d2f9 584 print $buffd "=over 8\n\n";
585 print $buffd @pod or die "Can't print $buffer: $!";
586 print $buffd "=back\n";
587 close $buffd or die "Can't close $buffer: $!";
febd60db 588 @found = $buffer;
589 $filter = 1;
4633a7c4 590}
591
febd60db 592foreach (@found) {
6a43d2f9 593 my $file = $_;
594 my $err;
595
596 if ($opt_t) {
597 Pod::Text->new()->parse_from_file($file, $tmpfd);
598 }
599 elsif (not $opt_u) {
600 my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man";
601 $cmd .= " | col -x" if $^O =~ /hpux/;
602 my $rslt = `$cmd`;
603 $rslt = filter_nroff($rslt) if $filter;
604 unless (($err = $?)) {
605 print $tmpfd $rslt
606 or die "Can't print $tmp: $!";
607 }
608 }
609 if ($opt_u or $err) {
610 open(IN,"<", $file) or die("Can't open $file: $!");
611 my $cut = 1;
612 local $_;
613 while (<IN>) {
614 $cut = $1 eq 'cut' if /^=(\w+)/;
615 next if $cut;
616 print $tmpfd $_
617 or die "Can't print $tmp: $!";
618 }
619 close IN or die "Can't close $file: $!";
620 }
eb459f90 621}
6a43d2f9 622close $tmpfd
623 or die "Can't close $tmp: $!";
febd60db 624page($tmp, $no_tty, @pagers);
4633a7c4 625
8167b455 626exit;
627
628sub is_tainted {
629 my $arg = shift;
630 my $nada = substr($arg, 0, 0); # zero-length
631 local $@; # preserve caller's version
632 eval { eval "# $nada" };
633 return length($@) != 0;
634}
635
636sub am_taint_checking {
637 my($k,$v) = each %ENV;
638 return is_tainted($v);
639}
640
7eda7aea 641
642__END__
643
644=head1 NAME
645
646perldoc - Look up Perl documentation in pod format.
647
648=head1 SYNOPSIS
649
89b8affa 650B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
7eda7aea 651
31bdbec1 652B<perldoc> B<-f> BuiltinFunction
653
c8950503 654B<perldoc> B<-q> FAQ Keyword
655
7eda7aea 656=head1 DESCRIPTION
657
40fc7247 658I<perldoc> looks up a piece of documentation in .pod format that is embedded
659in the perl installation tree or in a perl script, and displays it via
660C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
661C<col -x> will be used.) This is primarily used for the documentation for
662the perl library modules.
7eda7aea 663
664Your system may also have man pages installed for those modules, in
665which case you can probably just use the man(1) command.
666
667=head1 OPTIONS
668
669=over 5
670
671=item B<-h> help
672
673Prints out a brief help message.
674
675=item B<-v> verbose
676
677Describes search for the item in detail.
678
679=item B<-t> text output
680
681Display docs using plain text converter, instead of nroff. This may be faster,
682but it won't look as nice.
683
684=item B<-u> unformatted
685
686Find docs only; skip reformatting by pod2*
687
688=item B<-m> module
689
690Display the entire module: both code and unformatted pod documentation.
691This may be useful if the docs don't explain a function in the detail
692you need, and you'd like to inspect the code directly; perldoc will find
693the file for you and simply hand it off for display.
694
44a8e56a 695=item B<-l> file name only
696
697Display the file name of the module found.
698
cce34969 699=item B<-F> file names
700
89b8affa 701Consider arguments as file names, no search in directories will be performed.
cce34969 702
31bdbec1 703=item B<-f> perlfunc
704
705The B<-f> option followed by the name of a perl built in function will
706extract the documentation of this function from L<perlfunc>.
707
c8950503 708=item B<-q> perlfaq
709
710The B<-q> option takes a regular expression as an argument. It will search
711the question headings in perlfaq[1-9] and print the entries matching
712the regular expression.
713
89b8affa 714=item B<-X> use an index if present
715
716The B<-X> option looks for a entry whose basename matches the name given on the
717command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
718contain fully qualified filenames, one per line.
719
c185d8c4 720=item B<-U> run insecurely
721
722Because B<perldoc> does not run properly tainted, and is known to
723have security issues, it will not normally execute as the superuser.
724If you use the B<-U> flag, it will do so, but only after setting
725the effective and real IDs to nobody's or nouser's account, or -2
726if unavailable. If it cannot relinguish its privileges, it will not
727run.
728
7eda7aea 729=item B<PageName|ModuleName|ProgramName>
730
731The item you want to look up. Nested modules (such as C<File::Basename>)
732are specified either as C<File::Basename> or C<File/Basename>. You may also
1b420867 733give a descriptive name of a page, such as C<perlfunc>. You may also give a
7eda7aea 734partial or wrong-case name, such as "basename" for "File::Basename", but
735this will be slower, if there is more then one page with the same partial
736name, you will only get the first one.
737
738=back
739
740=head1 ENVIRONMENT
741
febd60db 742Any switches in the C<PERLDOC> environment variable will be used before the
7eda7aea 743command line arguments. C<perldoc> also searches directories
744specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
745defined) and C<PATH> environment variables.
746(The latter is so that embedded pods for executables, such as
a3cb178b 747C<perldoc> itself, are available.) C<perldoc> will use, in order of
748preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
749C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
750used if C<perldoc> was told to display plain text or unformatted pod.)
7eda7aea 751
eb459f90 752One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
753
febd60db 754=head1 VERSION
755
6d0835e5 756This is perldoc v2.03.
febd60db 757
7eda7aea 758=head1 AUTHOR
759
760Kenneth Albanowski <kjahds@kjahds.com>
761
febd60db 762Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
763and others.
7eda7aea 764
7eda7aea 765=cut
766
767#
6d0835e5 768# Version 2.03: Sun Apr 23 16:56:34 BST 2000
769# Hugo van der Sanden <hv@crypt0.demon.co.uk>
770# don't die when 'use blib' fails
c185d8c4 771# Version 2.02: Mon Mar 13 18:03:04 MST 2000
772# Tom Christiansen <tchrist@perl.com>
773# Added -U insecurity option
8167b455 774# Version 2.01: Sat Mar 11 15:22:33 MST 2000
775# Tom Christiansen <tchrist@perl.com>, querulously.
776# Security and correctness patches.
777# What a twisted bit of distasteful spaghetti code.
778# Version 2.0: ????
7ec2cea4 779# Version 1.15: Tue Aug 24 01:50:20 EST 1999
780# Charles Wilson <cwilson@ece.gatech.edu>
781# changed /pod/ directory to /pods/ for cygwin
782# to support cygwin/win32
c5ae3962 783# Version 1.14: Wed Jul 15 01:50:20 EST 1998
784# Robin Barker <rmb1@cise.npl.co.uk>
785# -strict, -w cleanups
89b8affa 786# Version 1.13: Fri Feb 27 16:20:50 EST 1997
6e238990 787# Gurusamy Sarathy <gsar@activestate.com>
89b8affa 788# -doc tweaks for -F and -X options
137443ea 789# Version 1.12: Sat Apr 12 22:41:09 EST 1997
6e238990 790# Gurusamy Sarathy <gsar@activestate.com>
137443ea 791# -various fixes for win32
7eda7aea 792# Version 1.11: Tue Dec 26 09:54:33 EST 1995
793# Kenneth Albanowski <kjahds@kjahds.com>
794# -added Charles Bailey's further VMS patches, and -u switch
795# -added -t switch, with pod2text support
febd60db 796#
7eda7aea 797# Version 1.10: Thu Nov 9 07:23:47 EST 1995
798# Kenneth Albanowski <kjahds@kjahds.com>
799# -added VMS support
800# -added better error recognition (on no found pages, just exit. On
801# missing nroff/pod2man, just display raw pod.)
802# -added recursive/case-insensitive matching (thanks, Andreas). This
803# slows things down a bit, unfortunately. Give a precise name, and
804# it'll run faster.
805#
806# Version 1.01: Tue May 30 14:47:34 EDT 1995
807# Andy Dougherty <doughera@lafcol.lafayette.edu>
808# -added pod documentation.
809# -added PATH searching.
810# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
811# and friends.
812#
813#
814# TODO:
815#
816# Cache directories read during sloppy match
4633a7c4 817!NO!SUBS!
818
819close OUT or die "Can't close $file: $!";
820chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
821exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 822chdir $origdir;