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{installscript}";
  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 eval q{ use sigtrap qw(die INT TERM HUP QUIT) };
 563
 564 if ($opt_m) {
 565     foreach my $pager (@pagers) {
 566         if (system($pager, @found) == 0) {
 567             exit;
 568     }
 569     }
 570     if ($Is_VMS) {
 571         eval q{
 572             use vmsish qw(status exit);
 573             exit $?;
 574             1;
 575         } or die;
 576     }
 577     exit(1);
 578 }
 579
 580 my @pod;
 581 if ($opt_f) {
 582     my $perlfunc = shift @found;
 583     open(PFUNC, "<", $perlfunc)
 584         or die("Can't open $perlfunc: $!");
 585
 586     # Functions like -r, -e, etc. are listed under `-X'.
 587     my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
 588                         ? 'I<-X' : $opt_f ;
 589
 590     # Skip introduction
 591     local $_;
 592     while (<PFUNC>) {
 593         last if /^=head2 Alphabetical Listing of Perl Functions/;
 594     }
 595
 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;
 602         }
 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;
 612         }
 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     }
 619     close PFUNC         or die "Can't open $perlfunc: $!";
 620 }
 621
 622 if ($opt_q) {
 623     local @ARGV = @found;       # I'm lazy, sue me.
 624     my $found = 0;
 625     my %found_in;
 626     my $rx = eval { qr/$opt_q/ } or die <<EOD;
 627 Invalid regular expression '$opt_q' given as -q pattern:
 628   $@
 629 Did you mean \\Q$opt_q ?
 630
 631 EOD
 632
 633     for (@found) { die "invalid file spec: $!" if /[<>|]/ }
 634     local $_;
 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}++;
 639         }
 640         elsif (/^=head2/) {
 641             $found = 0;
 642         }
 643         next unless $found;
 644         push @pod, $_;
 645     }
 646     if (!@pod) {
 647         die("No documentation for perl FAQ keyword `$opt_q' found\n");
 648     }
 649 }
 650
 651 my $filter;
 652
 653 if (@pod) {
 654     sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
 655         or die("Can't open $buffer: $!");
 656     print TMP "=over 8\n\n";
 657     print TMP @pod      or die "Can't print $buffer: $!";
 658     print TMP "=back\n";
 659     close TMP           or die "Can't close $buffer: $!";
 660     @found = $buffer;
 661     $filter = 1;
 662 }
 663
 664 foreach (@found) {
 665     printout($_, $tmp, $filter);
 666 }
 667 page($tmp, $no_tty, @pagers);
 668
 669 exit;
 670
 671 sub 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
 679 sub am_taint_checking {
 680     my($k,$v) = each %ENV;
 681     return is_tainted($v);
 682 }
 683
 684
 685 __END__
 686
 687 =head1 NAME
 688
 689 perldoc - Look up Perl documentation in pod format.
 690
 691 =head1 SYNOPSIS
 692
 693 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
 694
 695 B<perldoc> B<-f> BuiltinFunction
 696
 697 B<perldoc> B<-q> FAQ Keyword
 698
 699 =head1 DESCRIPTION
 700
 701 I<perldoc> looks up a piece of documentation in .pod format that is embedded
 702 in the perl installation tree or in a perl script, and displays it via
 703 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
 704 C<col -x> will be used.) This is primarily used for the documentation for
 705 the perl library modules.
 706
 707 Your system may also have man pages installed for those modules, in
 708 which 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
 716 Prints out a brief help message.
 717
 718 =item B<-v> verbose
 719
 720 Describes search for the item in detail.
 721
 722 =item B<-t> text output
 723
 724 Display docs using plain text converter, instead of nroff. This may be faster,
 725 but it won't look as nice.
 726
 727 =item B<-u> unformatted
 728
 729 Find docs only; skip reformatting by pod2*
 730
 731 =item B<-m> module
 732
 733 Display the entire module: both code and unformatted pod documentation.
 734 This may be useful if the docs don't explain a function in the detail
 735 you need, and you'd like to inspect the code directly; perldoc will find
 736 the file for you and simply hand it off for display.
 737
 738 =item B<-l> file name only
 739
 740 Display the file name of the module found.
 741
 742 =item B<-F> file names
 743
 744 Consider arguments as file names, no search in directories will be performed.
 745
 746 =item B<-f> perlfunc
 747
 748 The B<-f> option followed by the name of a perl built in function will
 749 extract the documentation of this function from L<perlfunc>.
 750
 751 =item B<-q> perlfaq
 752
 753 The B<-q> option takes a regular expression as an argument.  It will search
 754 the question headings in perlfaq[1-9] and print the entries matching
 755 the regular expression.
 756
 757 =item B<-X> use an index if present
 758
 759 The B<-X> option looks for a entry whose basename matches the name given on the
 760 command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
 761 contain fully qualified filenames, one per line.
 762
 763 =item B<-U> run insecurely
 764
 765 Because B<perldoc> does not run properly tainted, and is known to
 766 have security issues, it will not normally execute as the superuser.
 767 If you use the B<-U> flag, it will do so, but only after setting
 768 the effective and real IDs to nobody's or nouser's account, or -2
 769 if unavailable.  If it cannot relinguish its privileges, it will not
 770 run.
 771
 772 =item B<PageName|ModuleName|ProgramName>
 773
 774 The item you want to look up.  Nested modules (such as C<File::Basename>)
 775 are specified either as C<File::Basename> or C<File/Basename>.  You may also
 776 give a descriptive name of a page, such as C<perlfunc>. You may also give a
 777 partial or wrong-case name, such as "basename" for "File::Basename", but
 778 this will be slower, if there is more then one page with the same partial
 779 name, you will only get the first one.
 780
 781 =back
 782
 783 =head1 ENVIRONMENT
 784
 785 Any switches in the C<PERLDOC> environment variable will be used before the
 786 command line arguments.  C<perldoc> also searches directories
 787 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 788 defined) and C<PATH> environment variables.
 789 (The latter is so that embedded pods for executables, such as
 790 C<perldoc> itself, are available.)  C<perldoc> will use, in order of
 791 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
 792 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
 793 used if C<perldoc> was told to display plain text or unformatted pod.)
 794
 795 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
 796
 797 =head1 VERSION
 798
 799 This is perldoc v2.03.
 800
 801 =head1 AUTHOR
 802
 803 Kenneth Albanowski <kjahds@kjahds.com>
 804
 805 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
 806 and others.
 807
 808 =cut
 809
 810 #
 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
 814 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
 815 #       Tom Christiansen <tchrist@perl.com>
 816 #       Added -U insecurity option
 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: ????
 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
 826 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
 827 #       Robin Barker <rmb1@cise.npl.co.uk>
 828 #       -strict, -w cleanups
 829 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
 830 #       Gurusamy Sarathy <gsar@activestate.com>
 831 #       -doc tweaks for -F and -X options
 832 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
 833 #       Gurusamy Sarathy <gsar@activestate.com>
 834 #       -various fixes for win32
 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
 839 #
 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
 860 !NO!SUBS!
 861
 862 close OUT or die "Can't close $file: $!";
 863 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 864 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 865 chdir $origdir;