utils/perldoc.PL

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