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