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