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