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.pm236
1 files changed, 188 insertions, 48 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
index 8c841e833e8..6ddd21d95d4 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
@@ -12,7 +12,7 @@ use File::Spec::Functions qw(catfile catdir splitdir);
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.19';
+$VERSION = '3.23';
#..........................................................................
@@ -90,12 +90,13 @@ $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
#
# Option accessors...
-foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) {
+foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULva}) {
no strict 'refs';
*$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
}
# And these are so that GetOptsOO knows they take options:
+sub opt_a_with { shift->_elem('opt_a', @_) }
sub opt_f_with { shift->_elem('opt_f', @_) }
sub opt_q_with { shift->_elem('opt_q', @_) }
sub opt_d_with { shift->_elem('opt_d', @_) }
@@ -293,6 +294,7 @@ Options:
-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
+ -a Search Perl API
-v Search predefined Perl variables
PageName|ModuleName|ProgramName|URL...
@@ -399,6 +401,7 @@ Examples:
$program_name -f PerlFunc
$program_name -q FAQKeywords
$program_name -v PerlVar
+ $program_name -a PerlAPI
The -h option prints more help. Also try "$program_name perldoc" to get
acquainted with the system. [Perldoc v$VERSION]
@@ -441,6 +444,7 @@ sub init {
$self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
$self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
$self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
+ $self->{'search_path'} = [ ] unless exists $self->{'search_path'};
push @{ $self->{'formatter_switches'} = [] }, (
# Yeah, we could use a hashref, but maybe there's some class where options
@@ -470,7 +474,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 $self->is_mswin32 || $self->is_dos
+ $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos
|| !($ENV{TERM} && (
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
));
@@ -502,10 +506,10 @@ sub process {
# such as perlfaq".
return $self->usage_brief unless @{ $self->{'args'} };
- $self->pagers_guessing;
$self->options_reading;
+ $self->pagers_guessing;
$self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
- $self->drop_privs_maybe;
+ $self->drop_privs_maybe unless $self->opt_U;
$self->options_processing;
# Hm, we have @pages and @found, but we only really act on one
@@ -519,6 +523,7 @@ sub process {
if( $self->opt_f) { @pages = qw(perlfunc perlop) }
elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
elsif( $self->opt_v) { @pages = ("perlvar") }
+ elsif( $self->opt_a) { @pages = ("perlapi") }
else { @pages = @{$self->{'args'}};
# @pages = __FILE__
# if @pages == 1 and $pages[0] eq 'perldoc';
@@ -529,7 +534,7 @@ sub process {
$self->find_good_formatter_class();
$self->formatter_sanity_check();
- $self->maybe_diddle_INC();
+ $self->maybe_extend_searchpath();
# for when we're apparently in a module or extension directory
my @found = $self->grand_search_init(\@pages);
@@ -596,7 +601,7 @@ sub find_good_formatter_class {
} else {
$^W = 0;
# The average user just has no reason to be seeing
- # $^W-suppressible warnings from the the require!
+ # $^W-suppressible warnings from the require!
}
eval "require $c";
@@ -795,8 +800,12 @@ sub options_sanity {
# 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;
+ if( $self->opt_f or $self->opt_q or $self->opt_a) {
+ my $count;
+ $count++ if $self->opt_f;
+ $count++ if $self->opt_q;
+ $count++ if $self->opt_a;
+ $self->usage("Only one of -f or -q or -a") if $count > 1;
$self->warn(
"Perldoc is meant for reading one file at a time.\n",
"So these parameters are being ignored: ",
@@ -858,7 +867,7 @@ sub grand_search_init {
# We must look both in @INC for library modules and in $bindir
# for executables, like h2xs or perldoc itself.
- push @searchdirs, ($self->{'bindir'}, @INC);
+ push @searchdirs, ($self->{'bindir'}, @{$self->{search_path}}, @INC);
unless ($self->opt_m) {
if ($self->is_vms) {
my($i,$trn);
@@ -916,22 +925,28 @@ sub maybe_generate_dynamic_pod {
my($self, $found_things) = @_;
my @dynamic_pod;
+ $self->search_perlapi($found_things, \@dynamic_pod) if $self->opt_a;
+
$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 ) {
+ if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v and ! $self->opt_a) {
DEBUG > 4 and print "That's a non-dynamic pod search.\n";
} elsif ( @dynamic_pod ) {
$self->aside("Hm, I found some Pod from that search!\n");
my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
+ if ( $] >= 5.008 && $self->opt_L ) {
+ binmode($buffd, ":utf8");
+ print $buffd "=encoding utf8\n\n";
+ }
push @{ $self->{'temp_file_list'} }, $buffer;
# I.e., it MIGHT be deleted at the end.
- my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v;
+ my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v || $self->opt_a;
print $buffd "=over 8\n\n" if $in_list;
print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" );
@@ -1093,46 +1108,72 @@ sub search_perlop {
$self->not_dynamic( 1 );
my $perlop = shift @$found_things;
+ # XXX FIXME: getting filehandles should probably be done in a single place
+ # especially since we need to support UTF8 or other encoding when dealing
+ # with perlop, perlfunc, perlapi, perlfaq[1-9]
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";
- }
+ my $previous_line;
+ my $push = 0;
+ my $seen_item = 0;
+ my $skip = 1;
- push @$pod, $paragraph;
- $paragraph = "";
- $has_text_seen = 0;
- $list = 0;
+ while( my $line = <PERLOP> ) {
+ # only start search after we hit the operator section
+ if ($line =~ m!^X<operator, regexp>!) {
+ $skip = 0;
}
- if( $line =~ m!^=over! ){
- $list++;
+ next if $skip;
+
+ # strategy is to capture the previous line until we get a match on X<$thingy>
+ # if the current line contains X<$thingy>, then we push "=over", the previous line,
+ # the current line and keep pushing current line until we see a ^X<some-other-thing>,
+ # then we chop off final line from @$pod and add =back
+ #
+ # At that point, Bob's your uncle.
+
+ if ( $line =~ m!X<+\s*\Q$thing\E\s*>+!) {
+ if ( $previous_line ) {
+ push @$pod, "=over 8\n\n", $previous_line;
+ $previous_line = "";
+ }
+ push @$pod, $line;
+ $push = 1;
+
}
- elsif( $line =~ m!^=back! ){
- $list--;
+ elsif ( $push and $line =~ m!^=item\s*.*$! ) {
+ $seen_item = 1;
}
-
- if( $line =~ m!^=(?:head|item)! and $has_text_seen ){
- $paragraph = "";
+ elsif ( $push and $seen_item and $line =~ m!^X<+\s*[ a-z,?-]+\s*>+!) {
+ $push = 0;
+ $seen_item = 0;
+ last;
}
- elsif( $line !~ m!^=(?:head|item)! and $line !~ m!^\s*$! and $line !~ m!^\s*X<! ){
- $has_text_seen = 1;
+ elsif ( $push ) {
+ push @$pod, $line;
}
- $paragraph .= $line;
+ else {
+ $previous_line = $line;
}
+ } #end while
+
+ # we overfilled by 1 line, so pop off final array element if we have any
+ if ( scalar @$pod ) {
+ pop @$pod;
+
+ # and add the =back
+ push @$pod, "\n\n=back\n";
+ DEBUG > 8 and print "PERLOP POD --->" . (join "", @$pod) . "<---\n";
+ }
+ else {
+ DEBUG > 4 and print "No pod from perlop\n";
+ }
+
close PERLOP;
return;
@@ -1140,6 +1181,83 @@ sub search_perlop {
#..........................................................................
+sub search_perlapi {
+ my($self, $found_things, $pod) = @_;
+
+ DEBUG > 2 and print "Search: @$found_things\n";
+
+ my $perlapi = shift @$found_things;
+ open(PAPI, "<", $perlapi) # "Funk is its own reward"
+ or $self->die("Can't open $perlapi: $!");
+
+ my $search_re = quotemeta($self->opt_a);
+
+ DEBUG > 2 and
+ print "Going to perlapi-scan for $search_re in $perlapi\n";
+
+ # Check available translator or backup to default (english)
+ if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
+ my $tr = $self->{'translators'}->[0];
+ if ( $] < 5.008 ) {
+ $self->aside("Your old perl doesn't really have proper unicode support.");
+ }
+ else {
+ binmode(PAPI, ":utf8");
+ }
+ }
+
+ local $_;
+
+ # Look for our function
+ my $found = 0;
+ my $inlist = 0;
+
+ my @related;
+ my $related_re;
+ while (<PAPI>) { # "The Mothership Connection is here!"
+ 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;
+ }
+ elsif (/^=back/) {
+ last if $found > 1 and not $inlist;
+ --$inlist;
+ }
+ push @$pod, $_;
+ ++$found if /^\w/; # found descriptive text
+ }
+
+ if (!@$pod) {
+ CORE::die( sprintf
+ "No documentation for perl api function '%s' found\n",
+ $self->opt_a )
+ ;
+ }
+ close PAPI or $self->die( "Can't open $perlapi: $!" );
+
+ return;
+}
+
+#..........................................................................
+
sub search_perlfunc {
my($self, $found_things, $pod) = @_;
@@ -1162,6 +1280,12 @@ sub search_perlfunc {
if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
my $tr = $self->{'translators'}->[0];
$re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
+ if ( $] < 5.008 ) {
+ $self->aside("Your old perl doesn't really have proper unicode support.");
+ }
+ else {
+ binmode(PFUNC, ":utf8");
+ }
}
# Skip introduction
@@ -1180,7 +1304,16 @@ sub search_perlfunc {
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/ ) {
+
+ if ( /^=over/ and not $found ) {
+ ++$inlist;
+ }
+ elsif ( /^=back/ and not $found and $inlist ) {
+ --$inlist;
+ }
+
+
+ if ( m/^=item\s+$search_re\b/ and $inlist < 2 ) {
$found = 1;
}
elsif (@related > 1 and /^=item/) {
@@ -1189,11 +1322,11 @@ sub search_perlfunc {
$found = 1;
}
else {
- last;
+ last if $found > 1 and $inlist < 2;
}
}
elsif (/^=item/) {
- last if $found > 1 and not $inlist;
+ last if $found > 1 and $inlist < 2;
}
elsif ($found and /^X<[^>]+>/) {
push @related, m/X<([^>]+)>/g;
@@ -1203,7 +1336,6 @@ sub search_perlfunc {
++$inlist;
}
elsif (/^=back/) {
- last if $found > 1 and not $inlist;
--$inlist;
}
push @$pod, $_;
@@ -1220,7 +1352,7 @@ sub search_perlfunc {
$self->opt_f )
;
}
- close PFUNC or $self->die( "Can't open $perlfunc: $!" );
+ close PFUNC or $self->die( "Can't close $perlfunc: $!" );
return;
}
@@ -1514,7 +1646,14 @@ sub pagers_guessing {
}
}
- unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER};
+ if ( $self->opt_m ) {
+ unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER}
+ }
+ else {
+ unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER};
+ }
+
+ $self->aside("Pagers: ", @pagers);
return;
}
@@ -1638,19 +1777,18 @@ sub containspod {
#..........................................................................
-sub maybe_diddle_INC {
+sub maybe_extend_searchpath {
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 $self->die;
+ push @{$self->{search_path} }, '.','lib';
# don't add if superuser
if ($< && $> && -d "blib") { # don't be looking too hard now!
- eval q{ use blib; 1 };
+ push @{ $self->{search_path} }, 'blib';
$self->warn( $@ ) if $@ && $self->opt_D;
}
}
@@ -1867,6 +2005,8 @@ sub is_tainted { # just a function
sub drop_privs_maybe {
my $self = shift;
+ DEBUG and print "Attempting to drop privs...\n";
+
# Attempt to drop privs if we should be tainting and aren't
if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos
|| $self->is_os2