This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from match from perl-5.003_93 to perl-5.003_94]
[perl5.git] / utils / perldoc.PL
index 3106cbc..7febd01 100644 (file)
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
 
 # This forces PL files to create target in same directory as PL file.
 # This is so that make depend always knows where to find PL derivatives.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
-       if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
 
 open OUT,">$file" or die "Can't create $file: $!";
 
@@ -46,8 +45,10 @@ print OUT <<'!NO!SUBS!';
 # the perl manuals, though it too is written in perl.
 
 if(@ARGV<1) {
+        $0 =~ s,.*/,,;
        die <<EOF;
 Usage: $0 [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName
+       $0 -f PerlFunc
 
 We suggest you use "perldoc perldoc" to get aquainted 
 with the system.
@@ -58,24 +59,31 @@ use Getopt::Std;
 $Is_VMS = $^O eq 'VMS';
 
 sub usage{
-        warn "@_\n" if @_;
-    # Make sure exit status is success under VMS, so shell doesn't
-    # display error messages left over from startup.
-    ($! = 0, $^E = 1) if $^O eq 'VMS';
+    warn "@_\n" if @_;
+    # Erase evidence of previous errors (if any), so exit status is simple.
+    $! = 0;
     die <<EOF;
-perldoc [-h] [-v] [-u] PageName|ModuleName|ProgramName...
+perldoc [options] PageName|ModuleName|ProgramName...
+perldoc [options] -f BuiltinFunction
+
+Options:
     -h   Display this help message.
     -t   Display pod using pod2text instead of pod2man and nroff.
     -u  Display unformatted pod text
     -m   Display modules file in its entirety
     -l   Display the modules file name
     -v  Verbosely describe what's going on.
+
 PageName|ModuleName...
          is the name of a piece of documentation that you want to look at. You 
          may either give a descriptive name of the page (as in the case of
          `perlfunc') the name of a module, either like `Term::Info', 
          `Term/Info', the partial name of a module, like `info', or 
          `makemaker', or the name of a program, like `perldoc'.
+
+BuiltinFunction
+         is the name of a perl function.  Will extract documentation from
+         `perlfunc'.
          
 Any switches in the PERLDOC environment variable will be used before the 
 command line arguments.
@@ -88,7 +96,7 @@ use Text::ParseWords;
 
 unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
 
-getopts("mhtluv") || usage;
+getopts("mhtluvf:") || usage;
 
 usage if $opt_h || $opt_h; # avoid -w warning
 
@@ -96,7 +104,13 @@ usage("only one of -t, -u, -m or -l") if $opt_t + $opt_u + $opt_m + $opt_l > 1;
 
 if ($opt_t) { require Pod::Text; import Pod::Text; }
 
-@pages = @ARGV;
+if ($opt_f) {
+   @pages = ("perlfunc");
+} else {
+   @pages = @ARGV;
+}
+
+
 
 sub containspod {
        my($file) = @_;
@@ -151,14 +165,11 @@ sub containspod {
        my($recurse,$s,@dirs) = @_;
        $s =~ s!::!/!g;
        $s = VMS::Filespec::unixify($s) if $Is_VMS;
+       return $s if -f $s && containspod($s);
        printf STDERR "looking for $s in @dirs\n" if $opt_v;
        my $ret;
        my $i;
        my $dir;
-
-       if (-f $s and containspod $s) {
-               return $s;
-       }
        for ($i=0;$i<@dirs;$i++) {
                $dir = $dirs[$i];
                ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
@@ -228,7 +239,7 @@ if ($opt_l) {
     exit;
 }
 
-if( ! -t STDOUT ) { $opt_f = 1 }
+if( ! -t STDOUT ) { $no_tty = 1 }
 
 unless($Is_VMS) {
        $tmp = "/tmp/perldoc1.$$";
@@ -241,13 +252,48 @@ unless($Is_VMS) {
 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 
 if ($opt_m) {
-    foreach $pager (@pagers) {
-       my($sts) = system("$pager @found");
-       exit 0 if ($Is_VMS ? ($sts & 1) : !$sts);
-    }
-    exit $Is_VMS ? $sts : 1;
+       foreach $pager (@pagers) {
+               system("$pager @found") or exit;
+       }
+       if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
+       exit 1;
 } 
 
+if ($opt_f) {
+   my $perlfunc = shift @found;
+   open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
+
+   # Skip introduction
+   while (<PFUNC>) {
+       last if /^=head2 Alphabetical Listing of Perl Functions/;
+   }
+
+   # Look for our function
+   my $found = 0;
+   while (<PFUNC>) {
+       if (/^=item\s+\Q$opt_f\E\b/o)  {
+          $found++;
+       } elsif (/^=item/) {
+          last if $found;
+       }
+       push(@pod, $_) if $found;
+   }
+   if (@pod) {
+       if ($opt_t) {
+          open(FORMATTER, "| pod2text") || die "Can't start filter";
+          print FORMATTER "=over 8\n\n";
+          print FORMATTER @pod;
+          print FORMATTER "=back\n";
+          close(FORMATTER);
+       } else {
+          print @pod;
+       }
+   } else {
+       die "No documentation for perl function `$func' found\n";
+   }
+   exit;
+}
+
 foreach (@found) {
 
        if($opt_t) {
@@ -255,16 +301,14 @@ foreach (@found) {
                Pod::Text::pod2text($_,*TMP);
                close(TMP);
        } elsif(not $opt_u) {
-               open(TMP,">>$tmp");
-               if($^O =~ /hpux/) {
-                       $rslt = `pod2man $_ | nroff -man | col -x`;
-               } else {
-                       $rslt = `pod2man $_ | nroff -man`;
+               my $cmd = "pod2man --lax $_ | nroff -man";
+               $cmd .= " | col -x" if $^O =~ /hpux/;
+               $rslt = `$cmd`;
+               unless(($err = $?)) {
+                       open(TMP,">>$tmp");
+                       print TMP $rslt;
+                       close TMP;
                }
-               if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
-               else      { $err = $?; }
-               print TMP $rslt unless $err;
-               close TMP;
        }
                                                        
        if( $opt_u or $err or -z $tmp) {
@@ -281,15 +325,13 @@ foreach (@found) {
        }
 }
 
-if( $opt_f ) {
+if( $no_tty ) {
        open(TMP,"<$tmp");
        print while <TMP>;
        close(TMP);
 } else {
        foreach $pager (@pagers) {
-               $sts = system("$pager $tmp");
-               last if $Is_VMS && ($sts & 1);
-               last unless $sts;
+               system("$pager $tmp") or last;
        }
 }
 
@@ -307,6 +349,8 @@ perldoc - Look up Perl documentation in pod format.
 
 B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] PageName|ModuleName|ProgramName
 
+B<perldoc> B<-f> BuiltinFunction
+
 =head1 DESCRIPTION
 
 I<perldoc> looks up a piece of documentation in .pod format that is embedded
@@ -350,6 +394,11 @@ the file for you and simply hand it off for display.
 
 Display the file name of the module found.
 
+=item B<-f> perlfunc
+
+The B<-f> option followed by the name of a perl built in function will
+extract the documentation of this function from L<perlfunc>.
+
 =item B<PageName|ModuleName|ProgramName>
 
 The item you want to look up.  Nested modules (such as C<File::Basename>)