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