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 };
 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             last if system("$pager $tmp") == 0;
 413         }
 414     }
 415 }
 416
 417 sub cleanup {
 418     my @files = @_;
 419     for (@files) {
 420         if ($Is_VMS) {
 421             1 while unlink($_);    # XXX: expect failure
 422         } else {
 423             unlink($_);            # or die "Can't unlink $_: $!";
 424         }
 425     }
 426 }
 427
 428 my @found;
 429 foreach (@pages) {
 430     if ($podidx && open(PODIDX, $podidx)) {
 431         my $searchfor = catfile split '::';
 432         print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
 433         local $_;
 434         while (<PODIDX>) {
 435             chomp;
 436             push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
 437         }
 438         close(PODIDX)       or die "Can't close $podidx: $!";
 439         next;
 440     }
 441     print STDERR "Searching for $_\n" if $opt_v;
 442     # We must look both in @INC for library modules and in PATH
 443     # for executables, like h2xs or perldoc itself.
 444     my @searchdirs = @INC;
 445     if ($opt_F) {
 446         next unless -r;
 447         push @found, $_ if $opt_m or containspod($_);
 448         next;
 449     }
 450     unless ($opt_m) {
 451         if ($Is_VMS) {
 452             my($i,$trn);
 453             for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
 454                 push(@searchdirs,$trn);
 455             }
 456             push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
 457         }
 458         else {
 459             push(@searchdirs, grep(-d, split($Config{path_sep},
 460                                              $ENV{'PATH'})));
 461         }
 462     }
 463     my @files = searchfor(0,$_,@searchdirs);
 464     if (@files) {
 465         print STDERR "Found as @files\n" if $opt_v;
 466     }
 467     else {
 468         # no match, try recursive search
 469         @searchdirs = grep(!/^\.\z/s,@INC);
 470         @files= searchfor(1,$_,@searchdirs) if $opt_r;
 471         if (@files) {
 472             print STDERR "Loosely found as @files\n" if $opt_v;
 473         }
 474         else {
 475             print STDERR "No documentation found for \"$_\".\n";
 476             if (@global_found) {
 477                 print STDERR "However, try\n";
 478                 for my $dir (@global_found) {
 479                     opendir(DIR, $dir) or die "opendir $dir: $!";
 480                     while (my $file = readdir(DIR)) {
 481                         next if ($file =~ /^\./s);
 482                         $file =~ s/\.(pm|pod)\z//;  # XXX: badfs
 483                         print STDERR "\tperldoc $_\::$file\n";
 484                     }
 485                     closedir DIR    or die "closedir $dir: $!";
 486                 }
 487             }
 488         }
 489     }
 490     push(@found,@files);
 491 }
 492
 493 if (!@found) {
 494     exit ($Is_VMS ? 98962 : 1);
 495 }
 496
 497 if ($opt_l) {
 498     print join("\n", @found), "\n";
 499     exit;
 500 }
 501
 502 my $lines = $ENV{LINES} || 24;
 503
 504 my $no_tty;
 505 if (! -t STDOUT) { $no_tty = 1 }
 506 END { close(STDOUT) || die "Can't close STDOUT: $!" }
 507
 508 # until here we could simply exit or die
 509 # now we create temporary files that we have to clean up
 510 # namely $tmp, $buffer
 511 # that's because you did it wrong, should be descriptor based --tchrist
 512
 513 my $tmp;
 514 my $buffer;
 515 if ($Is_MSWin32) {
 516     $tmp = "$ENV{TEMP}\\perldoc1.$$";
 517     $buffer = "$ENV{TEMP}\\perldoc1.b$$";
 518     push @pagers, qw( more< less notepad );
 519     unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 520     for (@found) { s,/,\\,g }
 521 }
 522 elsif ($Is_VMS) {
 523     $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
 524     $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
 525     push @pagers, qw( most more less type/page );
 526 }
 527 elsif ($Is_Dos) {
 528     $tmp = "$ENV{TEMP}/perldoc1.$$";
 529     $buffer = "$ENV{TEMP}/perldoc1.b$$";
 530     $tmp =~ tr!\\/!//!s;
 531     $buffer =~ tr!\\/!//!s;
 532     push @pagers, qw( less.exe more.com< );
 533     unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 534 }
 535 else {
 536     if ($^O eq 'os2') {
 537       require POSIX;
 538       $tmp = POSIX::tmpnam();
 539       $buffer = POSIX::tmpnam();
 540       unshift @pagers, 'less', 'cmd /c more <';
 541     }
 542     else {
 543       # XXX: this is not secure, because it doesn't open it
 544       ($tmp, $buffer) = eval { require POSIX }
 545             ? (POSIX::tmpnam(),    POSIX::tmpnam()     )
 546             : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" );
 547     }
 548     push @pagers, qw( more less pg view cat );
 549     unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 550 }
 551 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 552
 553 # make sure cleanup called
 554 eval q{
 555     sub END { cleanup($tmp, $buffer) }
 556     1;
 557 } || die;
 558 eval q{ use sigtrap qw(die INT TERM HUP QUIT) };
 559
 560 if ($opt_m) {
 561     foreach my $pager (@pagers) {
 562         if (system($pager, @found) == 0) {
 563             exit;
 564     }
 565     }
 566     if ($Is_VMS) {
 567         eval q{
 568             use vmsish qw(status exit);
 569             exit $?;
 570             1;
 571         } or die;
 572     }
 573     exit(1);
 574 }
 575
 576 my @pod;
 577 if ($opt_f) {
 578     my $perlfunc = shift @found;
 579     open(PFUNC, "<", $perlfunc)
 580         or die("Can't open $perlfunc: $!");
 581
 582     # Functions like -r, -e, etc. are listed under `-X'.
 583     my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
 584                         ? 'I<-X' : $opt_f ;
 585
 586     # Skip introduction
 587     local $_;
 588     while (<PFUNC>) {
 589         last if /^=head2 Alphabetical Listing of Perl Functions/;
 590     }
 591
 592     # Look for our function
 593     my $found = 0;
 594     my $inlist = 0;
 595     while (<PFUNC>) {
 596         if (/^=item\s+\Q$search_string\E\b/o)  {
 597             $found = 1;
 598         }
 599         elsif (/^=item/) {
 600             last if $found > 1 and not $inlist;
 601         }
 602         next unless $found;
 603         if (/^=over/) {
 604             ++$inlist;
 605         }
 606         elsif (/^=back/) {
 607             --$inlist;
 608         }
 609         push @pod, $_;
 610         ++$found if /^\w/;      # found descriptive text
 611     }
 612     if (!@pod) {
 613         die "No documentation for perl function `$opt_f' found\n";
 614     }
 615     close PFUNC         or die "Can't open $perlfunc: $!";
 616 }
 617
 618 if ($opt_q) {
 619     local @ARGV = @found;       # I'm lazy, sue me.
 620     my $found = 0;
 621     my %found_in;
 622     my $rx = eval { qr/$opt_q/ } or die <<EOD;
 623 Invalid regular expression '$opt_q' given as -q pattern:
 624   $@
 625 Did you mean \\Q$opt_q ?
 626
 627 EOD
 628
 629     for (@found) { die "invalid file spec: $!" if /[<>|]/ }
 630     local $_;
 631     while (<>) {
 632         if (/^=head2\s+.*(?:$opt_q)/oi) {
 633             $found = 1;
 634             push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
 635         }
 636         elsif (/^=head2/) {
 637             $found = 0;
 638         }
 639         next unless $found;
 640         push @pod, $_;
 641     }
 642     if (!@pod) {
 643         die("No documentation for perl FAQ keyword `$opt_q' found\n");
 644     }
 645 }
 646
 647 my $filter;
 648
 649 if (@pod) {
 650     sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
 651         or die("Can't open $buffer: $!");
 652     print TMP "=over 8\n\n";
 653     print TMP @pod      or die "Can't print $buffer: $!";
 654     print TMP "=back\n";
 655     close TMP           or die "Can't close $buffer: $!";
 656     @found = $buffer;
 657     $filter = 1;
 658 }
 659
 660 foreach (@found) {
 661     printout($_, $tmp, $filter);
 662 }
 663 page($tmp, $no_tty, @pagers);
 664
 665 exit;
 666
 667 sub is_tainted {
 668     my $arg = shift;
 669     my $nada = substr($arg, 0, 0);  # zero-length
 670     local $@;  # preserve caller's version
 671     eval { eval "# $nada" };
 672     return length($@) != 0;
 673 }
 674
 675 sub am_taint_checking {
 676     my($k,$v) = each %ENV;
 677     return is_tainted($v);
 678 }
 679
 680
 681 __END__
 682
 683 =head1 NAME
 684
 685 perldoc - Look up Perl documentation in pod format.
 686
 687 =head1 SYNOPSIS
 688
 689 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
 690
 691 B<perldoc> B<-f> BuiltinFunction
 692
 693 B<perldoc> B<-q> FAQ Keyword
 694
 695 =head1 DESCRIPTION
 696
 697 I<perldoc> looks up a piece of documentation in .pod format that is embedded
 698 in the perl installation tree or in a perl script, and displays it via
 699 C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
 700 C<col -x> will be used.) This is primarily used for the documentation for
 701 the perl library modules.
 702
 703 Your system may also have man pages installed for those modules, in
 704 which case you can probably just use the man(1) command.
 705
 706 =head1 OPTIONS
 707
 708 =over 5
 709
 710 =item B<-h> help
 711
 712 Prints out a brief help message.
 713
 714 =item B<-v> verbose
 715
 716 Describes search for the item in detail.
 717
 718 =item B<-t> text output
 719
 720 Display docs using plain text converter, instead of nroff. This may be faster,
 721 but it won't look as nice.
 722
 723 =item B<-u> unformatted
 724
 725 Find docs only; skip reformatting by pod2*
 726
 727 =item B<-m> module
 728
 729 Display the entire module: both code and unformatted pod documentation.
 730 This may be useful if the docs don't explain a function in the detail
 731 you need, and you'd like to inspect the code directly; perldoc will find
 732 the file for you and simply hand it off for display.
 733
 734 =item B<-l> file name only
 735
 736 Display the file name of the module found.
 737
 738 =item B<-F> file names
 739
 740 Consider arguments as file names, no search in directories will be performed.
 741
 742 =item B<-f> perlfunc
 743
 744 The B<-f> option followed by the name of a perl built in function will
 745 extract the documentation of this function from L<perlfunc>.
 746
 747 =item B<-q> perlfaq
 748
 749 The B<-q> option takes a regular expression as an argument.  It will search
 750 the question headings in perlfaq[1-9] and print the entries matching
 751 the regular expression.
 752
 753 =item B<-X> use an index if present
 754
 755 The B<-X> option looks for a entry whose basename matches the name given on the
 756 command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
 757 contain fully qualified filenames, one per line.
 758
 759 =item B<-U> run insecurely
 760
 761 Because B<perldoc> does not run properly tainted, and is known to
 762 have security issues, it will not normally execute as the superuser.
 763 If you use the B<-U> flag, it will do so, but only after setting
 764 the effective and real IDs to nobody's or nouser's account, or -2
 765 if unavailable.  If it cannot relinguish its privileges, it will not
 766 run.
 767
 768 =item B<PageName|ModuleName|ProgramName>
 769
 770 The item you want to look up.  Nested modules (such as C<File::Basename>)
 771 are specified either as C<File::Basename> or C<File/Basename>.  You may also
 772 give a descriptive name of a page, such as C<perlfunc>. You may also give a
 773 partial or wrong-case name, such as "basename" for "File::Basename", but
 774 this will be slower, if there is more then one page with the same partial
 775 name, you will only get the first one.
 776
 777 =back
 778
 779 =head1 ENVIRONMENT
 780
 781 Any switches in the C<PERLDOC> environment variable will be used before the
 782 command line arguments.  C<perldoc> also searches directories
 783 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 784 defined) and C<PATH> environment variables.
 785 (The latter is so that embedded pods for executables, such as
 786 C<perldoc> itself, are available.)  C<perldoc> will use, in order of
 787 preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
 788 C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
 789 used if C<perldoc> was told to display plain text or unformatted pod.)
 790
 791 One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
 792
 793 =head1 VERSION
 794
 795 This is perldoc v2.03.
 796
 797 =head1 AUTHOR
 798
 799 Kenneth Albanowski <kjahds@kjahds.com>
 800
 801 Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
 802 and others.
 803
 804 =cut
 805
 806 #
 807 # Version 2.03: Sun Apr 23 16:56:34 BST 2000
 808 #       Hugo van der Sanden <hv@crypt0.demon.co.uk>
 809 #       don't die when 'use blib' fails
 810 # Version 2.02: Mon Mar 13 18:03:04 MST 2000
 811 #       Tom Christiansen <tchrist@perl.com>
 812 #       Added -U insecurity option
 813 # Version 2.01: Sat Mar 11 15:22:33 MST 2000
 814 #       Tom Christiansen <tchrist@perl.com>, querulously.
 815 #       Security and correctness patches.
 816 #       What a twisted bit of distasteful spaghetti code.
 817 # Version 2.0: ????
 818 # Version 1.15: Tue Aug 24 01:50:20 EST 1999
 819 #       Charles Wilson <cwilson@ece.gatech.edu>
 820 #       changed /pod/ directory to /pods/ for cygwin
 821 #         to support cygwin/win32
 822 # Version 1.14: Wed Jul 15 01:50:20 EST 1998
 823 #       Robin Barker <rmb1@cise.npl.co.uk>
 824 #       -strict, -w cleanups
 825 # Version 1.13: Fri Feb 27 16:20:50 EST 1997
 826 #       Gurusamy Sarathy <gsar@activestate.com>
 827 #       -doc tweaks for -F and -X options
 828 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
 829 #       Gurusamy Sarathy <gsar@activestate.com>
 830 #       -various fixes for win32
 831 # Version 1.11: Tue Dec 26 09:54:33 EST 1995
 832 #       Kenneth Albanowski <kjahds@kjahds.com>
 833 #   -added Charles Bailey's further VMS patches, and -u switch
 834 #   -added -t switch, with pod2text support
 835 #
 836 # Version 1.10: Thu Nov  9 07:23:47 EST 1995
 837 #               Kenneth Albanowski <kjahds@kjahds.com>
 838 #       -added VMS support
 839 #       -added better error recognition (on no found pages, just exit. On
 840 #        missing nroff/pod2man, just display raw pod.)
 841 #       -added recursive/case-insensitive matching (thanks, Andreas). This
 842 #        slows things down a bit, unfortunately. Give a precise name, and
 843 #        it'll run faster.
 844 #
 845 # Version 1.01: Tue May 30 14:47:34 EDT 1995
 846 #               Andy Dougherty  <doughera@lafcol.lafayette.edu>
 847 #   -added pod documentation.
 848 #   -added PATH searching.
 849 #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
 850 #    and friends.
 851 #
 852 #
 853 # TODO:
 854 #
 855 #       Cache directories read during sloppy match
 856 !NO!SUBS!
 857
 858 close OUT or die "Can't close $file: $!";
 859 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 860 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 861 chdir $origdir;