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