use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.20';
+$VERSION = '3.21';
#..........................................................................
#
# 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', @_) }
-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...
$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]
$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
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';
$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);
} 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";
# 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: ",
# 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);
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");
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: $!" );
#..........................................................................
+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) = @_;
#..........................................................................
-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;
}
}
projects / platform / upstream / perl.git / commitdiff