1093 lines
35 KiB
Perl
1093 lines
35 KiB
Perl
require 5.005;
|
|
package Pod::Simple::Search;
|
|
use strict;
|
|
|
|
use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
|
|
$VERSION = '3.43'; ## Current version of this package
|
|
|
|
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
|
|
use Carp ();
|
|
|
|
$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
|
|
# flag to occasionally sleep for $SLEEPY - 1 seconds.
|
|
|
|
$MAX_VERSION_WITHIN ||= 60;
|
|
|
|
#############################################################################
|
|
|
|
#use diagnostics;
|
|
use File::Spec ();
|
|
use File::Basename qw( basename dirname );
|
|
use Config ();
|
|
use Cwd qw( cwd );
|
|
|
|
#==========================================================================
|
|
__PACKAGE__->_accessorize( # Make my dumb accessor methods
|
|
'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob',
|
|
'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse',
|
|
'ciseen', 'is_case_insensitive'
|
|
);
|
|
#==========================================================================
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $self = bless {}, ref($class) || $class;
|
|
$self->init;
|
|
return $self;
|
|
}
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
$self->inc(1);
|
|
$self->recurse(1);
|
|
$self->verbose(DEBUG);
|
|
$self->is_case_insensitive(-e uc __FILE__ && -e lc __FILE__);
|
|
return $self;
|
|
}
|
|
|
|
#--------------------------------------------------------------------------
|
|
|
|
sub survey {
|
|
my($self, @search_dirs) = @_;
|
|
$self = $self->new unless ref $self; # tolerate being a class method
|
|
|
|
$self->_expand_inc( \@search_dirs );
|
|
|
|
$self->{'_scan_count'} = 0;
|
|
$self->{'_dirs_visited'} = {};
|
|
$self->path2name( {} );
|
|
$self->name2path( {} );
|
|
$self->ciseen( {} );
|
|
$self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
|
|
my $cwd = cwd();
|
|
my $verbose = $self->verbose;
|
|
local $_; # don't clobber the caller's $_ !
|
|
|
|
foreach my $try (@search_dirs) {
|
|
unless( File::Spec->file_name_is_absolute($try) ) {
|
|
# make path absolute
|
|
$try = File::Spec->catfile( $cwd ,$try);
|
|
}
|
|
# simplify path
|
|
$try = File::Spec->canonpath($try);
|
|
|
|
my $start_in;
|
|
my $modname_prefix;
|
|
if($self->{'dir_prefix'}) {
|
|
$start_in = File::Spec->catdir(
|
|
$try,
|
|
grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
|
|
);
|
|
$modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
|
|
$verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
|
|
"giving $start_in (= @$modname_prefix)\n";
|
|
} else {
|
|
$start_in = $try;
|
|
}
|
|
|
|
if( $self->{'_dirs_visited'}{$start_in} ) {
|
|
$verbose and print "Directory '$start_in' already seen, skipping.\n";
|
|
next;
|
|
} else {
|
|
$self->{'_dirs_visited'}{$start_in} = 1;
|
|
}
|
|
|
|
unless(-e $start_in) {
|
|
$verbose and print "Skipping non-existent $start_in\n";
|
|
next;
|
|
}
|
|
|
|
my $closure = $self->_make_search_callback;
|
|
|
|
if(-d $start_in) {
|
|
# Normal case:
|
|
$verbose and print "Beginning excursion under $start_in\n";
|
|
$self->_recurse_dir( $start_in, $closure, $modname_prefix );
|
|
$verbose and print "Back from excursion under $start_in\n\n";
|
|
|
|
} elsif(-f _) {
|
|
# A excursion consisting of just one file!
|
|
$_ = basename($start_in);
|
|
$verbose and print "Pondering $start_in ($_)\n";
|
|
$closure->($start_in, $_, 0, []);
|
|
|
|
} else {
|
|
$verbose and print "Skipping mysterious $start_in\n";
|
|
}
|
|
}
|
|
$self->progress and $self->progress->done(
|
|
"Noted $$self{'_scan_count'} Pod files total");
|
|
$self->ciseen( {} );
|
|
|
|
return unless defined wantarray; # void
|
|
return $self->name2path unless wantarray; # scalar
|
|
return $self->name2path, $self->path2name; # list
|
|
}
|
|
|
|
#==========================================================================
|
|
sub _make_search_callback {
|
|
my $self = $_[0];
|
|
|
|
# Put the options in variables, for easy access
|
|
my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,
|
|
$path2name, $name2path, $recurse, $ciseen, $is_case_insensitive) =
|
|
map scalar($self->$_()),
|
|
qw(laborious verbose shadows limit_re callback progress
|
|
path2name name2path recurse ciseen is_case_insensitive);
|
|
my ($seen, $remember, $files_for);
|
|
if ($is_case_insensitive) {
|
|
$seen = sub { $ciseen->{ lc $_[0] } };
|
|
$remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; };
|
|
$files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } };
|
|
} else {
|
|
$seen = sub { $name2path->{ $_[0] } };
|
|
$remember = sub { $name2path->{ $_[0] } = $_[1] };
|
|
$files_for = sub { my $n = $_[0]; grep { $path2name->{$_} eq $n } %{ $path2name } };
|
|
}
|
|
|
|
my($file, $shortname, $isdir, $modname_bits);
|
|
return sub {
|
|
($file, $shortname, $isdir, $modname_bits) = @_;
|
|
|
|
if($isdir) { # this never gets called on the startdir itself, just subdirs
|
|
|
|
unless( $recurse ) {
|
|
$verbose and print "Not recursing into '$file' as per requested.\n";
|
|
return 'PRUNE';
|
|
}
|
|
|
|
if( $self->{'_dirs_visited'}{$file} ) {
|
|
$verbose and print "Directory '$file' already seen, skipping.\n";
|
|
return 'PRUNE';
|
|
}
|
|
|
|
print "Looking in dir $file\n" if $verbose;
|
|
|
|
unless ($laborious) { # $laborious overrides pruning
|
|
if( m/^(\d+\.[\d_]{3,})\z/s
|
|
and do { my $x = $1; $x =~ tr/_//d; $x != $] }
|
|
) {
|
|
$verbose and print "Perl $] version mismatch on $_, skipping.\n";
|
|
return 'PRUNE';
|
|
}
|
|
|
|
if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
|
|
$verbose and print "$_ is a well-named module subdir. Looking....\n";
|
|
} else {
|
|
$verbose and print "$_ is a fishy directory name. Skipping.\n";
|
|
return 'PRUNE';
|
|
}
|
|
} # end unless $laborious
|
|
|
|
$self->{'_dirs_visited'}{$file} = 1;
|
|
return; # (not pruning);
|
|
}
|
|
|
|
# Make sure it's a file even worth even considering
|
|
if($laborious) {
|
|
unless(
|
|
m/\.(pod|pm|plx?)\z/i || -x _ and -T _
|
|
# Note that the cheapest operation (the RE) is run first.
|
|
) {
|
|
$verbose > 1 and print " Brushing off uninteresting $file\n";
|
|
return;
|
|
}
|
|
} else {
|
|
unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
|
|
$verbose > 1 and print " Brushing off oddly-named $file\n";
|
|
return;
|
|
}
|
|
}
|
|
|
|
$verbose and print "Considering item $file\n";
|
|
my $name = $self->_path2modname( $file, $shortname, $modname_bits );
|
|
$verbose > 0.01 and print " Nominating $file as $name\n";
|
|
|
|
if($limit_re and $name !~ m/$limit_re/i) {
|
|
$verbose and print "Shunning $name as not matching $limit_re\n";
|
|
return;
|
|
}
|
|
|
|
if( !$shadows and $seen->($name) ) {
|
|
$verbose and print "Not worth considering $file ",
|
|
"-- already saw $name as ",
|
|
join(' ', $files_for->($name)), "\n";
|
|
return;
|
|
}
|
|
|
|
# Put off until as late as possible the expense of
|
|
# actually reading the file:
|
|
$progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
|
|
return unless $self->contains_pod( $file );
|
|
++ $self->{'_scan_count'};
|
|
|
|
# Or finally take note of it:
|
|
if ( my $prev = $seen->($name) ) {
|
|
$verbose and print
|
|
"Duplicate POD found (shadowing?): $name ($file)\n",
|
|
" Already seen in ", join(' ', $files_for->($name)), "\n";
|
|
} else {
|
|
$remember->($name, $file); # Noting just the first occurrence
|
|
}
|
|
$verbose and print " Noting $name = $file\n";
|
|
if( $callback ) {
|
|
local $_ = $_; # insulate from changes, just in case
|
|
$callback->($file, $name);
|
|
}
|
|
$path2name->{$file} = $name;
|
|
return;
|
|
}
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _path2modname {
|
|
my($self, $file, $shortname, $modname_bits) = @_;
|
|
|
|
# this code simplifies the POD name for Perl modules:
|
|
# * remove "site_perl"
|
|
# * remove e.g. "i586-linux" (from 'archname')
|
|
# * remove e.g. 5.00503
|
|
# * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
|
|
# * dig into the file for case-preserved name if not already mixed case
|
|
|
|
my @m = @$modname_bits;
|
|
my $x;
|
|
my $verbose = $self->verbose;
|
|
|
|
# Shaving off leading naughty-bits
|
|
while(@m
|
|
and defined($x = lc( $m[0] ))
|
|
and( $x eq 'site_perl'
|
|
or($x =~ m/^pods?$/ and @m == 1 and $shortname =~ m{^perl.*\.pod$}s )
|
|
or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum
|
|
or $x eq lc( $Config::Config{'archname'} )
|
|
)) { shift @m }
|
|
|
|
my $name = join '::', @m, $shortname;
|
|
$self->_simplify_base($name);
|
|
|
|
# On VMS, case-preserved document names can't be constructed from
|
|
# filenames, so try to extract them from the "=head1 NAME" tag in the
|
|
# file instead.
|
|
if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
|
|
open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
|
|
my $in_pod = 0;
|
|
my $in_name = 0;
|
|
my $line;
|
|
while ($line = <PODFILE>) {
|
|
chomp $line;
|
|
$in_pod = 1 if ($line =~ m/^=\w/);
|
|
$in_pod = 0 if ($line =~ m/^=cut/);
|
|
next unless $in_pod; # skip non-pod text
|
|
next if ($line =~ m/^\s*\z/); # and blank lines
|
|
next if ($in_pod && ($line =~ m/^X</)); # and commands
|
|
if ($in_name) {
|
|
if ($line =~ m/(\w+::)?(\w+)/) {
|
|
# substitute case-preserved version of name
|
|
my $podname = $2;
|
|
my $prefix = $1 || '';
|
|
$verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
|
|
unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
|
|
$verbose and print "Attempting case restore of '$name' from '$podname'\n";
|
|
$name =~ s/$podname/$podname/i;
|
|
}
|
|
last;
|
|
}
|
|
}
|
|
$in_name = 1 if ($line =~ m/^=head1 NAME/);
|
|
}
|
|
close PODFILE;
|
|
}
|
|
|
|
return $name;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _recurse_dir {
|
|
my($self, $startdir, $callback, $modname_bits) = @_;
|
|
|
|
my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
|
|
my $verbose = $self->verbose;
|
|
|
|
my $here_string = File::Spec->curdir;
|
|
my $up_string = File::Spec->updir;
|
|
$modname_bits ||= [];
|
|
|
|
my $recursor;
|
|
$recursor = sub {
|
|
my($dir_long, $dir_bare) = @_;
|
|
if( @$modname_bits >= 10 ) {
|
|
$verbose and print "Too deep! [@$modname_bits]\n";
|
|
return;
|
|
}
|
|
|
|
unless(-d $dir_long) {
|
|
$verbose > 2 and print "But it's not a dir! $dir_long\n";
|
|
return;
|
|
}
|
|
unless( opendir(INDIR, $dir_long) ) {
|
|
$verbose > 2 and print "Can't opendir $dir_long : $!\n";
|
|
closedir(INDIR);
|
|
return
|
|
}
|
|
|
|
# Load all items; put no extension before .pod before .pm before .plx?.
|
|
my @items = map { $_->[0] }
|
|
sort { $a->[1] cmp $b->[1] || $b->[2] cmp $a->[2] }
|
|
map {
|
|
(my $t = $_) =~ s/[.]p(m|lx?|od)\z//;
|
|
[$_, $t, lc($1 || 'z') ]
|
|
} readdir(INDIR);
|
|
closedir(INDIR);
|
|
|
|
push @$modname_bits, $dir_bare unless $dir_bare eq '';
|
|
|
|
my $i_full;
|
|
foreach my $i (@items) {
|
|
next if $i eq $here_string or $i eq $up_string or $i eq '';
|
|
$i_full = File::Spec->catfile( $dir_long, $i );
|
|
|
|
if(!-r $i_full) {
|
|
$verbose and print "Skipping unreadable $i_full\n";
|
|
|
|
} elsif(-f $i_full) {
|
|
$_ = $i;
|
|
$callback->( $i_full, $i, 0, $modname_bits );
|
|
|
|
} elsif(-d _) {
|
|
$i =~ s/\.DIR\z//i if $^O eq 'VMS';
|
|
$_ = $i;
|
|
my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
|
|
|
|
if($rv eq 'PRUNE') {
|
|
$verbose > 1 and print "OK, pruning";
|
|
} else {
|
|
# Otherwise, recurse into it
|
|
$recursor->( File::Spec->catdir($dir_long, $i) , $i);
|
|
}
|
|
} else {
|
|
$verbose > 1 and print "Skipping oddity $i_full\n";
|
|
}
|
|
}
|
|
pop @$modname_bits;
|
|
return;
|
|
};;
|
|
|
|
local $_;
|
|
$recursor->($startdir, '');
|
|
|
|
undef $recursor; # allow it to be GC'd
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
#==========================================================================
|
|
|
|
sub run {
|
|
# A function, useful in one-liners
|
|
|
|
my $self = __PACKAGE__->new;
|
|
$self->limit_glob($ARGV[0]) if @ARGV;
|
|
$self->callback( sub {
|
|
my($file, $name) = @_;
|
|
my $version = '';
|
|
|
|
# Yes, I know we won't catch the version in like a File/Thing.pm
|
|
# if we see File/Thing.pod first. That's just the way the
|
|
# cookie crumbles. -- SMB
|
|
|
|
if($file =~ m/\.pod$/i) {
|
|
# Don't bother looking for $VERSION in .pod files
|
|
DEBUG and print "Not looking for \$VERSION in .pod $file\n";
|
|
} elsif( !open(INPOD, $file) ) {
|
|
DEBUG and print "Couldn't open $file: $!\n";
|
|
close(INPOD);
|
|
} else {
|
|
# Sane case: file is readable
|
|
my $lines = 0;
|
|
while(<INPOD>) {
|
|
last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
|
|
if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
|
|
DEBUG and print "Found version line (#$lines): $_";
|
|
s/\s*\#.*//s;
|
|
s/\;\s*$//s;
|
|
s/\s+$//s;
|
|
s/\t+/ /s; # nix tabs
|
|
# Optimize the most common cases:
|
|
$_ = "v$1"
|
|
if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
|
|
# like in $VERSION = "3.14159";
|
|
or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
|
|
# like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
|
|
;
|
|
|
|
# Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
|
|
$_ = sprintf("v%d.%s",
|
|
map {s/_//g; $_}
|
|
$1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
|
|
if m{\$Name:\s*([^\$]+)\$}s
|
|
;
|
|
$version = $_;
|
|
DEBUG and print "Noting $version as version\n";
|
|
last;
|
|
}
|
|
}
|
|
close(INPOD);
|
|
}
|
|
print "$name\t$version\t$file\n";
|
|
return;
|
|
# End of callback!
|
|
});
|
|
|
|
$self->survey;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub simplify_name {
|
|
my($self, $str) = @_;
|
|
|
|
# Remove all path components
|
|
# XXX Why not just use basename()? -- SMB
|
|
|
|
if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
|
|
else { $str =~ s{^.*/+}{}s }
|
|
|
|
$self->_simplify_base($str);
|
|
return $str;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _simplify_base { # Internal method only
|
|
|
|
# strip Perl's own extensions
|
|
$_[1] =~ s/\.(pod|pm|plx?)\z//i;
|
|
|
|
# strip meaningless extensions on Win32 and OS/2
|
|
$_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
|
|
|
|
# strip meaningless extensions on VMS
|
|
$_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
|
|
|
|
return;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _expand_inc {
|
|
my($self, $search_dirs) = @_;
|
|
|
|
return unless $self->{'inc'};
|
|
my %seen = map { File::Spec->rel2abs($_) => 1 } @{ $search_dirs };
|
|
|
|
if ($^O eq 'MacOS') {
|
|
push @$search_dirs,
|
|
grep { !$seen{ File::Spec->rel2abs($_) }++ } $self->_mac_whammy(@INC);
|
|
# Any other OSs need custom handling here?
|
|
} else {
|
|
push @$search_dirs,
|
|
grep { !$seen{ File::Spec->rel2abs($_) }++ } @INC;
|
|
}
|
|
|
|
$self->{'laborious'} = 0; # Since inc said to use INC
|
|
return;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
|
|
my @them;
|
|
(undef,@them) = @_;
|
|
for $_ (@them) {
|
|
if ( $_ eq '.' ) {
|
|
$_ = ':';
|
|
} elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
|
|
$_ = ':'. $_;
|
|
} else {
|
|
$_ =~ s|^\./|:|;
|
|
}
|
|
}
|
|
return @them;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _limit_glob_to_limit_re {
|
|
my $self = $_[0];
|
|
my $limit_glob = $self->{'limit_glob'} || return;
|
|
|
|
my $limit_re = '^' . quotemeta($limit_glob) . '$';
|
|
$limit_re =~ s/\\\?/./g; # glob "?" => "."
|
|
$limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?"
|
|
$limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
|
|
|
|
$self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
|
|
|
|
# A common optimization:
|
|
if(!exists($self->{'dir_prefix'})
|
|
and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*"
|
|
# Optimize for sane and common cases (but not things like "*::File")
|
|
) {
|
|
$self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
|
|
$self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
|
|
}
|
|
|
|
return $limit_re;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu>
|
|
|
|
sub _actual_filenames {
|
|
my $dir = shift;
|
|
my $fn = lc shift;
|
|
opendir my ($dh), $dir or return;
|
|
return map { File::Spec->catdir($dir, $_) }
|
|
grep { lc $_ eq $fn } readdir $dh;
|
|
}
|
|
|
|
sub find {
|
|
my($self, $pod, @search_dirs) = @_;
|
|
$self = $self->new unless ref $self; # tolerate being a class method
|
|
|
|
# Check usage
|
|
Carp::carp 'Usage: \$self->find($podname, ...)'
|
|
unless defined $pod and length $pod;
|
|
|
|
my $verbose = $self->verbose;
|
|
|
|
# Split on :: and then join the name together using File::Spec
|
|
my @parts = split /::/, $pod;
|
|
$verbose and print "Chomping {$pod} => {@parts}\n";
|
|
|
|
#@search_dirs = File::Spec->curdir unless @search_dirs;
|
|
|
|
$self->_expand_inc(\@search_dirs);
|
|
# Add location of binaries such as pod2text:
|
|
push @search_dirs, $Config::Config{'scriptdir'} if $self->inc;
|
|
|
|
my %seen_dir;
|
|
while (my $dir = shift @search_dirs ) {
|
|
next unless defined $dir and length $dir;
|
|
next if $seen_dir{$dir};
|
|
$seen_dir{$dir} = 1;
|
|
unless(-d $dir) {
|
|
print "Directory $dir does not exist\n" if $verbose;
|
|
}
|
|
|
|
print "Looking in directory $dir\n" if $verbose;
|
|
my $fullname = File::Spec->catfile( $dir, @parts );
|
|
print "Filename is now $fullname\n" if $verbose;
|
|
|
|
foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions
|
|
my $fullext = $fullname . $ext;
|
|
if ( -f $fullext and $self->contains_pod($fullext) ) {
|
|
print "FOUND: $fullext\n" if $verbose;
|
|
if (@parts > 1 && lc $parts[0] eq 'pod' && $self->is_case_insensitive() && $ext eq '.pod') {
|
|
# Well, this file could be for a program (perldoc) but we actually
|
|
# want a module (Pod::Perldoc). So see if there is a .pm with the
|
|
# proper casing.
|
|
my $subdir = dirname $fullext;
|
|
unless (grep { $fullext eq $_ } _actual_filenames $subdir, "$parts[-1].pod") {
|
|
print "# Looking for alternate spelling in $subdir\n" if $verbose;
|
|
# Try the .pm file.
|
|
my $pm = $fullname . '.pm';
|
|
if ( -f $pm and $self->contains_pod($pm) ) {
|
|
# Prefer the .pm if its case matches.
|
|
if (grep { $pm eq $_ } _actual_filenames $subdir, "$parts[-1].pm") {
|
|
print "FOUND: $fullext\n" if $verbose;
|
|
return $pm;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $fullext;
|
|
}
|
|
}
|
|
|
|
# Case-insensitively Look for ./pod directories and slip them in.
|
|
for my $subdir ( _actual_filenames($dir, 'pods'), _actual_filenames($dir, 'pod') ) {
|
|
if (-d $subdir) {
|
|
$verbose and print "Noticing $subdir and looking there...\n";
|
|
unshift @search_dirs, $subdir;
|
|
}
|
|
}
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub contains_pod {
|
|
my($self, $file) = @_;
|
|
my $verbose = $self->{'verbose'};
|
|
|
|
# check for one line of POD
|
|
$verbose > 1 and print " Scanning $file for pod...\n";
|
|
unless( open(MAYBEPOD,"<$file") ) {
|
|
print "Error: $file is unreadable: $!\n";
|
|
return undef;
|
|
}
|
|
|
|
sleep($SLEEPY - 1) if $SLEEPY;
|
|
# avoid totally hogging the processor on OSs with poor process control
|
|
|
|
local $_;
|
|
while( <MAYBEPOD> ) {
|
|
if(m/^=(head\d|pod|over|item)\b/s) {
|
|
close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
|
|
chomp;
|
|
$verbose > 1 and print " Found some pod ($_) in $file\n";
|
|
return 1;
|
|
}
|
|
}
|
|
close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
|
|
$verbose > 1 and print " No POD in $file, skipping.\n";
|
|
return 0;
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
sub _accessorize { # A simple-minded method-maker
|
|
shift;
|
|
no strict 'refs';
|
|
foreach my $attrname (@_) {
|
|
*{caller() . '::' . $attrname} = sub {
|
|
use strict;
|
|
$Carp::CarpLevel = 1, Carp::croak(
|
|
"Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
|
|
) unless (@_ == 1 or @_ == 2) and ref $_[0];
|
|
|
|
# Read access:
|
|
return $_[0]->{$attrname} if @_ == 1;
|
|
|
|
# Write access:
|
|
$_[0]->{$attrname} = $_[1];
|
|
return $_[0]; # RETURNS MYSELF!
|
|
};
|
|
}
|
|
# Ya know, they say accessories make the ensemble!
|
|
return;
|
|
}
|
|
|
|
#==========================================================================
|
|
sub _state_as_string {
|
|
my $self = $_[0];
|
|
return '' unless ref $self;
|
|
my @out = "{\n # State of $self ...\n";
|
|
foreach my $k (sort keys %$self) {
|
|
push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n";
|
|
}
|
|
push @out, "}\n";
|
|
my $x = join '', @out;
|
|
$x =~ s/^/#/mg;
|
|
return $x;
|
|
}
|
|
|
|
sub _esc {
|
|
my $in = $_[0];
|
|
return 'undef' unless defined $in;
|
|
$in =~
|
|
s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
|
|
<'\\x'.(unpack("H2",$1))>eg;
|
|
return qq{"$in"};
|
|
}
|
|
|
|
#==========================================================================
|
|
|
|
run() unless caller; # run if "perl whatever/Search.pm"
|
|
|
|
1;
|
|
|
|
#==========================================================================
|
|
|
|
__END__
|
|
|
|
|
|
=head1 NAME
|
|
|
|
Pod::Simple::Search - find POD documents in directory trees
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Pod::Simple::Search;
|
|
my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey;
|
|
print "Looky see what I found: ",
|
|
join(' ', sort keys %$name2path), "\n";
|
|
|
|
print "LWPUA docs = ",
|
|
Pod::Simple::Search->new->find('LWP::UserAgent') || "?",
|
|
"\n";
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
B<Pod::Simple::Search> is a class that you use for running searches
|
|
for Pod files. An object of this class has several attributes
|
|
(mostly options for controlling search options), and some methods
|
|
for searching based on those attributes.
|
|
|
|
The way to use this class is to make a new object of this class,
|
|
set any options, and then call one of the search options
|
|
(probably C<survey> or C<find>). The sections below discuss the
|
|
syntaxes for doing all that.
|
|
|
|
|
|
=head1 CONSTRUCTOR
|
|
|
|
This class provides the one constructor, called C<new>.
|
|
It takes no parameters:
|
|
|
|
use Pod::Simple::Search;
|
|
my $search = Pod::Simple::Search->new;
|
|
|
|
=head1 ACCESSORS
|
|
|
|
This class defines several methods for setting (and, occasionally,
|
|
reading) the contents of an object. With two exceptions (discussed at
|
|
the end of this section), these attributes are just for controlling the
|
|
way searches are carried out.
|
|
|
|
Note that each of these return C<$self> when you call them as
|
|
C<< $self->I<whatever(value)> >>. That's so that you can chain
|
|
together set-attribute calls like this:
|
|
|
|
my $name2path =
|
|
Pod::Simple::Search->new
|
|
-> inc(0) -> verbose(1) -> callback(\&blab)
|
|
->survey(@there);
|
|
|
|
...which works exactly as if you'd done this:
|
|
|
|
my $search = Pod::Simple::Search->new;
|
|
$search->inc(0);
|
|
$search->verbose(1);
|
|
$search->callback(\&blab);
|
|
my $name2path = $search->survey(@there);
|
|
|
|
=over
|
|
|
|
=item $search->inc( I<true-or-false> );
|
|
|
|
This attribute, if set to a true value, means that searches should
|
|
implicitly add perl's I<@INC> paths. This
|
|
automatically considers paths specified in the C<PERL5LIB> environment
|
|
as this is prepended to I<@INC> by the Perl interpreter itself.
|
|
This attribute's default value is B<TRUE>. If you want to search
|
|
only specific directories, set $self->inc(0) before calling
|
|
$inc->survey or $inc->find.
|
|
|
|
|
|
=item $search->verbose( I<nonnegative-number> );
|
|
|
|
This attribute, if set to a nonzero positive value, will make searches output
|
|
(via C<warn>) notes about what they're doing as they do it.
|
|
This option may be useful for debugging a pod-related module.
|
|
This attribute's default value is zero, meaning that no C<warn> messages
|
|
are produced. (Setting verbose to 1 turns on some messages, and setting
|
|
it to 2 turns on even more messages, i.e., makes the following search(es)
|
|
even more verbose than 1 would make them.)
|
|
|
|
=item $search->limit_glob( I<some-glob-string> );
|
|
|
|
This option means that you want to limit the results just to items whose
|
|
podnames match the given glob/wildcard expression. For example, you
|
|
might limit your search to just "LWP::*", to search only for modules
|
|
starting with "LWP::*" (but not including the module "LWP" itself); or
|
|
you might limit your search to "LW*" to see only modules whose (full)
|
|
names begin with "LW"; or you might search for "*Find*" to search for
|
|
all modules with "Find" somewhere in their full name. (You can also use
|
|
"?" in a glob expression; so "DB?" will match "DBI" and "DBD".)
|
|
|
|
|
|
=item $search->callback( I<\&some_routine> );
|
|
|
|
This attribute means that every time this search sees a matching
|
|
Pod file, it should call this callback routine. The routine is called
|
|
with two parameters: the current file's filespec, and its pod name.
|
|
(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would
|
|
be in C<@_>.)
|
|
|
|
The callback routine's return value is not used for anything.
|
|
|
|
This attribute's default value is false, meaning that no callback
|
|
is called.
|
|
|
|
=item $search->laborious( I<true-or-false> );
|
|
|
|
Unless you set this attribute to a true value, Pod::Search will
|
|
apply Perl-specific heuristics to find the correct module PODs quickly.
|
|
This attribute's default value is false. You won't normally need
|
|
to set this to true.
|
|
|
|
Specifically: Turning on this option will disable the heuristics for
|
|
seeing only files with Perl-like extensions, omitting subdirectories
|
|
that are numeric but do I<not> match the current Perl interpreter's
|
|
version ID, suppressing F<site_perl> as a module hierarchy name, etc.
|
|
|
|
=item $search->recurse( I<true-or-false> );
|
|
|
|
Unless you set this attribute to a false value, Pod::Search will
|
|
recurse into subdirectories of the search directories.
|
|
|
|
=item $search->shadows( I<true-or-false> );
|
|
|
|
Unless you set this attribute to a true value, Pod::Simple::Search will
|
|
consider only the first file of a given modulename as it looks thru the
|
|
specified directories; that is, with this option off, if
|
|
Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this
|
|
search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm>
|
|
later on in that search, because that file is merely a "shadow". But if
|
|
you turn on C<< $self->shadows(1) >>, then these "shadow" files are
|
|
inspected too, and are noted in the pathname2podname return hash.
|
|
|
|
This attribute's default value is false; and normally you won't
|
|
need to turn it on.
|
|
|
|
=item $search->is_case_insensitive( I<true-or-false> );
|
|
|
|
Pod::Simple::Search will by default internally make an assumption
|
|
based on the underlying filesystem where the class file is found
|
|
whether it is case insensitive or not.
|
|
|
|
If it is determined to be case insensitive, during survey() it may
|
|
skip pod files/modules that happen to be equal to names it's already
|
|
seen, ignoring case.
|
|
|
|
However, it's possible to have distinct files in different directories
|
|
that intentionally has the same name, just differing in case, that should
|
|
be reported. Hence, you may force the behavior by setting this to true
|
|
or false.
|
|
|
|
=item $search->limit_re( I<some-regxp> );
|
|
|
|
Setting this attribute (to a value that's a regexp) means that you want
|
|
to limit the results just to items whose podnames match the given
|
|
regexp. Normally this option is not needed, and the more efficient
|
|
C<limit_glob> attribute is used instead.
|
|
|
|
=item $search->dir_prefix( I<some-string-value> );
|
|
|
|
Setting this attribute to a string value means that the searches should
|
|
begin in the specified subdirectory name (like "Pod" or "File::Find",
|
|
also expressible as "File/Find"). For example, the search option
|
|
C<< $search->limit_glob("File::Find::R*") >>
|
|
is the same as the combination of the search options
|
|
C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>.
|
|
|
|
Normally you don't need to know about the C<dir_prefix> option, but I
|
|
include it in case it might prove useful for someone somewhere.
|
|
|
|
(Implementationally, searching with limit_glob ends up setting limit_re
|
|
and usually dir_prefix.)
|
|
|
|
|
|
=item $search->progress( I<some-progress-object> );
|
|
|
|
If you set a value for this attribute, the value is expected
|
|
to be an object (probably of a class that you define) that has a
|
|
C<reach> method and a C<done> method. This is meant for reporting
|
|
progress during the search, if you don't want to use a simple
|
|
callback.
|
|
|
|
Normally you don't need to know about the C<progress> option, but I
|
|
include it in case it might prove useful for someone somewhere.
|
|
|
|
While a search is in progress, the progress object's C<reach> and
|
|
C<done> methods are called like this:
|
|
|
|
# Every time a file is being scanned for pod:
|
|
$progress->reach($count, "Scanning $file"); ++$count;
|
|
|
|
# And then at the end of the search:
|
|
$progress->done("Noted $count Pod files total");
|
|
|
|
Internally, we often set this to an object of class
|
|
Pod::Simple::Progress. That class is probably undocumented,
|
|
but you may wish to look at its source.
|
|
|
|
|
|
=item $name2path = $self->name2path;
|
|
|
|
This attribute is not a search parameter, but is used to report the
|
|
result of C<survey> method, as discussed in the next section.
|
|
|
|
=item $path2name = $self->path2name;
|
|
|
|
This attribute is not a search parameter, but is used to report the
|
|
result of C<survey> method, as discussed in the next section.
|
|
|
|
=back
|
|
|
|
=head1 MAIN SEARCH METHODS
|
|
|
|
Once you've actually set any options you want (if any), you can go
|
|
ahead and use the following methods to search for Pod files
|
|
in particular ways.
|
|
|
|
|
|
=head2 C<< $search->survey( @directories ) >>
|
|
|
|
The method C<survey> searches for POD documents in a given set of
|
|
files and/or directories. This runs the search according to the various
|
|
options set by the accessors above. (For example, if the C<inc> attribute
|
|
is on, as it is by default, then the perl @INC directories are implicitly
|
|
added to the list of directories (if any) that you specify.)
|
|
|
|
The return value of C<survey> is two hashes:
|
|
|
|
=over
|
|
|
|
=item C<name2path>
|
|
|
|
A hash that maps from each pod-name to the filespec (like
|
|
"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm")
|
|
|
|
=item C<path2name>
|
|
|
|
A hash that maps from each Pod filespec to its pod-name (like
|
|
"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing")
|
|
|
|
=back
|
|
|
|
Besides saving these hashes as the hashref attributes
|
|
C<name2path> and C<path2name>, calling this function also returns
|
|
these hashrefs. In list context, the return value of
|
|
C<< $search->survey >> is the list C<(\%name2path, \%path2name)>.
|
|
In scalar context, the return value is C<\%name2path>.
|
|
Or you can just call this in void context.
|
|
|
|
Regardless of calling context, calling C<survey> saves
|
|
its results in its C<name2path> and C<path2name> attributes.
|
|
|
|
E.g., when searching in F<$HOME/perl5lib>, the file
|
|
F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
|
|
whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
|
|
I<Myclass::Subclass>. The name information can be used for POD
|
|
translators.
|
|
|
|
Only text files containing at least one valid POD command are found.
|
|
|
|
In verbose mode, a warning is printed if shadows are found (i.e., more
|
|
than one POD file with the same POD name is found, e.g. F<CPAN.pm> in
|
|
different directories). This usually indicates duplicate occurrences of
|
|
modules in the I<@INC> search path, which is occasionally inadvertent
|
|
(but is often simply a case of a user's path dir having a more recent
|
|
version than the system's general path dirs in general.)
|
|
|
|
The options to this argument is a list of either directories that are
|
|
searched recursively, or files. (Usually you wouldn't specify files,
|
|
but just dirs.) Or you can just specify an empty-list, as in
|
|
$name2path; with the C<inc> option on, as it is by default.
|
|
|
|
The POD names of files are the plain basenames with any Perl-like
|
|
extension (.pm, .pl, .pod) stripped, and path separators replaced by
|
|
C<::>'s.
|
|
|
|
Calling Pod::Simple::Search->search(...) is short for
|
|
Pod::Simple::Search->new->search(...). That is, a throwaway object
|
|
with default attribute values is used.
|
|
|
|
|
|
=head2 C<< $search->simplify_name( $str ) >>
|
|
|
|
The method B<simplify_name> is equivalent to B<basename>, but also
|
|
strips Perl-like extensions (.pm, .pl, .pod) and extensions like
|
|
F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
|
|
|
|
|
|
=head2 C<< $search->find( $pod ) >>
|
|
|
|
=head2 C<< $search->find( $pod, @search_dirs ) >>
|
|
|
|
Returns the location of a Pod file, given a Pod/module/script name
|
|
(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of
|
|
what files/directories to look in.
|
|
It searches according to the various options set by the accessors above.
|
|
(For example, if the C<inc> attribute is on, as it is by default, then
|
|
the perl @INC directories are implicitly added to the list of
|
|
directories (if any) that you specify.)
|
|
|
|
This returns the full path of the first occurrence to the file.
|
|
Package names (eg 'A::B') are automatically converted to directory
|
|
names in the selected directory. Additionally, '.pm', '.pl' and '.pod'
|
|
are automatically appended to the search as required.
|
|
(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm",
|
|
"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.)
|
|
|
|
If no such Pod file is found, this method returns undef.
|
|
|
|
If any of the given search directories contains a F<pod/> subdirectory,
|
|
then it is searched. (That's how we manage to find F<perlfunc>,
|
|
for example, which is usually in F<pod/perlfunc> in most Perl dists.)
|
|
|
|
The C<verbose> and C<inc> attributes influence the behavior of this
|
|
search; notably, C<inc>, if true, adds @INC I<and also
|
|
$Config::Config{'scriptdir'}> to the list of directories to search.
|
|
|
|
It is common to simply say C<< $filename = Pod::Simple::Search-> new
|
|
->find("perlvar") >> so that just the @INC (well, and scriptdir)
|
|
directories are searched. (This happens because the C<inc>
|
|
attribute is true by default.)
|
|
|
|
Calling Pod::Simple::Search->find(...) is short for
|
|
Pod::Simple::Search->new->find(...). That is, a throwaway object
|
|
with default attribute values is used.
|
|
|
|
|
|
=head2 C<< $self->contains_pod( $file ) >>
|
|
|
|
Returns true if the supplied filename (not POD module) contains some Pod
|
|
documentation.
|
|
|
|
=head1 SUPPORT
|
|
|
|
Questions or discussion about POD and Pod::Simple should be sent to the
|
|
pod-people@perl.org mail list. Send an empty email to
|
|
pod-people-subscribe@perl.org to subscribe.
|
|
|
|
This module is managed in an open GitHub repository,
|
|
L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
|
|
to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
|
|
|
|
Patches against Pod::Simple are welcome. Please send bug reports to
|
|
<bug-pod-simple@rt.cpan.org>.
|
|
|
|
=head1 COPYRIGHT AND DISCLAIMERS
|
|
|
|
Copyright (c) 2002 Sean M. Burke.
|
|
|
|
This library is free software; you can redistribute it and/or modify it
|
|
under the same terms as Perl itself.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
without any warranty; without even the implied warranty of
|
|
merchantability or fitness for a particular purpose.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Pod::Simple was created by Sean M. Burke <sburke@cpan.org> with code borrowed
|
|
from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from
|
|
Nick Ing-Simmons' C<PodToHtml>.
|
|
|
|
But don't bother him, he's retired.
|
|
|
|
Pod::Simple is maintained by:
|
|
|
|
=over
|
|
|
|
=item * Allison Randal C<allison@perl.org>
|
|
|
|
=item * Hans Dieter Pearcey C<hdp@cpan.org>
|
|
|
|
=item * David E. Wheeler C<dwheeler@cpan.org>
|
|
|
|
=back
|
|
|
|
=cut
|