perl5.005_03 (stock)

1 files changed, 205 insertions, 56 deletions

diff --git a/gnu/usr.bin/perl/utils/perldoc.PL b/gnu/usr.bin/perl/utils/perldoc.PL
index d223a9aaf90..26335101c01 100644
--- a/gnu/usr.bin/perl/utils/perldoc.PL
+++ b/gnu/usr.bin/perl/utils/perldoc.PL
@@ -2,6 +2,7 @@
 
 use Config;
 use File::Basename qw(&basename &dirname);
+use Cwd;
 
 # List explicitly here the variables you want Configure to
 # generate.  Metaconfig only looks for shell variables, so you
@@ -12,6 +13,7 @@ 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.
+$origdir = cwd;
 chdir dirname($0);
 $file = basename($0, '.PL');
 $file .= '.com' if $^O eq 'VMS';
@@ -26,9 +28,10 @@ print "Extracting $file (with variable substitutions)\n";
 print OUT <<"!GROK!THIS!";
 $Config{startperl}
     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
-	if \$running_under_some_shell;
+	if 0;
 
-\@pagers = ();
+use strict;
+my \@pagers = ();
 push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
 !GROK!THIS!
 
@@ -45,25 +48,27 @@ print OUT <<'!NO!SUBS!';
 # the perl manuals, though it too is written in perl.
 
 if(@ARGV<1) {
-	$me = $0;		# Editing $0 is unportable
+	my $me = $0;		# Editing $0 is unportable
 	$me =~ s,.*/,,;
 	die <<EOF;
-Usage: $me [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName
+Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName
        $me -f PerlFunc
+       $me -q FAQKeywords
 
-We suggest you use "perldoc perldoc" to get aquainted 
-with the system.
+The -h option prints more help.  Also try "perldoc perldoc" to get
+aquainted with the system.
 EOF
 }
 
 use Getopt::Std;
 use Config '%Config';
 
-@global_found = ();
-$global_target = "";
+my @global_found = ();
+my $global_target = "";
 
-$Is_VMS = $^O eq 'VMS';
-$Is_MSWin32 = $^O eq 'MSWin32';
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $Is_Dos = $^O eq 'dos';
 
 sub usage{
     warn "@_\n" if @_;
@@ -72,15 +77,21 @@ sub usage{
     die <<EOF;
 perldoc [options] PageName|ModuleName|ProgramName...
 perldoc [options] -f BuiltinFunction
+perldoc [options] -q FAQRegex
 
 Options:
     -h   Display this help message
+    -r   Recursive search (slow)
+    -i   Ignore case 
     -t   Display pod using pod2text instead of pod2man and nroff
              (-t is the default on win32)
     -u	 Display unformatted pod text
-    -m   Display modules file in its entirety
-    -l   Display the modules file name
+    -m   Display module's file in its entirety
+    -l   Display the module's file name
+    -F   Arguments are file names, not modules
     -v	 Verbosely describe what's going on
+    -X	 use index if present (looks for pod.idx at $Config{archlib})
+    -q   Search the text of questions (not answers) in perlfaq[1-9]
 
 PageName|ModuleName...
          is the name of a piece of documentation that you want to look at. You 
@@ -92,32 +103,55 @@ PageName|ModuleName...
 BuiltinFunction
          is the name of a perl function.  Will extract documentation from
          `perlfunc'.
-         
+
+FAQRegex
+         is a regex. Will search perlfaq[1-9] for and extract any
+         questions that match.
+
 Any switches in the PERLDOC environment variable will be used before the 
-command line arguments.
+command line arguments.  The optional pod index file contains a list of
+filenames, one per line.
 
 EOF
 }
 
-use Text::ParseWords;
+if( defined $ENV{"PERLDOC"} ) {
+    require Text::ParseWords;
+    unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
+}
+!NO!SUBS!
 
+my $getopts = "mhtluvriFf:Xq:";
+print OUT <<"!GET!OPTS!";
 
-unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
+use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
 
-getopts("mhtluvf:") || usage;
+getopts("$getopts") || usage;
+!GET!OPTS!
 
-usage if $opt_h || $opt_h; # avoid -w warning
+print OUT <<'!NO!SUBS!';
 
-if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
+usage if $opt_h;
+
+my $podidx;
+if( $opt_X ) {
+    $podidx = "$Config{'archlib'}/pod.idx";
+    $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
+}
+
+if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
     usage("only one of -t, -u, -m or -l")
-} elsif ($Is_MSWin32) {
-    $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
+} elsif ($Is_MSWin32 || $Is_Dos) {
+    $opt_t = 1 unless $opts
 }
 
 if ($opt_t) { require Pod::Text; import Pod::Text; }
 
+my @pages;
 if ($opt_f) {
    @pages = ("perlfunc");
+} elsif ($opt_q) {
+   @pages = ("perlfaq1" .. "perlfaq9");
 } else {
    @pages = @ARGV;
 }
@@ -148,23 +182,26 @@ sub containspod {
 }
 
 sub minus_f_nocase {
-     my($file) = @_;
-     # on a case-forgiving file system we can simply use -f $file
-     if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') {
-        return $file if -f $file and -r _;
-	warn "Ignored $file: unreadable\n" unless -r _;
+     my($dir,$file) = @_;
+     my $path = join('/',$dir,$file);
+     return $path if -f $path and -r _;
+     if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
+        # on a case-forgiving file system or if case is important 
+	# that is it all we can do
+	warn "Ignored $path: unreadable\n" if -f _;
 	return '';
      }
      local *DIR;
      local($")="/";
-     my(@p,$p,$cip);
+     my @p = ($dir);
+     my($p,$cip);
      foreach $p (split(/\//, $file)){
 	my $try = "@p/$p";
 	stat $try;
  	if (-d _){
  	    push @p, $p;
 	    if ( $p eq $global_target) {
-		$tmp_path = join ('/', @p);
+		my $tmp_path = join ('/', @p);
 		my $path_f = 0;
 		for (@global_found) {
 		    $path_f = 1 if $_ eq $tmp_path;
@@ -190,16 +227,22 @@ sub minus_f_nocase {
  	    return "" unless $found;
  	    push @p, $cip;
  	    return "@p" if -f "@p" and -r _;
-	    warn "Ignored $file: unreadable\n" if -f _;
+	    warn "Ignored @p: unreadable\n" if -f _;
  	}
      }
-     return; # is not a file
+     return "";
 }
  
 
 sub check_file {
-    my($file) = @_;
-    return minus_f_nocase($file) && containspod($file) ? $file : "";
+    my($dir,$file) = @_;
+    if ($opt_m) {
+	return minus_f_nocase($dir,$file);
+    } else {
+	my $path = minus_f_nocase($dir,$file);
+        return $path if length $path and containspod($path);
+    }
+    return "";
 }
 
 
@@ -216,17 +259,17 @@ sub searchfor {
     for ($i=0; $i<@dirs; $i++) {
 	$dir = $dirs[$i];
 	($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
-	if (       ( $ret = check_file "$dir/$s.pod")
-		or ( $ret = check_file "$dir/$s.pm")
-		or ( $ret = check_file "$dir/$s")
+	if (       ( $ret = check_file $dir,"$s.pod")
+		or ( $ret = check_file $dir,"$s.pm")
+		or ( $ret = check_file $dir,$s)
 		or ( $Is_VMS and
-		     $ret = check_file "$dir/$s.com")
+		     $ret = check_file $dir,"$s.com")
 		or ( $^O eq 'os2' and 
-		     $ret = check_file "$dir/$s.cmd")
-		or ( ($Is_MSWin32 or $^O eq 'os2') and 
-		     $ret = check_file "$dir/$s.bat")
-		or ( $ret = check_file "$dir/pod/$s.pod")
-		or ( $ret = check_file "$dir/pod/$s")
+		     $ret = check_file $dir,"$s.cmd")
+		or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
+		     $ret = check_file $dir,"$s.bat")
+		or ( $ret = check_file "$dir/pod","$s.pod")
+		or ( $ret = check_file "$dir/pod",$s)
 	) {
 	    return $ret;
 	}
@@ -248,24 +291,42 @@ sub searchfor {
     return ();
 }
 
-
+my @found;
 foreach (@pages) {
+        if ($podidx && open(PODIDX, $podidx)) {
+	    my $searchfor = $_;
+	    local($_);
+	    $searchfor =~ s,::,/,g;
+	    print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
+	    while (<PODIDX>) {
+		chomp;
+		push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
+	    }
+	    close(PODIDX);
+	    next;
+        }
 	print STDERR "Searching for $_\n" if $opt_v;
 	# We must look both in @INC for library modules and in PATH
 	# for executables, like h2xs or perldoc itself.
-	@searchdirs = @INC;
+	my @searchdirs = @INC;
+	if ($opt_F) {
+	  next unless -r;
+	  push @found, $_ if $opt_m or containspod($_);
+	  next;
+	}
 	unless ($opt_m) { 
 	    if ($Is_VMS) {
 		my($i,$trn);
 		for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
 		    push(@searchdirs,$trn);
 		}
+		push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
 	    } else {
 	        push(@searchdirs, grep(-d, split($Config{path_sep}, 
 						 $ENV{'PATH'})));
 	    }
-	    @files= searchfor(0,$_,@searchdirs);
 	}
+	my @files = searchfor(0,$_,@searchdirs);
 	if( @files ) {
 		print STDERR "Found as @files\n" if $opt_v;
 	} else {
@@ -273,17 +334,16 @@ foreach (@pages) {
 		
 		@searchdirs = grep(!/^\.$/,@INC);
 		
-		@files= searchfor(1,$_,@searchdirs);
+		@files= searchfor(1,$_,@searchdirs) if $opt_r;
 		if( @files ) {
 			print STDERR "Loosely found as @files\n" if $opt_v;
 		} else {
 			print STDERR "No documentation found for \"$_\".\n";
 			if (@global_found) {
 			    print STDERR "However, try\n";
-			    my $dir = $file = "";
-			    for $dir (@global_found) {
+			    for my $dir (@global_found) {
 				opendir(DIR, $dir) or die "$!";
-				while ($file = readdir(DIR)) {
+				while (my $file = readdir(DIR)) {
 				    next if ($file =~ /^\./);
 				    $file =~ s/\.(pm|pod)$//;
 				    print STDERR "\tperldoc $_\::$file\n";
@@ -305,8 +365,12 @@ if ($opt_l) {
     exit;
 }
 
+my $lines = $ENV{LINES} || 24;
+
+my $no_tty;
 if( ! -t STDOUT ) { $no_tty = 1 }
 
+my $tmp;
 if ($Is_MSWin32) {
 	$tmp = "$ENV{TEMP}\\perldoc1.$$";
 	push @pagers, qw( more< less notepad );
@@ -314,10 +378,16 @@ if ($Is_MSWin32) {
 } elsif ($Is_VMS) {
 	$tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
 	push @pagers, qw( most more less type/page );
+} elsif ($Is_Dos) {
+	$tmp = "$ENV{TEMP}/perldoc1.$$";
+	$tmp =~ tr!\\/!//!s;
+	push @pagers, qw( less.exe more.com< );
+	unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
 } else {
 	if ($^O eq 'os2') {
 	  require POSIX;
 	  $tmp = POSIX::tmpnam();
+	  unshift @pagers, 'less', 'cmd /c more <';
 	} else {
 	  $tmp = "/tmp/perldoc1.$$";	  
 	}
@@ -327,7 +397,7 @@ if ($Is_MSWin32) {
 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 
 if ($opt_m) {
-	foreach $pager (@pagers) {
+	foreach my $pager (@pagers) {
 		system("$pager @found") or exit;
 	}
 	if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
@@ -338,6 +408,9 @@ if ($opt_f) {
    my $perlfunc = shift @found;
    open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
 
+   # Functions like -r, -e, etc. are listed under `-X'.
+   my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ;
+
    # Skip introduction
    while (<PFUNC>) {
        last if /^=head2 Alphabetical Listing of Perl Functions/;
@@ -347,7 +420,7 @@ if ($opt_f) {
    my $found = 0;
    my @pod;
    while (<PFUNC>) {
-       if (/^=item\s+\Q$opt_f\E\b/o)  {
+       if (/^=item\s+\Q$search_string\E\b/o)  {
 	   $found = 1;
        } elsif (/^=item/) {
 	   last if $found > 1;
@@ -363,8 +436,15 @@ if ($opt_f) {
 	   print FORMATTER @pod;
 	   print FORMATTER "=back\n";
 	   close(FORMATTER);
-       } else {
+       } elsif (@pod < $lines-2) {
 	   print @pod;
+       } else {
+	   foreach my $pager (@pagers) {
+		open (PAGER, "| $pager") or next;
+		print PAGER @pod ;
+		close(PAGER) or next;
+		last;
+	   }
        }
    } else {
        die "No documentation for perl function `$opt_f' found\n";
@@ -372,8 +452,49 @@ if ($opt_f) {
    exit;
 }
 
+if ($opt_q) {
+   local @ARGV = @found;	# I'm lazy, sue me.
+   my $found = 0;
+   my %found_in;
+   my @pod;
+
+   while (<>) {
+      if (/^=head2\s+.*(?:$opt_q)/oi) {
+	 $found = 1;
+	 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
+      } elsif (/^=head2/) {
+	 $found = 0;
+      }
+      next unless $found;
+      push @pod, $_;
+   }
+   
+   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);
+      } elsif (@pod < $lines-2) {
+	 print @pod;
+      } else {
+	 foreach my $pager (@pagers) {
+	    open (PAGER, "| $pager") or next;
+	    print PAGER @pod ;
+	    close(PAGER) or next;
+	    last;
+	 }
+      }
+   } else {
+      die "No documentation for perl FAQ keyword `$opt_q' found\n";
+   }
+   exit;
+}
+
 foreach (@found) {
 
+	my $err;
 	if($opt_t) {
 		open(TMP,">>$tmp");
 		Pod::Text::pod2text($_,*TMP);
@@ -381,7 +502,7 @@ foreach (@found) {
 	} elsif(not $opt_u) {
 		my $cmd = "pod2man --lax $_ | nroff -man";
 		$cmd .= " | col -x" if $^O =~ /hpux/;
-		$rslt = `$cmd`;
+		my $rslt = `$cmd`;
 		unless(($err = $?)) {
 			open(TMP,">>$tmp");
 			print TMP $rslt;
@@ -392,7 +513,7 @@ foreach (@found) {
 	if( $opt_u or $err or -z $tmp) {
 		open(OUT,">>$tmp");
 		open(IN,"<$_");
-		$cut = 1;
+		my $cut = 1;
 		while (<IN>) {
 			$cut = $1 eq 'cut' if /^=(\w+)/;
 			next if $cut;
@@ -408,7 +529,7 @@ if( $no_tty ) {
 	print while <TMP>;
 	close(TMP);
 } else {
-	foreach $pager (@pagers) {
+	foreach my $pager (@pagers) {
 		system("$pager $tmp") or last;
 	}
 }
@@ -425,10 +546,12 @@ perldoc - Look up Perl documentation in pod format.
 
 =head1 SYNOPSIS
 
-B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] PageName|ModuleName|ProgramName
+B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
 
 B<perldoc> B<-f> BuiltinFunction
 
+B<perldoc> B<-q> FAQ Keyword
+
 =head1 DESCRIPTION
 
 I<perldoc> looks up a piece of documentation in .pod format that is embedded
@@ -472,11 +595,27 @@ the file for you and simply hand it off for display.
 
 Display the file name of the module found.
 
+=item B<-F> file names
+
+Consider arguments as file names, no search in directories will be performed.
+
 =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<-q> perlfaq
+
+The B<-q> option takes a regular expression as an argument.  It will search
+the question headings in perlfaq[1-9] and print the entries matching
+the regular expression.
+
+=item B<-X> use an index if present
+
+The B<-X> option looks for a entry whose basename matches the name given on the
+command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
+contain fully qualified filenames, one per line.
+
 =item B<PageName|ModuleName|ProgramName>
 
 The item you want to look up.  Nested modules (such as C<File::Basename>)
@@ -495,7 +634,10 @@ command line arguments.  C<perldoc> also searches directories
 specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
 defined) and C<PATH> environment variables.
 (The latter is so that embedded pods for executables, such as
-C<perldoc> itself, are available.)
+C<perldoc> itself, are available.)  C<perldoc> will use, in order of
+preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
+C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
+used if C<perldoc> was told to display plain text or unformatted pod.)
 
 =head1 AUTHOR
 
@@ -506,6 +648,12 @@ Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 =cut
 
 #
+# Version 1.14: Wed Jul 15 01:50:20 EST 1998
+#       Robin Barker <rmb1@cise.npl.co.uk>
+#	-strict, -w cleanups
+# Version 1.13: Fri Feb 27 16:20:50 EST 1997
+#       Gurusamy Sarathy <gsar@umich.edu>
+#	-doc tweaks for -F and -X options
 # Version 1.12: Sat Apr 12 22:41:09 EST 1997
 #       Gurusamy Sarathy <gsar@umich.edu>
 #	-various fixes for win32
@@ -539,3 +687,4 @@ Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
 close OUT or die "Can't close $file: $!";
 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;