diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Perldoc.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Pod/Perldoc.pm | 1100 |
1 files changed, 547 insertions, 553 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm index 083a6e907e1..a0dd24addc2 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm @@ -1,18 +1,19 @@ +use 5.006; # we use some open(X, "<", $y) syntax -require 5; -use 5.006; # we use some open(X, "<", $y) syntax package Pod::Perldoc; use strict; use warnings; use Config '%Config'; use Fcntl; # for sysopen +use File::Basename qw(basename); use File::Spec::Functions qw(catfile catdir splitdir); use vars qw($VERSION @Pagers $Bindir $Pod2man $Temp_Files_Created $Temp_File_Lifetime ); -$VERSION = '3.15_04'; +$VERSION = '3.17'; + #.......................................................................... BEGIN { # Make a DEBUG constant very first thing... @@ -27,6 +28,32 @@ BEGIN { # Make a DEBUG constant very first thing... } use Pod::Perldoc::GetOptsOO; # uses the DEBUG. +use Carp qw(croak carp); + +# these are also in BaseTo, which I don't want to inherit +sub debugging { + my $self = shift; + + ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() ) + } + +sub debug { + my( $self, @messages ) = @_; + return unless $self->debugging; + print STDERR map { "DEBUG : $_" } @messages; + } + +sub warn { + my( $self, @messages ) = @_; + + carp( join "\n", @messages, '' ); + } + +sub die { + my( $self, @messages ) = @_; + + croak( join "\n", @messages, '' ); + } #.......................................................................... @@ -35,13 +62,13 @@ sub FALSE () {return} sub BE_LENIENT () {1} BEGIN { - *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; - *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; - *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; - *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; - *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin; - *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux; - *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX; + *is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms; + *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32; + *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos; + *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2; + *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin; + *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux; + *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; } $Temp_File_Lifetime ||= 60 * 60 * 24 * 5; @@ -52,7 +79,7 @@ $Temp_File_Lifetime ||= 60 * 60 * 24 * 5; #.......................................................................... { my $pager = $Config{'pager'}; - push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS; + push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms; } $Bindir = $Config{'scriptdirexp'}; $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); @@ -83,7 +110,7 @@ sub opt_w_with { # Specify an option for the formatter subclass $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" $self->add_formatter_option( $option, $option_value ); } else { - warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; + $self->warn( qq("$value" isn't a good formatter option name. I'm ignoring it!\n ) ); } return; } @@ -99,17 +126,17 @@ sub opt_M_with { # specify formatter class name(s) # A mildly restrictive concept of what modulenames are valid. push @classes_to_add, $1; # untaint } else { - warn "\"$classname\" isn't a valid classname. Ignoring.\n"; + $self->warn( qq("$classname" isn't a valid classname. Ignoring.\n) ); } } - + unshift @{ $self->{'formatter_classes'} }, @classes_to_add; - + DEBUG > 3 and print( "Adding @classes_to_add to the list of formatter classes, " . "making them @{ $self->{'formatter_classes'} }.\n" ); - + return; } @@ -119,9 +146,9 @@ sub opt_V { # report version and exit (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), - + (chr(65) eq 'A') ? () : " (non-ASCII)", - + "\n", ; exit; @@ -152,14 +179,14 @@ sub opt_o_with { # "o" for output format if($rest =~ m/^(\w+)$/s) { $rest = $1; #untaint } else { - warn "\"$rest\" isn't a valid output format. Skipping.\n"; + $self->warn( qq("$rest" isn't a valid output format. Skipping.\n") ); return; } - + $self->aside("Noting \"$rest\" as desired output format...\n"); - + # Figure out what class(es) that could actually mean... - + my @classes; foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { # Messy but smart: @@ -168,10 +195,10 @@ sub opt_o_with { # "o" for output format "\L$rest", "\L\u$rest", "\U$rest" # And then try variations ) { + $self->aside("Considering $prefix$stem\n"); push @classes, $prefix . $stem; - #print "Considering $prefix$stem\n"; } - + # Tidier, but misses too much: #push @classes, $prefix . ucfirst(lc($rest)); } @@ -233,27 +260,27 @@ sub aside { # If we're in -D or DEBUG mode, say this. sub usage { my $self = shift; - warn "@_\n" if @_; - + $self->warn( "@_\n" ) if @_; + # Erase evidence of previous errors (if any), so exit status is simple. $! = 0; - - die <<EOF; -perldoc [options] PageName|ModuleName|ProgramName... + + CORE::die( <<EOF ); +perldoc [options] PageName|ModuleName|ProgramName|URL... perldoc [options] -f BuiltinFunction perldoc [options] -q FAQRegex perldoc [options] -v PerlVariable Options: -h Display this help message - -V report version + -V Report version -r Recursive search (slow) -i Ignore case - -t Display pod using pod2text instead of pod2man and nroff + -t Display pod using pod2text instead of Pod::Man and groff (-t is the default on win32 unless -n is specified) -u Display unformatted pod text -m Display module's file in its entirety - -n Specify replacement for nroff + -n Specify replacement for groff -l Display the module's file name -F Arguments are file names, not modules -D Verbosely describe what's going on @@ -263,20 +290,21 @@ Options: -M FormatterModuleNameToUse -w formatter_option:option_value -L translation_code Choose doc translation (if any) - -X use index if present (looks for pod.idx at $Config{archlib}) + -X Use index if present (looks for pod.idx at $Config{archlib}) -q Search the text of questions (not answers) in perlfaq[1-9] -f Search Perl built-in functions -v Search predefined Perl variables -PageName|ModuleName... +PageName|ModuleName|ProgramName|URL... 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' or like - `Term/Info', or the name of a program, like `perldoc'. + `Term/Info', or the name of a program, like `perldoc', or a URL + starting with http(s). BuiltinFunction is the name of a perl function. Will extract documentation from - `perlfunc'. + `perlfunc' or `perlop'. FAQRegex is a regex. Will search perlfaq[1-9] for and extract any @@ -292,18 +320,87 @@ EOF #.......................................................................... +sub program_name { + my( $self ) = @_; + + if( my $link = readlink( $0 ) ) { + $self->debug( "The value in $0 is a symbolic link to $link\n" ); + } + + my $basename = basename( $0 ); + + $self->debug( "\$0 is [$0]\nbasename is [$basename]\n" ); + # possible name forms + # perldoc + # perldoc-v5.14 + # perldoc-5.14 + # perldoc-5.14.2 + # perlvar # an alias mentioned in Camel 3 + { + my( $untainted ) = $basename =~ m/( + \A + perl + (?: doc | func | faq | help | op | toc | var # Camel 3 + ) + (?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version + (?: \. (?: bat | exe | com ) )? # possible extension + \z + ) + /x; + + $self->debug($untainted); + return $untainted if $untainted; + } + + $self->warn(<<"HERE"); +You called the perldoc command with a name that I didn't recognize. +This might mean that someone is tricking you into running a +program you don't intend to use, but it also might mean that you +created your own link to perldoc. I think your program name is +[$basename]. + +I'll allow this if the filename only has [a-zA-Z0-9._-]. +HERE + + { + my( $untainted ) = $basename =~ m/( + \A [a-zA-Z0-9._-]+ \z + )/x; + + $self->debug($untainted); + return $untainted if $untainted; + } + + $self->die(<<"HERE"); +I think that your name for perldoc is potentially unsafe, so I'm +going to disallow it. I'd rather you be safe than sorry. If you +intended to use the name I'm disallowing, please tell the maintainers +about it. Write to: + + Pod-Perldoc\@rt.cpan.org + +HERE +} + +#.......................................................................... + sub usage_brief { - my $me = $0; # Editing $0 is unportable + my $self = shift; + my $program_name = $self->program_name; + + CORE::die( <<"EOUSAGE" ); +Usage: $program_name [-hVriDtumFXlT] [-n nroffer_program] + [-d output_filename] [-o output_format] [-M FormatterModule] + [-w formatter_option:option_value] [-L translation_code] + PageName|ModuleName|ProgramName + +Examples: - $me =~ s,.*[/\\],,; # get basename - - die <<"EOUSAGE"; -Usage: $me [-h] [-V] [-r] [-i] [-D] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName - $me -f PerlFunc - $me -q FAQKeywords - $me -v PerlVar + $program_name -f PerlFunc + $program_name -q FAQKeywords + $program_name -v PerlVar -The -h option prints more help. Also try "perldoc perldoc" to get +The -h option prints more help. Also try "$program_name perldoc" to get acquainted with the system. [Perldoc v$VERSION] EOUSAGE @@ -311,7 +408,7 @@ EOUSAGE #.......................................................................... -sub pagers { @{ shift->{'pagers'} } } +sub pagers { @{ shift->{'pagers'} } } #.......................................................................... @@ -335,8 +432,8 @@ sub init { $self->{'args'} ||= \@ARGV; $self->{'found'} ||= []; $self->{'temp_file_list'} ||= []; - - + + $self->{'target'} = undef; $self->init_formatter_class_list; @@ -373,7 +470,7 @@ sub init_formatter_class_list { $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru $self->opt_o_with('text'); - $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos + $self->opt_o_with('man') unless $self->is_mswin32 || $self->is_dos || !($ENV{TERM} && ( ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i )); @@ -403,14 +500,14 @@ sub process { # TODO: make it deal with being invoked as various different things # such as perlfaq". - + return $self->usage_brief unless @{ $self->{'args'} }; $self->pagers_guessing; $self->options_reading; $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); $self->drop_privs_maybe; $self->options_processing; - + # Hm, we have @pages and @found, but we only really act on one # file per call, with the exception of the opt_q hack, and with # -l things @@ -419,7 +516,7 @@ sub process { my @pages; $self->{'pages'} = \@pages; - if( $self->opt_f) { @pages = ("perlfunc") } + if( $self->opt_f) { @pages = qw(perlfunc perlop) } elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } elsif( $self->opt_v) { @pages = ("perlvar") } else { @pages = @{$self->{'args'}}; @@ -434,11 +531,11 @@ sub process { $self->maybe_diddle_INC(); # for when we're apparently in a module or extension directory - + my @found = $self->grand_search_init(\@pages); - exit (IS_VMS ? 98962 : 1) unless @found; - - if ($self->opt_l) { + exit ($self->is_vms ? 98962 : 1) unless @found; + + if ($self->opt_l and not $self->opt_q ) { DEBUG and print "We're in -l mode, so byebye after this:\n"; print join("\n", @found), "\n"; return; @@ -459,8 +556,8 @@ my( %class_seen, %class_loaded ); sub find_good_formatter_class { my $self = $_[0]; my @class_list = @{ $self->{'formatter_classes'} || [] }; - die "WHAT? Nothing in the formatter class list!?" unless @class_list; - + $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list; + my $good_class_found; foreach my $c (@class_list) { DEBUG > 4 and print "Trying to load $c...\n"; @@ -469,22 +566,22 @@ sub find_good_formatter_class { $good_class_found = $c; last; } - + if($class_seen{$c}) { DEBUG > 4 and print "I've tried $c before, and it's no good. Skipping.\n"; next; } - + $class_seen{$c} = 1; - + if( $c->can('parse_from_file') ) { DEBUG > 4 and print "Interesting, the formatter class $c is already loaded!\n"; - + } elsif( - (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) - # the alway case-insensitive fs's + ( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2) + # the always case-insensitive filesystems and $class_seen{lc("~$c")}++ ) { DEBUG > 4 and print @@ -508,7 +605,7 @@ sub find_good_formatter_class { next; } } - + if( $c->can('parse_from_file') ) { DEBUG > 4 and print "Settling on $c\n"; my $v = $c->VERSION; @@ -520,13 +617,13 @@ sub find_good_formatter_class { DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; } } - - die "Can't find any loadable formatter class in @class_list?!\nAborting" + + $self->die( "Can't find any loadable formatter class in @class_list?!\nAborting" ) unless $good_class_found; - + $self->{'formatter_class'} = $good_class_found; $self->aside("Will format with the class $good_class_found\n"); - + return; } @@ -536,8 +633,8 @@ sub find_good_formatter_class { sub formatter_sanity_check { my $self = shift; my $formatter_class = $self->{'formatter_class'} - || die "NO FORMATTER CLASS YET!?"; - + || $self->die( "NO FORMATTER CLASS YET!?" ); + if(!$self->opt_T # so -T can FORCE sending to STDOUT and $formatter_class->can('is_pageable') and !$formatter_class->is_pageable @@ -548,11 +645,12 @@ sub formatter_sanity_check { && $formatter_class->output_extension ) || ''; $ext = ".$ext" if length $ext; - - die + + my $me = $self->program_name; + $self->die( "When using Perldoc to format with $formatter_class, you have to\n" . "specify -T or -dsomefile$ext\n" - . "See `perldoc perldoc' for more information on those switches.\n" + . "See `$me perldoc' for more information on those switches.\n" ) ; } } @@ -561,18 +659,18 @@ sub formatter_sanity_check { sub render_and_page { my($self, $found_list) = @_; - + $self->maybe_generate_dynamic_pod($found_list); my($out, $formatter) = $self->render_findings($found_list); - + if($self->opt_d) { printf "Perldoc (%s) output saved to %s\n", $self->{'formatter_class'} || ref($self), $out; print "But notice that it's 0 bytes long!\n" unless -s $out; - - + + } elsif( # Allow the formatter to "page" itself, if it wants. $formatter->can('page_for_perldoc') and do { @@ -587,25 +685,25 @@ sub render_and_page { } ) { # Do nothing, since the formatter has "paged" it for itself. - + } else { # Page it normally (internally) - + if( -s $out ) { # Usual case: $self->page($out, $self->{'output_to_stdout'}, $self->pagers); - + } else { # Odd case: $self->aside("Skipping $out (from $$found_list[0] " . "via $$self{'formatter_class'}) as it is 0-length.\n"); - + push @{ $self->{'temp_file_list'} }, $out; $self->unlink_if_temp_file($out); } } - + $self->after_rendering(); # any extra cleanup or whatever - + return; } @@ -613,7 +711,7 @@ sub render_and_page { sub options_reading { my $self = shift; - + if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { require Text::ParseWords; $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); @@ -636,7 +734,7 @@ sub options_reading { and print " Args after switch processing: @{$self->{'args'}}\n"; return $self->usage if $self->opt_h; - + return; } @@ -644,7 +742,7 @@ sub options_reading { sub options_processing { my $self = shift; - + if ($self->opt_X) { my $podidx = "$Config{'archlib'}/pod.idx"; $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; @@ -655,8 +753,11 @@ sub options_processing { $self->options_sanity; - $self->opt_n("nroff") unless $self->opt_n; - $self->add_formatter_option( '__nroffer' => $self->opt_n ); + # This used to set a default, but that's now moved into any + # formatter that cares to have a default. + if( $self->opt_n ) { + $self->add_formatter_option( '__nroffer' => $self->opt_n ); + } # Get language from PERLDOC_POD2 environment variable if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) { @@ -689,19 +790,19 @@ sub options_sanity { #; # #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; - - + + # Any sanity-checking need doing here? - - # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} - if( $self->opt_f or $self->opt_q ) { - $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q; - warn - "Perldoc is only really meant for reading one word at a time.\n", - "So these parameters are being ignored: ", - join(' ', @{$self->{'args'}}), - "\n" - if @{$self->{'args'}} + + # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} + if( $self->opt_f or $self->opt_q ) { + $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q; + $self->warn( + "Perldoc is only really meant for reading one word at a time.\n", + "So these parameters are being ignored: ", + join(' ', @{$self->{'args'}}), + "\n" ) + if @{$self->{'args'}} } return; } @@ -712,6 +813,24 @@ sub grand_search_init { my($self, $pages, @found) = @_; foreach (@$pages) { + if (/^http(s)?:\/\//) { + require HTTP::Tiny; + require File::Temp; + my $response = HTTP::Tiny->new->get($_); + if ($response->{success}) { + my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1); + $fh->print($response->{content}); + push @found, $filename; + ($self->{podnames}{$filename} = + m{.*/([^/#?]+)} ? uc $1 : "UNKNOWN") + =~ s/\.P(?:[ML]|OD)\z//; + } + else { + print STDERR "No " . + ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; + } + next; + } if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { my $searchfor = catfile split '::', $_; $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); @@ -720,7 +839,7 @@ sub grand_search_init { chomp; push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; } - close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; + close(PODIDX) or $self->die( "Can't close $$self{'podidx'}: $!" ); next; } @@ -728,7 +847,7 @@ sub grand_search_init { if ($self->opt_F) { next unless -r; - push @found, $_ if $self->opt_m or $self->containspod($_); + push @found, $_ if $self->opt_l or $self->opt_m or $self->containspod($_); next; } @@ -741,7 +860,7 @@ sub grand_search_init { # for executables, like h2xs or perldoc itself. push @searchdirs, ($self->{'bindir'}, @INC); unless ($self->opt_m) { - if (IS_VMS) { + if ($self->is_vms) { my($i,$trn); for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { push(@searchdirs,$trn); @@ -758,7 +877,7 @@ sub grand_search_init { $self->aside( "Found as @files\n" ); } # add "perl" prefix, so "perldoc foo" may find perlfoo.pod - elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) { + elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) { $self->aside( "Loosely found as @files\n" ); } else { @@ -773,14 +892,15 @@ sub grand_search_init { ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; if ( @{ $self->{'found'} } ) { print STDERR "However, try\n"; + my $me = $self->program_name; for my $dir (@{ $self->{'found'} }) { - opendir(DIR, $dir) or die "opendir $dir: $!"; + opendir(DIR, $dir) or $self->die( "opendir $dir: $!" ); while (my $file = readdir(DIR)) { next if ($file =~ /^\./s); $file =~ s/\.(pm|pod)\z//; # XXX: badfs - print STDERR "\tperldoc $_\::$file\n"; + print STDERR "\t$me $_\::$file\n"; } - closedir(DIR) or die "closedir $dir: $!"; + closedir(DIR) or $self->die( "closedir $dir: $!" ); } } } @@ -795,11 +915,11 @@ sub grand_search_init { sub maybe_generate_dynamic_pod { my($self, $found_things) = @_; my @dynamic_pod; - + $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v; - + $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) { @@ -807,22 +927,22 @@ sub maybe_generate_dynamic_pod { } elsif ( @dynamic_pod ) { $self->aside("Hm, I found some Pod from that search!\n"); my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); - + push @{ $self->{'temp_file_list'} }, $buffer; # I.e., it MIGHT be deleted at the end. - - my $in_list = $self->opt_f || $self->opt_v; + + my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v; print $buffd "=over 8\n\n" if $in_list; - print $buffd @dynamic_pod or die "Can't print $buffer: $!"; + print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" ); print $buffd "=back\n" if $in_list; - close $buffd or die "Can't close $buffer: $!"; - + close $buffd or $self->die( "Can't close $buffer: $!" ); + @$found_things = $buffer; # Yes, so found_things never has more than one thing in # it, by time we leave here - + $self->add_formatter_option('__filter_nroff' => 1); } else { @@ -835,13 +955,21 @@ sub maybe_generate_dynamic_pod { #.......................................................................... +sub not_dynamic { + my ($self,$value) = @_; + $self->{__not_dynamic} = $value if @_ == 2; + return $self->{__not_dynamic}; +} + +#.......................................................................... + sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); my $self = shift; push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; DEBUG > 3 and printf "Formatter switches now: [%s]\n", join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; - + return; } @@ -854,12 +982,12 @@ sub new_translator { # $tr = $self->new_translator($lang); my $pack = 'POD2::' . uc($lang); eval "require $pack"; if ( !$@ && $pack->can('new') ) { - return $pack->new(); + return $pack->new(); } eval { require POD2::Base }; return if $@; - + return POD2::Base->new({ lang => $lang }); } @@ -876,7 +1004,7 @@ sub add_translator { # $self->add_translator($lang); $self->aside( "translator for '$lang' loaded\n" ); } else { # non-installed or bad translator package - warn "Perldoc cannot load translator package for '$lang': ignored\n"; + $self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" ); } } @@ -891,23 +1019,23 @@ sub search_perlvar { my $opt = $self->opt_v; if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) { - die "'$opt' does not look like a Perl variable\n"; + CORE::die( "'$opt' does not look like a Perl variable\n" ); } DEBUG > 2 and print "Search: @$found_things\n"; - + my $perlvar = shift @$found_things; open(PVAR, "<", $perlvar) # "Funk is its own reward" - or die("Can't open $perlvar: $!"); + or $self->die("Can't open $perlvar: $!"); - if ( $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9 + if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ... $opt = '$<I<digits>>'; } my $search_re = quotemeta($opt); DEBUG > 2 and print "Going to perlvar-scan for $search_re in $perlvar\n"; - + # Skip introduction local $_; while (<PVAR>) { @@ -930,13 +1058,13 @@ sub search_perlvar { elsif (!/^\s+$/) { # not a blank line if ( $found ) { $inheader = 0; # don't accept more =item (unless inlist) - } + } else { @$pod = (); # reset $inheader = 1; # start over next; } - } + } if (/^=over/) { ++$inlist; @@ -950,15 +1078,68 @@ sub search_perlvar { } @$pod = () unless $found; if (!@$pod) { - die "No documentation for perl variable '$opt' found\n"; + CORE::die( "No documentation for perl variable '$opt' found\n" ); } - close PVAR or die "Can't open $perlvar: $!"; + close PVAR or $self->die( "Can't open $perlvar: $!" ); return; } #.......................................................................... +sub search_perlop { + my ($self,$found_things,$pod) = @_; + + $self->not_dynamic( 1 ); + + my $perlop = shift @$found_things; + open( PERLOP, '<', $perlop ) or $self->die( "Can't open $perlop: $!" ); + + my $paragraph = ""; + my $has_text_seen = 0; + my $thing = $self->opt_f; + my $list = 0; + + while( my $line = <PERLOP> ){ + if( $paragraph and $line =~ m!^=(?:head|item)! and $paragraph =~ m!X<+\s*\Q$thing\E\s*>+! ){ + if( $list ){ + $paragraph =~ s!=back.*?\z!!s; + } + + if( $paragraph =~ m!^=item! ){ + $paragraph = "=over 8\n\n" . $paragraph . "=back\n"; + } + + push @$pod, $paragraph; + $paragraph = ""; + $has_text_seen = 0; + $list = 0; + } + + if( $line =~ m!^=over! ){ + $list++; + } + elsif( $line =~ m!^=back! ){ + $list--; + } + + if( $line =~ m!^=(?:head|item)! and $has_text_seen ){ + $paragraph = ""; + } + elsif( $line !~ m!^=(?:head|item)! and $line !~ m!^\s*$! and $line !~ m!^\s*X<! ){ + $has_text_seen = 1; + } + + $paragraph .= $line; + } + + close PERLOP; + + return; +} + +#.......................................................................... + sub search_perlfunc { my($self, $found_things, $pod) = @_; @@ -966,7 +1147,7 @@ sub search_perlfunc { my $perlfunc = shift @$found_things; open(PFUNC, "<", $perlfunc) # "Funk is its own reward" - or die("Can't open $perlfunc: $!"); + or $self->die("Can't open $perlfunc: $!"); # Functions like -r, -e, etc. are listed under `-X'. my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) @@ -992,13 +1173,31 @@ sub search_perlfunc { # Look for our function my $found = 0; my $inlist = 0; + + my @perlops = qw(m q qq qr qx qw s tr y); + + my @related; + my $related_re; while (<PFUNC>) { # "The Mothership Connection is here!" + last if( grep{ $self->opt_f eq $_ }@perlops ); if ( m/^=item\s+$search_re\b/ ) { $found = 1; } + elsif (@related > 1 and /^=item/) { + $related_re ||= join "|", @related; + if (m/^=item\s+(?:$related_re)\b/) { + $found = 1; + } + else { + last; + } + } elsif (/^=item/) { last if $found > 1 and not $inlist; } + elsif ($found and /^X<[^>]+>/) { + push @related, m/X<([^>]+)>/g; + } next unless $found; if (/^=over/) { ++$inlist; @@ -1010,13 +1209,18 @@ sub search_perlfunc { push @$pod, $_; ++$found if /^\w/; # found descriptive text } + + if( !@$pod ){ + $self->search_perlop( $found_things, $pod ); + } + if (!@$pod) { - die sprintf - "No documentation for perl function `%s' found\n", - $self->opt_f + CORE::die( sprintf + "No documentation for perl function '%s' found\n", + $self->opt_f ) ; } - close PFUNC or die "Can't open $perlfunc: $!"; + close PFUNC or $self->die( "Can't open $perlfunc: $!" ); return; } @@ -1029,9 +1233,9 @@ sub search_perlfaqs { my $found = 0; my %found_in; my $search_key = $self->opt_q; - + my $rx = eval { qr/$search_key/ } - or die <<EOD; + or $self->die( <<EOD ); Invalid regular expression '$search_key' given as -q pattern: $@ Did you mean \\Q$search_key ? @@ -1040,9 +1244,9 @@ EOD local $_; foreach my $file (@$found_things) { - die "invalid file spec: $!" if $file =~ /[<>|]/; + $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/; open(INFAQ, "<", $file) # XXX 5.6ism - or die "Can't read-open $file: $!\nAborting"; + or $self->die( "Can't read-open $file: $!\nAborting" ); while (<INFAQ>) { if ( m/^=head2\s+.*(?:$search_key)/i ) { $found = 1; @@ -1056,9 +1260,12 @@ EOD } close(INFAQ); } - die("No documentation for perl FAQ keyword `$search_key' found\n") + CORE::die("No documentation for perl FAQ keyword '$search_key' found\n") unless @$pod; + if ( $self->opt_l ) { + CORE::die((join "\n", keys %found_in) . "\n"); + } return; } @@ -1071,25 +1278,25 @@ sub render_findings { my($self, $found_things) = @_; my $formatter_class = $self->{'formatter_class'} - || die "No formatter class set!?"; + || $self->die( "No formatter class set!?" ); my $formatter = $formatter_class->can('new') ? $formatter_class->new : $formatter_class ; if(! @$found_things) { - die "Nothing found?!"; + $self->die( "Nothing found?!" ); # should have been caught before here } elsif(@$found_things > 1) { - warn + $self->warn( "Perldoc is only really meant for reading one document at a time.\n", "So these parameters are being ignored: ", join(' ', @$found_things[1 .. $#$found_things] ), - "\n" + "\n" ); } my $file = $found_things->[0]; - + DEBUG > 3 and printf "Formatter switches now: [%s]\n", join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; @@ -1099,21 +1306,26 @@ sub render_findings { my($switch, $value, $silent_fail) = @$f; if( $formatter->can($switch) ) { eval { $formatter->$switch( defined($value) ? $value : () ) }; - warn "Got an error when setting $formatter_class\->$switch:\n$@\n" + $self->warn( "Got an error when setting $formatter_class\->$switch:\n$@\n" ) if $@; } else { if( $silent_fail or $switch =~ m/^__/s ) { DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; } else { - warn "$formatter_class doesn't recognize the $switch switch.\n"; + $self->warn( "$formatter_class doesn't recognize the $switch switch.\n" ); } } } } - + $self->{'output_is_binary'} = $formatter->can('write_with_binmode') && $formatter->write_with_binmode; + if( $self->{podnames} and exists $self->{podnames}{$file} and + $formatter->can('name') ) { + $formatter->name($self->{podnames}{$file}); + } + my ($out_fh, $out) = $self->new_output_file( ( $formatter->can('output_extension') && $formatter->output_extension ) || undef, @@ -1130,19 +1342,19 @@ sub render_findings { # The average user just has no reason to be seeing # $^W-suppressible warnings from the formatting! } - + eval { $formatter->parse_from_file( $file, $out_fh ) }; } - - warn "Error while formatting with $formatter_class:\n $@\n" if $@; + + $self->warn( "Error while formatting with $formatter_class:\n $@\n" ) if $@; DEBUG > 2 and print "Back from formatting with $formatter_class\n"; - close $out_fh - or warn "Can't close $out: $!\n(Did $formatter already close it?)"; + close $out_fh + or $self->warn( "Can't close $out: $!\n(Did $formatter already close it?)" ); sleep 0; sleep 0; sleep 0; # Give the system a few timeslices to meditate on the fact # that the output file does in fact exist and is closed. - + $self->unlink_if_temp_file($file); unless( -s $out ) { @@ -1152,7 +1364,7 @@ sub render_findings { # as a 0-length output file? $formatter->if_zero_length( $file, $out, $out_fh ); } else { - warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" + $self->warn( "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" ); } } @@ -1171,11 +1383,11 @@ sub unlink_if_temp_file { # my($self, $file) = @_; return unless defined $file and length $file; - + my $temp_file_list = $self->{'temp_file_list'} || return; if(grep $_ eq $file, @$temp_file_list) { $self->aside("Unlinking $file\n"); - unlink($file) or warn "Odd, couldn't unlink $file: $!"; + unlink($file) or $self->warn( "Odd, couldn't unlink $file: $!" ); } else { DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; } @@ -1184,129 +1396,25 @@ sub unlink_if_temp_file { #.......................................................................... -sub MSWin_temp_cleanup { - - # Nothing particularly MSWin-specific in here, but I don't know if any - # other OS needs its temp dir policed like MSWin does! - - my $self = shift; - - my $tempdir = $ENV{'TEMP'}; - return unless defined $tempdir and length $tempdir - and -e $tempdir and -d _ and -w _; - - $self->aside( - "Considering whether any old files of mine in $tempdir need unlinking.\n" - ); - - opendir(TMPDIR, $tempdir) || return; - my @to_unlink; - - my $limit = time() - $Temp_File_Lifetime; - - DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", - ($limit) x 2; - - my $filespec; - - while(defined($filespec = readdir(TMPDIR))) { - if( - $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s - ) { - if( hex($1) < $limit ) { - push @to_unlink, "$tempdir/$filespec"; - $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); - } else { - DEBUG > 5 and - printf " $tempdir/$filespec is too recent (after %x)\n", $limit; - } - } else { - DEBUG > 5 and - print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; - } - } - closedir(TMPDIR); - $self->aside(sprintf "Unlinked %s items of mine in %s\n", - scalar(unlink(@to_unlink)), - $tempdir - ); - return; -} - -# . . . . . . . . . . . . . . . . . . . . . . . . . - -sub MSWin_perldoc_tempfile { - my($self, $suffix, $infix) = @_; - - my $tempdir = $ENV{'TEMP'}; - return unless defined $tempdir and length $tempdir - and -e $tempdir and -d _ and -w _; - - my $spec; - - do { - $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup - # Yes, we embed the create-time in the filename! - $tempdir, - $infix || 'x', - time(), - $$, - defined( &Win32::GetTickCount ) - ? (Win32::GetTickCount() & 0xff) - : int(rand 256) - # Under MSWin, $$ values get reused quickly! So if we ran - # perldoc foo and then perldoc bar before there was time for - # time() to increment time."_$$" would likely be the same - # for each process! So we tack on the tick count's lower - # bits (or, in a pinch, rand) - , - $suffix || 'txt'; - ; - } while( -e $spec ); - - my $counter = 0; - - while($counter < 50) { - my $fh; - # If we are running before perl5.6.0, we can't autovivify - if ($] < 5.006) { - require Symbol; - $fh = Symbol::gensym(); - } - DEBUG > 3 and print "About to try making temp file $spec\n"; - return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism - $self->aside("Can't create temp file $spec: $!\n"); - } - - $self->aside("Giving up on making a temp file!\n"); - die "Can't make a tempfile!?"; -} - -#.......................................................................... - sub after_rendering { my $self = $_[0]; - $self->after_rendering_VMS if IS_VMS; - $self->after_rendering_MSWin32 if IS_MSWin32; - $self->after_rendering_Dos if IS_Dos; - $self->after_rendering_OS2 if IS_OS2; + $self->after_rendering_VMS if $self->is_vms; + $self->after_rendering_MSWin32 if $self->is_mswin32; + $self->after_rendering_Dos if $self->is_dos; + $self->after_rendering_OS2 if $self->is_os2; return; } sub after_rendering_VMS { return } sub after_rendering_Dos { return } sub after_rendering_OS2 { return } - -sub after_rendering_MSWin32 { - shift->MSWin_temp_cleanup() if $Temp_Files_Created; -} +sub after_rendering_MSWin32 { return } #.......................................................................... -# : : : : : : : : : +# : : : : : : : : : #.......................................................................... - sub minus_f_nocase { # i.e., do like -f, but without regard to case my($self, $dir, $file) = @_; @@ -1314,59 +1422,59 @@ sub minus_f_nocase { # i.e., do like -f, but without regard to case return $path if -f $path and -r _; if(!$self->opt_i - or IS_VMS or IS_MSWin32 - or IS_Dos or IS_OS2 + or $self->is_vms or $self->is_mswin32 + or $self->Is_dos or $self->is_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 ''; + # that is it, all we can do. + $self->warn( "Ignored $path: unreadable\n" ) if -f _; + return ''; } - + local *DIR; my @p = ($dir); my($p,$cip); foreach $p (splitdir $file){ - my $try = catfile @p, $p; + my $try = catfile @p, $p; $self->aside("Scrutinizing $try...\n"); - stat $try; - if (-d _) { - push @p, $p; - if ( $p eq $self->{'target'} ) { - my $tmp_path = catfile @p; - my $path_f = 0; - for (@{ $self->{'found'} }) { - $path_f = 1 if $_ eq $tmp_path; - } - push (@{ $self->{'found'} }, $tmp_path) unless $path_f; - $self->aside( "Found as $tmp_path but directory\n" ); - } - } - elsif (-f _ && -r _) { - return $try; - } - elsif (-f _) { - warn "Ignored $try: unreadable\n"; - } - elsif (-d catdir(@p)) { # at least we see the containing directory! - my $found = 0; - my $lcp = lc $p; - my $p_dirspec = catdir(@p); - opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; - while(defined( $cip = readdir(DIR) )) { - if (lc $cip eq $lcp){ - $found++; - last; # XXX stop at the first? what if there's others? - } - } - closedir DIR or die "closedir $p_dirspec: $!"; - return "" unless $found; - - push @p, $cip; - my $p_filespec = catfile(@p); - return $p_filespec if -f $p_filespec and -r _; - warn "Ignored $p_filespec: unreadable\n" if -f _; - } + stat $try; + if (-d _) { + push @p, $p; + if ( $p eq $self->{'target'} ) { + my $tmp_path = catfile @p; + my $path_f = 0; + for (@{ $self->{'found'} }) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@{ $self->{'found'} }, $tmp_path) unless $path_f; + $self->aside( "Found as $tmp_path but directory\n" ); + } + } + elsif (-f _ && -r _ && lc($try) eq lc($path)) { + return $try; + } + elsif (-f _) { + $self->warn( "Ignored $try: unreadable or file/dir mismatch\n" ); + } + elsif (-d catdir(@p)) { # at least we see the containing directory! + my $found = 0; + my $lcp = lc $p; + my $p_dirspec = catdir(@p); + opendir DIR, $p_dirspec or $self->die( "opendir $p_dirspec: $!" ); + while(defined( $cip = readdir(DIR) )) { + if (lc $cip eq $lcp){ + $found++; + last; # XXX stop at the first? what if there's others? + } + } + closedir DIR or $self->die( "closedir $p_dirspec: $!" ); + return "" unless $found; + + push @p, $cip; + my $p_filespec = catfile(@p); + return $p_filespec if -f $p_filespec and -r _; + $self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _; + } } return ""; } @@ -1380,34 +1488,35 @@ sub pagers_guessing { push @pagers, $self->pagers; $self->{'pagers'} = \@pagers; - if (IS_MSWin32) { + if ($self->is_mswin32) { push @pagers, qw( more< less notepad ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } - elsif (IS_VMS) { + elsif ($self->is_vms) { push @pagers, qw( most more less type/page ); } - elsif (IS_Dos) { + elsif ($self->is_dos) { push @pagers, qw( less.exe more.com< ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } else { - if (IS_OS2) { + if ($self->is_os2) { unshift @pagers, 'less', 'cmd /c more <'; } push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER}; } - if (IS_Cygwin) { + if ($self->is_cygwin) { if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { unshift @pagers, '/usr/bin/less -isrR'; - } + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } } unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; - - return; + + return; } #.......................................................................... @@ -1427,62 +1536,23 @@ sub page_module_file { # occasionally hazy distinction between OS-local extension # associations, and browser-specific MIME mappings. - if ($self->{'output_to_stdout'}) { - $self->aside("Sending unpaged output to STDOUT.\n"); - local $_; - my $any_error = 0; - foreach my $output (@found) { - unless( open(TMP, "<", $output) ) { # XXX 5.6ism - warn("Can't open $output: $!"); - $any_error = 1; - next; - } - while (<TMP>) { - print or die "Can't print to stdout: $!"; - } - close TMP or die "Can't close while $output: $!"; - $self->unlink_if_temp_file($output); - } - return $any_error; # successful + if(@found > 1) { + $self->warn( + "Perldoc is only really meant for reading one document at a time.\n" . + "So these files are being ignored: " . + join(' ', @found[1 .. $#found] ) . + "\n" ) } - foreach my $pager ( $self->pagers ) { - $self->aside("About to try calling $pager @found\n"); - if (system($pager, @found) == 0) { - $self->aside("Yay, it worked.\n"); - return 0; - } - $self->aside("That didn't work.\n"); - - # Odd -- when it fails, under Win32, this seems to neither - # return with a fail nor return with a success!! - # That's discouraging! - } + return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers); - $self->aside( - sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", - join(' ', @found), - join(' ', $self->pagers), - ); - - if (IS_VMS) { - DEBUG > 1 and print "Bailing out in a VMSish way.\n"; - eval q{ - use vmsish qw(status exit); - exit $?; - 1; - } or die; - } - - return 1; - # i.e., an UNSUCCESSFUL return value! } #.......................................................................... sub check_file { my($self, $dir, $file) = @_; - + unless( ref $self ) { # Should never get called: $Carp::Verbose = 1; @@ -1493,29 +1563,41 @@ sub check_file { "Aborting" ); } - + if(length $dir and not -d $dir) { DEBUG > 3 and print " No dir $dir -- skipping.\n"; return ""; } - - if ($self->opt_m) { - return $self->minus_f_nocase($dir,$file); - } - - else { - my $path = $self->minus_f_nocase($dir,$file); - if( length $path and $self->containspod($path) ) { - DEBUG > 3 and print - " The file $path indeed looks promising!\n"; - return $path; - } + + my $path = $self->minus_f_nocase($dir,$file); + if( length $path and ($self->opt_m ? $self->isprintable($path) + : $self->containspod($path)) ) { + DEBUG > 3 and print + " The file $path indeed looks promising!\n"; + return $path; } DEBUG > 3 and print " No good: $file in $dir\n"; - + return ""; } +sub isprintable { + my($self, $file, $readit) = @_; + my $size= 1024; + my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc. + + return 1 if !$readit && $file =~ /\.(?:pl|pm|pod|cmd|com|bat)\z/i; + + my $data; + local($_); + open(TEST,"<", $file) or $self->die( "Can't open $file: $!" ); + read TEST, $data, $size; + close TEST; + $size= length($data); + $data =~ tr/\x09-\x0D\x20-\x7E//d; + return length($data) <= $size*$maxunprintfrac; +} + #.......................................................................... sub containspod { @@ -1536,21 +1618,21 @@ sub containspod { # # $ perldoc perl.pod - if ( IS_Cygwin and -x $file and -f "$file.exe" ) + if ( $self->is_cygwin and -x $file and -f "$file.exe" ) { - warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_D; + $self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D; return 0; } local($_); - open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism + open(TEST,"<", $file) or $self->die( "Can't open $file: $!" ); # XXX 5.6ism while (<TEST>) { - if (/^=head/) { - close(TEST) or die "Can't close $file: $!"; - return 1; - } + if (/^=head/) { + close(TEST) or $self->die( "Can't close $file: $!" ); + return 1; + } } - close(TEST) or die "Can't close $file: $!"; + close(TEST) or $self->die( "Can't close $file: $!" ); return 0; } @@ -1558,21 +1640,21 @@ sub containspod { sub maybe_diddle_INC { my $self = shift; - + # Does this look like a module or extension directory? - + if (-f "Makefile.PL" || -f "Build.PL") { # Add "." and "lib" to @INC (if they exist) - eval q{ use lib qw(. lib); 1; } or die; + eval q{ use lib qw(. lib); 1; } or $self->die; # don't add if superuser if ($< && $> && -d "blib") { # don't be looking too hard now! eval q{ use blib; 1 }; - warn $@ if $@ && $self->opt_D; + $self->warn( $@ ) if $@ && $self->opt_D; } } - + return; } @@ -1582,21 +1664,21 @@ sub new_output_file { my $self = shift; my $outspec = $self->opt_d; # Yes, -d overrides all else! # So don't call this twice per format-job! - + return $self->new_tempfile(@_) unless defined $outspec and length $outspec; # Otherwise open a write-handle on opt_d!f my $fh; # If we are running before perl5.6.0, we can't autovivify - if ($] < 5.006) { + if ($^V < 5.006) { require Symbol; $fh = Symbol::gensym(); } DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; - die "Can't write-open $outspec: $!" + $self->die( "Can't write-open $outspec: $!" ) unless open($fh, ">", $outspec); # XXX 5.6ism - + DEBUG > 3 and print "Successfully opened $outspec\n"; binmode($fh) if $self->{'output_is_binary'}; return($fh, $outspec); @@ -1617,7 +1699,7 @@ sub useful_filename_bit { my $self = shift; my $pages = $self->{'pages'} || return undef; return undef unless @$pages; - + my $chunk = $pages->[0]; return undef unless defined $chunk; $chunk =~ s/:://g; @@ -1639,12 +1721,6 @@ sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) ++$Temp_Files_Created; - if( IS_MSWin32 ) { - my @out = $self->MSWin_perldoc_tempfile(@_); - return @out if @out; - # otherwise fall thru to the normal stuff below... - } - require File::Temp; return File::Temp::tempfile(UNLINK => 1); } @@ -1655,32 +1731,32 @@ sub page { # apply a pager to the output file my ($self, $output, $output_to_stdout, @pagers) = @_; if ($output_to_stdout) { $self->aside("Sending unpaged output to STDOUT.\n"); - open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism - local $_; - while (<TMP>) { - print or die "Can't print to stdout: $!"; - } - close TMP or die "Can't close while $output: $!"; - $self->unlink_if_temp_file($output); + open(TMP, "<", $output) or $self->die( "Can't open $output: $!" ); # XXX 5.6ism + local $_; + while (<TMP>) { + print or $self->die( "Can't print to stdout: $!" ); + } + close TMP or $self->die( "Can't close while $output: $!" ); + $self->unlink_if_temp_file($output); } else { # On VMS, quoting prevents logical expansion, and temp files with no # extension get the wrong default extension (such as .LIS for TYPE) - $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; + $output = VMS::Filespec::rmsexpand($output, '.') if $self->is_vms; - $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos; - # Altho "/" under MSWin is in theory good as a pathsep, - # many many corners of the OS don't like it. So we - # have to force it to be "\" to make everyone happy. + $output =~ s{/}{\\}g if $self->is_mswin32 || $self->is_dos; + # Altho "/" under MSWin is in theory good as a pathsep, + # many many corners of the OS don't like it. So we + # have to force it to be "\" to make everyone happy. foreach my $pager (@pagers) { $self->aside("About to try calling $pager $output\n"); - if (IS_VMS) { + if ($self->is_vms) { last if system("$pager $output") == 0; } else { - last if system("$pager \"$output\"") == 0; + last if system("$pager \"$output\"") == 0; } - } + } } return; } @@ -1690,7 +1766,7 @@ sub page { # apply a pager to the output file sub searchfor { my($self, $recurse,$s,@dirs) = @_; $s =~ s!::!/!g; - $s = VMS::Filespec::unixify($s) if IS_VMS; + $s = VMS::Filespec::unixify($s) if $self->is_vms; return $s if -f $s && $self->containspod($s); $self->aside( "Looking for $s in @dirs\n" ); my $ret; @@ -1698,41 +1774,41 @@ sub searchfor { my $dir; $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? for ($i=0; $i<@dirs; $i++) { - $dir = $dirs[$i]; - next unless -d $dir; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS; - if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) - or ( $ret = $self->check_file($dir,"$s.pm")) - or ( $ret = $self->check_file($dir,$s)) - or ( IS_VMS and - $ret = $self->check_file($dir,"$s.com")) - or ( IS_OS2 and - $ret = $self->check_file($dir,"$s.cmd")) - or ( (IS_MSWin32 or IS_Dos or IS_OS2) and - $ret = $self->check_file($dir,"$s.bat")) - or ( $ret = $self->check_file("$dir/pod","$s.pod")) - or ( $ret = $self->check_file("$dir/pod",$s)) - or ( $ret = $self->check_file("$dir/pods","$s.pod")) - or ( $ret = $self->check_file("$dir/pods",$s)) - ) { - DEBUG > 1 and print " Found $ret\n"; - return $ret; - } + $dir = $dirs[$i]; + next unless -d $dir; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $self->is_vms; + if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) + or ( $ret = $self->check_file($dir,"$s.pm")) + or ( $ret = $self->check_file($dir,$s)) + or ( $self->is_vms and + $ret = $self->check_file($dir,"$s.com")) + or ( $self->is_os2 and + $ret = $self->check_file($dir,"$s.cmd")) + or ( ($self->is_mswin32 or $self->is_dos or $self->is_os2) and + $ret = $self->check_file($dir,"$s.bat")) + or ( $ret = $self->check_file("$dir/pod","$s.pod")) + or ( $ret = $self->check_file("$dir/pod",$s)) + or ( $ret = $self->check_file("$dir/pods","$s.pod")) + or ( $ret = $self->check_file("$dir/pods",$s)) + ) { + DEBUG > 1 and print " Found $ret\n"; + return $ret; + } - if ($recurse) { - opendir(D,$dir) or die "Can't opendir $dir: $!"; - my @newdirs = map catfile($dir, $_), grep { - not /^\.\.?\z/s and - not /^auto\z/s and # save time! don't search auto dirs - -d catfile($dir, $_) - } readdir D; - closedir(D) or die "Can't closedir $dir: $!"; - next unless @newdirs; - # what a wicked map! - @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; - $self->aside( "Also looking in @newdirs\n" ); - push(@dirs,@newdirs); - } + if ($recurse) { + opendir(D,$dir) or $self->die( "Can't opendir $dir: $!" ); + my @newdirs = map catfile($dir, $_), grep { + not /^\.\.?\z/s and + not /^auto\z/s and # save time! don't search auto dirs + -d catfile($dir, $_) + } readdir D; + closedir(D) or $self->die( "Can't closedir $dir: $!" ); + next unless @newdirs; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->is_vms; + $self->aside( "Also looking in @newdirs\n" ); + push(@dirs,@newdirs); + } } return (); } @@ -1745,10 +1821,10 @@ sub searchfor { return if $already_asserted; - eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; + eval q~ END { close(STDOUT) || CORE::die "Can't close STDOUT: $!" } ~; # What for? to let the pager know that nothing more will come? - - die $@ if $@; + + $self->die( $@ ) if $@; $already_asserted = 1; return; } @@ -1758,21 +1834,22 @@ sub searchfor { sub tweak_found_pathnames { my($self, $found) = @_; - if (IS_MSWin32) { + if ($self->is_mswin32) { foreach (@$found) { s,/,\\,g } } + foreach (@$found) { s,',\\',g } # RT 37347 return; } #.......................................................................... -# : : : : : : : : : +# : : : : : : : : : #.......................................................................... sub am_taint_checking { my $self = shift; - die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way + $self->die( "NO ENVIRONMENT?!?!" ) unless keys %ENV; # reset iterator along the way my($k,$v) = each %ENV; - return is_tainted($v); + return is_tainted($v); } #.......................................................................... @@ -1789,10 +1866,10 @@ sub is_tainted { # just a function sub drop_privs_maybe { my $self = shift; - + # Attempt to drop privs if we should be tainting and aren't - if (!(IS_VMS || IS_MSWin32 || IS_Dos - || IS_OS2 + if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos + || $self->is_os2 ) && ($> == 0 || $< == 0) && !$self->am_taint_checking() @@ -1873,94 +1950,11 @@ merchantability or fitness for a particular purpose. =head1 AUTHOR -Current maintainer: Adriano R. Ferreira <ferreira@cpan.org> +Current maintainer: Mark Allen C<< <mallen@cpan.org> >> Past contributions from: -Sean M. Burke <sburke@cpan.org> +brian d foy C<< <bdfoy@cpan.org> >> +Adriano R. Ferreira C<< <ferreira@cpan.org> >>, +Sean M. Burke C<< <sburke@cpan.org> >> =cut - -# -# -# Perldoc -- look up a piece of documentation in .pod format that -# is embedded in the perl installation tree. -# -#~~~~~~ -# -# See ChangeLog in CPAN dist for Pod::Perldoc for later notes. -# -# Version 3.01: Sun Nov 10 21:38:09 MST 2002 -# Sean M. Burke <sburke@cpan.org> -# Massive refactoring and code-tidying. -# Now it's a module(-family)! -# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm -# Added -T, -d, -o, -M, -w. -# Added some improved MSWin funk. -# -#~~~~~~ -# -# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 -# Hugo van der Sanden <hv@crypt.org> -# Made -U the default, based on patch from Simon Cozens -# Version 2.04: Sun Aug 18 13:27:12 BST 2002 -# Randy W. Sims <RandyS@ThePierianSpring.org> -# allow -n to enable nroff under Win32 -# Version 2.03: Sun Apr 23 16:56:34 BST 2000 -# Hugo van der Sanden <hv@crypt.org> -# don't die when 'use blib' fails -# Version 2.02: Mon Mar 13 18:03:04 MST 2000 -# Tom Christiansen <tchrist@perl.com> -# Added -U insecurity option -# Version 2.01: Sat Mar 11 15:22:33 MST 2000 -# Tom Christiansen <tchrist@perl.com>, querulously. -# Security and correctness patches. -# What a twisted bit of distasteful spaghetti code. -# Version 2.0: ???? -# -#~~~~~~ -# -# Version 1.15: Tue Aug 24 01:50:20 EST 1999 -# Charles Wilson <cwilson@ece.gatech.edu> -# changed /pod/ directory to /pods/ for cygwin -# to support cygwin/win32 -# 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@activestate.com> -# -doc tweaks for -F and -X options -# Version 1.12: Sat Apr 12 22:41:09 EST 1997 -# Gurusamy Sarathy <gsar@activestate.com> -# -various fixes for win32 -# Version 1.11: Tue Dec 26 09:54:33 EST 1995 -# Kenneth Albanowski <kjahds@kjahds.com> -# -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 <kjahds@kjahds.com> -# -added VMS support -# -added better error recognition (on no found pages, just exit. On -# missing nroff/pod2man, just display raw pod.) -# -added recursive/case-insensitive matching (thanks, Andreas). This -# slows things down a bit, unfortunately. Give a precise name, and -# it'll run faster. -# -# Version 1.01: Tue May 30 14:47:34 EDT 1995 -# Andy Dougherty <doughera@lafcol.lafayette.edu> -# -added pod documentation. -# -added PATH searching. -# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod -# and friends. -# -#~~~~~~~ -# -# TODO: -# -# Cache the directories read during sloppy match -# (To disk, or just in-memory?) -# -# Backport this to perl 5.005? -# -# Implement at least part of the "perlman" interface described -# in Programming Perl 3e? |