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