summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Perldoc.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc.pm1100
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?