From: Gurusamy Sarathy Date: Sun, 9 May 1999 20:00:09 +0000 (+0000) Subject: perldoc cleanups (variant of changes suggested by Christian Lemburg X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=febd60db78d69754497d8360da8c221b5cd2747b;p=p5sagit%2Fp5-mst-13.2.git perldoc cleanups (variant of changes suggested by Christian Lemburg ) p4raw-id: //depot/perl@3348 --- diff --git a/utils/perldoc.PL b/utils/perldoc.PL index e591479..bd23350 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -47,7 +47,7 @@ print OUT <<'!NO!SUBS!'; # man replacement, written in perl. This perldoc is strictly for reading # the perl manuals, though it too is written in perl. -if(@ARGV<1) { +if (@ARGV<1) { my $me = $0; # Editing $0 is unportable $me =~ s,.*/,,; die < 1) { +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 || $Is_Dos) { +} +elsif ($Is_MSWin32 || $Is_Dos) { $opt_t = 1 unless $opts } @@ -149,11 +150,13 @@ 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; + @pages = ("perlfunc"); +} +elsif ($opt_q) { + @pages = ("perlfaq1" .. "perlfaq9"); +} +else { + @pages = @ARGV; } # Does this look like a module or extension directory? @@ -164,15 +167,13 @@ if (-f "Makefile.PL") { require ExtUtils::testlib; } - - sub containspod { my($file, $readit) = @_; return 1 if !$readit && $file =~ /\.pod$/i; local($_); open(TEST,"<$file"); - while() { - if(/^=head/) { + while () { + if (/^=head/) { close(TEST); return 1; } @@ -186,7 +187,7 @@ sub minus_f_nocase { 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 + # 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 ''; @@ -198,7 +199,7 @@ sub minus_f_nocase { foreach $p (split(/\//, $file)){ my $try = "@p/$p"; stat $try; - if (-d _){ + if (-d _) { push @p, $p; if ( $p eq $global_target) { my $tmp_path = join ('/', @p); @@ -209,11 +210,14 @@ sub minus_f_nocase { push (@global_found, $tmp_path) unless $path_f; print STDERR "Found as @p but directory\n" if $opt_v; } - } elsif (-f _ && -r _) { + } + elsif (-f _ && -r _) { return $try; - } elsif (-f _) { + } + elsif (-f _) { warn "Ignored $try: unreadable\n"; - } else { + } + else { my $found=0; my $lcp = lc $p; opendir DIR, "@p"; @@ -238,7 +242,8 @@ sub check_file { my($dir,$file) = @_; if ($opt_m) { return minus_f_nocase($dir,$file); - } else { + } + else { my $path = minus_f_nocase($dir,$file); return $path if length $path and containspod($path); } @@ -264,7 +269,7 @@ sub searchfor { or ( $ret = check_file $dir,$s) or ( $Is_VMS and $ret = check_file $dir,"$s.com") - or ( $^O eq 'os2' and + or ( $^O eq 'os2' and $ret = check_file $dir,"$s.cmd") or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and $ret = check_file $dir,"$s.bat") @@ -300,73 +305,142 @@ sub filter_nroff { join "\n\n", @data; } +sub printout { + my ($file, $tmp, $filter) = @_; + my $err; + + if ($opt_t) { + open(TMP,">>$tmp") + or warn("Can't open $tmp: $!"), return; + Pod::Text::pod2text($file,*TMP); + close TMP; + } + elsif (not $opt_u) { + my $cmd = "pod2man --lax $file | nroff -man"; + $cmd .= " | col -x" if $^O =~ /hpux/; + my $rslt = `$cmd`; + $rslt = filter_nroff($rslt) if $filter; + unless (($err = $?)) { + open(TMP,">>$tmp") or warn("Can't open $tmp: $!"), return; + print TMP $rslt; + close TMP; + } + } + if ($opt_u or $err or -z $tmp) { + open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; + open(IN,"<$file") or warn("Can't open $file: $!"), return; + my $cut = 1; + while () { + $cut = $1 eq 'cut' if /^=(\w+)/; + next if $cut; + print OUT; + } + close IN; + close OUT; + } +} + +sub page { + my ($tmp, $no_tty, @pagers) = @_; + if ($no_tty) { + open(TMP,"<$tmp") or warn("Can't open $tmp: $!"), return; + print while ; + close TMP; + } + else { + foreach my $pager (@pagers) { + system("$pager $tmp") or last; + } + } +} + +sub cleanup { + my @files = @_; + for (@files) { + 1 while unlink($_); #Possibly pointless VMSism + } +} + +sub safe_exit { + my ($val, @files) = @_; + cleanup(@files); + exit $val; +} + +sub safe_die { + my ($msg, @files) = @_; + cleanup(@files); + die $msg; +} + 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 () { - 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. - my @searchdirs = @INC; - if ($opt_F) { - next unless -r; - push @found, $_ if $opt_m or containspod($_); - next; + if ($podidx && open(PODIDX, $podidx)) { + my $searchfor = $_; + local($_); + $searchfor =~ s,::,/,g; + print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + while () { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; } - 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'}))); + 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. + 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'}))); } - my @files = searchfor(0,$_,@searchdirs); - if( @files ) { - print STDERR "Found as @files\n" if $opt_v; - } else { - # no match, try recursive search - - @searchdirs = grep(!/^\.$/,@INC); - - @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"; - for my $dir (@global_found) { - opendir(DIR, $dir) or die "$!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./); - $file =~ s/\.(pm|pod)$//; - print STDERR "\tperldoc $_\::$file\n"; - } - closedir DIR; - } - } + } + my @files = searchfor(0,$_,@searchdirs); + if (@files) { + print STDERR "Found as @files\n" if $opt_v; + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.$/,@INC); + @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"; + for my $dir (@global_found) { + opendir(DIR, $dir) or die "$!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./); + $file =~ s/\.(pm|pod)$//; + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR; } + } } - push(@found,@files); + } + push(@found,@files); } -if(!@found) { - exit ($Is_VMS ? 98962 : 1); +if (!@found) { + exit ($Is_VMS ? 98962 : 1); } if ($opt_l) { @@ -377,164 +451,143 @@ if ($opt_l) { my $lines = $ENV{LINES} || 24; my $no_tty; -if( ! -t STDOUT ) { $no_tty = 1 } +if (! -t STDOUT) { $no_tty = 1 } + +# until here we could simply exit or die +# now we create temporary files that we have to clean up +# namely $tmp, $buffer my $tmp; +my $buffer; if ($Is_MSWin32) { - $tmp = "$ENV{TEMP}\\perldoc1.$$"; - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - for (@found) { s,/,\\,g } -} 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.$$"; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + $tmp = "$ENV{TEMP}\\perldoc1.$$"; + $buffer = "$ENV{TEMP}\\perldoc1.b$$"; + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + for (@found) { s,/,\\,g } +} +elsif ($Is_VMS) { + $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; + $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$; + push @pagers, qw( most more less type/page ); +} +elsif ($Is_Dos) { + $tmp = "$ENV{TEMP}/perldoc1.$$"; + $buffer = "$ENV{TEMP}/perldoc1.b$$"; + $tmp =~ tr!\\/!//!s; + $buffer =~ 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(); + $buffer = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; + } + else { + $tmp = "/tmp/perldoc1.$$"; + $buffer = "/tmp/perldoc1.b$$"; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; +# all exit calls from here on have to be safe_exit calls (see above) +# and all die calls safe_die calls to guarantee removal of files and +# dir as needed + if ($opt_m) { - foreach my $pager (@pagers) { - system("$pager @found") or exit; - } - if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } - exit 1; + foreach my $pager (@pagers) { + system("$pager @found") or safe_exit(0, $tmp, $buffer); + } + if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } + # I don't get the line above. Please patch yourself as needed. + safe_exit(1, $tmp, $buffer); } my @pod; 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 () { - last if /^=head2 Alphabetical Listing of Perl Functions/; - } - - # Look for our function - my $found = 0; - my $inlist = 0; - while () { - if (/^=item\s+\Q$search_string\E\b/o) { - $found = 1; - } elsif (/^=item/) { - last if $found > 1 and not $inlist; - } - next unless $found; - if (/^=over/) { - ++$inlist; - } - elsif (/^=back/) { - --$inlist; - } - push @pod, $_; - ++$found if /^\w/; # found descriptive text - } - if (!@pod) { - die "No documentation for perl function `$opt_f' found\n"; - } -} + my $perlfunc = shift @found; + open(PFUNC, $perlfunc) + or safe_die("Can't open $perlfunc: $!", $tmp, $buffer); -if ($opt_q) { - local @ARGV = @found; # I'm lazy, sue me. - my $found = 0; - my %found_in; - - 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) { - die "No documentation for perl FAQ keyword `$opt_q' found\n"; - } -} - -my $tmp1; -my $filter; - -if (@pod) { - $tmp1 = $tmp . "_"; - open(TMP,">$tmp1") or die "open '$tmp1': $!"; - print TMP "=over 8\n\n"; - print TMP @pod; - print TMP "=back\n"; - close(TMP) or die "close '$tmp1': $!"; - @found = $tmp1; - $filter = 1; -} + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? 'I<-X' : $opt_f ; -foreach (@found) { + # Skip introduction + while () { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } - my $err; - if($opt_t) { - open(TMP,">>$tmp"); - Pod::Text::pod2text($_,*TMP); - close(TMP); - } elsif(not $opt_u) { - my $cmd = "pod2man --lax $_ | nroff -man"; - $cmd .= " | col -x" if $^O =~ /hpux/; - my $rslt = `$cmd`; - $rslt = filter_nroff $rslt if $filter; - unless(($err = $?)) { - open(TMP,">>$tmp"); - print TMP $rslt; - close TMP; - } + # Look for our function + my $found = 0; + my $inlist = 0; + while () { + if (/^=item\s+\Q$search_string\E\b/o) { + $found = 1; } - - if( $opt_u or $err or -z $tmp) { - open(OUT,">>$tmp"); - open(IN,"<$_"); - my $cut = 1; - while () { - $cut = $1 eq 'cut' if /^=(\w+)/; - next if $cut; - print OUT; - } - close(IN); - close(OUT); + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + --$inlist; } + push @pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@pod) { + die "No documentation for perl function `$opt_f' found\n"; + } } -if( $no_tty ) { - open(TMP,"<$tmp"); - print while ; - close(TMP); -} else { - foreach my $pager (@pagers) { - system("$pager $tmp") or last; +if ($opt_q) { + local @ARGV = @found; # I'm lazy, sue me. + my $found = 0; + my %found_in; + + 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) { + safe_die("No documentation for perl FAQ keyword `$opt_q' found\n", + $tmp, $buffer); + } +} + +my $filter; + +if (@pod) { + open(TMP,">$buffer") or safe_die("Can't open '$buffer': $!", $tmp, $buffer); + print TMP "=over 8\n\n"; + print TMP @pod; + print TMP "=back\n"; + close TMP; + @found = $buffer; + $filter = 1; } -1 while unlink($tmp); #Possibly pointless VMSism -if (defined $tmp1) { - 1 while unlink($tmp1); #Possibly pointless VMSism +foreach (@found) { + printout($_, $tmp, $filter); } +page($tmp, $no_tty, @pagers); -exit 0; +safe_exit(0, $tmp, $buffer); __END__ @@ -627,7 +680,7 @@ name, you will only get the first one. =head1 ENVIRONMENT -Any switches in the C environment variable will be used before the +Any switches in the C environment variable will be used before the command line arguments. C also searches directories specified by the C (or C if C is not defined) and C environment variables. @@ -639,11 +692,16 @@ used if C was told to display plain text or unformatted pod.) One useful value for C is C. +=head1 VERSION + +This is perldoc v2.0. + =head1 AUTHOR Kenneth Albanowski -Minor updates by Andy Dougherty +Minor updates by Andy Dougherty , +and others. =cut @@ -661,7 +719,7 @@ Minor updates by Andy Dougherty # Kenneth Albanowski # -added Charles Bailey's further VMS patches, and -u switch # -added -t switch, with pod2text support -# +# # Version 1.10: Thu Nov 9 07:23:47 EST 1995 # Kenneth Albanowski # -added VMS support