home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / utils / perldoc.PL < prev    next >
Perl Script  |  2000-03-13  |  23KB  |  857 lines
  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;
  857.