File Coverage

blib/lib/Pod/Simple/Search.pm
Criterion Covered Total %
statement 269 390 68.9
branch 111 258 43.0
condition 45 93 48.3
subroutine 30 38 78.9
pod 4 7 57.1
total 459 786 58.4


line stmt bran cond sub pod time code
1             require 5.005;
2             package Pod::Simple::Search;
3 14     14   6482 use strict;
  14         80  
  14         565  
4              
5 14     14   86 use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
  14         24  
  14         1283  
6             $VERSION = '3.42'; ## Current version of this package
7              
8 14 50   14   254 BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
9 14     14   71 use Carp ();
  14         20  
  14         1399  
10              
11             $SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
12             # flag to occasionally sleep for $SLEEPY - 1 seconds.
13              
14             $MAX_VERSION_WITHIN ||= 60;
15              
16             #############################################################################
17              
18             #use diagnostics;
19 14     14   148 use File::Spec ();
  14         21  
  14         377  
20 14     14   75 use File::Basename qw( basename dirname );
  14         26  
  14         1610  
21 14     14   79 use Config ();
  14         27  
  14         270  
22 14     14   78 use Cwd qw( cwd );
  14         22  
  14         66516  
23              
24             #==========================================================================
25             __PACKAGE__->_accessorize( # Make my dumb accessor methods
26             'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob',
27             'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse',
28             'ciseen', 'is_case_insensitive'
29             );
30             #==========================================================================
31              
32             sub new {
33 13     13 0 710 my $class = shift;
34 13   33     108 my $self = bless {}, ref($class) || $class;
35 13         70 $self->init;
36 13         36 return $self;
37             }
38              
39             sub init {
40 13     13 0 30 my $self = shift;
41 13         60 $self->inc(1);
42 13         72 $self->recurse(1);
43 13         57 $self->verbose(DEBUG);
44 13   33     249 $self->is_case_insensitive(-e uc __FILE__ && -e lc __FILE__);
45 13         24 return $self;
46             }
47              
48             #--------------------------------------------------------------------------
49              
50             sub survey {
51 15     15 1 3323 my($self, @search_dirs) = @_;
52 15 50       166 $self = $self->new unless ref $self; # tolerate being a class method
53              
54 15         192 $self->_expand_inc( \@search_dirs );
55              
56 15         127 $self->{'_scan_count'} = 0;
57 15         84 $self->{'_dirs_visited'} = {};
58 15         176 $self->path2name( {} );
59 15         92 $self->name2path( {} );
60 15         107 $self->ciseen( {} );
61 15 100       120 $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
62 15         36497 my $cwd = cwd();
63 15         565 my $verbose = $self->verbose;
64 15         162 local $_; # don't clobber the caller's $_ !
65              
66 15         179 foreach my $try (@search_dirs) {
67 38 100       1116 unless( File::Spec->file_name_is_absolute($try) ) {
68             # make path absolute
69 2         74 $try = File::Spec->catfile( $cwd ,$try);
70             }
71             # simplify path
72 38         309 $try = File::Spec->canonpath($try);
73              
74 38         152 my $start_in;
75             my $modname_prefix;
76 38 100       266 if($self->{'dir_prefix'}) {
77             $start_in = File::Spec->catdir(
78             $try,
79 3         56 grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
80             );
81 3         28 $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
82 3 50       15 $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
83             "giving $start_in (= @$modname_prefix)\n";
84             } else {
85 35         132 $start_in = $try;
86             }
87              
88 38 50       277 if( $self->{'_dirs_visited'}{$start_in} ) {
89 0 0       0 $verbose and print "Directory '$start_in' already seen, skipping.\n";
90 0         0 next;
91             } else {
92 38         238 $self->{'_dirs_visited'}{$start_in} = 1;
93             }
94            
95 38 50       819 unless(-e $start_in) {
96 0 0       0 $verbose and print "Skipping non-existent $start_in\n";
97 0         0 next;
98             }
99              
100 38         361 my $closure = $self->_make_search_callback;
101            
102 38 50       689 if(-d $start_in) {
    0          
103             # Normal case:
104 38 50       175 $verbose and print "Beginning excursion under $start_in\n";
105 38         256 $self->_recurse_dir( $start_in, $closure, $modname_prefix );
106 38 50       952 $verbose and print "Back from excursion under $start_in\n\n";
107            
108             } elsif(-f _) {
109             # A excursion consisting of just one file!
110 0         0 $_ = basename($start_in);
111 0 0       0 $verbose and print "Pondering $start_in ($_)\n";
112 0         0 $closure->($start_in, $_, 0, []);
113            
114             } else {
115 0 0       0 $verbose and print "Skipping mysterious $start_in\n";
116             }
117             }
118 15 50       207 $self->progress and $self->progress->done(
119             "Noted $$self{'_scan_count'} Pod files total");
120 15         276 $self->ciseen( {} );
121              
122 15 100       177 return unless defined wantarray; # void
123 14 50       44 return $self->name2path unless wantarray; # scalar
124 14         41 return $self->name2path, $self->path2name; # list
125             }
126              
127             #==========================================================================
128             sub _make_search_callback {
129 38     38   136 my $self = $_[0];
130              
131             # Put the options in variables, for easy access
132 38         321 my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,
133             $path2name, $name2path, $recurse, $ciseen, $is_case_insensitive) =
134             map scalar($self->$_()),
135             qw(laborious verbose shadows limit_re callback progress
136             path2name name2path recurse ciseen is_case_insensitive);
137 38         116 my ($seen, $remember, $files_for);
138 38 50       136 if ($is_case_insensitive) {
139 0     0   0 $seen = sub { $ciseen->{ lc $_[0] } };
  0         0  
140 0     0   0 $remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; };
  0         0  
141 0     0   0 $files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } };
  0         0  
  0         0  
  0         0  
  0         0  
142             } else {
143 38     3197   489 $seen = sub { $name2path->{ $_[0] } };
  3197         9961  
144 38     1198   296 $remember = sub { $name2path->{ $_[0] } = $_[1] };
  1198         4513  
145 38     0   263 $files_for = sub { my $n = $_[0]; grep { $path2name->{$_} eq $n } %{ $path2name } };
  0         0  
  0         0  
  0         0  
  0         0  
146             }
147              
148 38         121 my($file, $shortname, $isdir, $modname_bits);
149             return sub {
150 4832     4832   11128 ($file, $shortname, $isdir, $modname_bits) = @_;
151              
152 4832 100       9838 if($isdir) { # this never gets called on the startdir itself, just subdirs
153              
154 686 100       1487 unless( $recurse ) {
155 16 50       87 $verbose and print "Not recursing into '$file' as per requested.\n";
156 16         63 return 'PRUNE';
157             }
158              
159 670 100       1955 if( $self->{'_dirs_visited'}{$file} ) {
160 4 50       15 $verbose and print "Directory '$file' already seen, skipping.\n";
161 4         15 return 'PRUNE';
162             }
163              
164 666 50       1268 print "Looking in dir $file\n" if $verbose;
165              
166 666 50       1339 unless ($laborious) { # $laborious overrides pruning
167 666 0 33     1862 if( m/^(\d+\.[\d_]{3,})\z/s
168 0         0 and do { my $x = $1; $x =~ tr/_//d; $x != $] }
  0         0  
  0         0  
169             ) {
170 0 0       0 $verbose and print "Perl $] version mismatch on $_, skipping.\n";
171 0         0 return 'PRUNE';
172             }
173              
174 666 100       3105 if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
175 608 50       1204 $verbose and print "$_ is a well-named module subdir. Looking....\n";
176             } else {
177 58 50       116 $verbose and print "$_ is a fishy directory name. Skipping.\n";
178 58         139 return 'PRUNE';
179             }
180             } # end unless $laborious
181              
182 608         1827 $self->{'_dirs_visited'}{$file} = 1;
183 608         2265 return; # (not pruning);
184             }
185              
186             # Make sure it's a file even worth even considering
187 4146 50       6772 if($laborious) {
188 0 0 0     0 unless(
      0        
189             m/\.(pod|pm|plx?)\z/i || -x _ and -T _
190             # Note that the cheapest operation (the RE) is run first.
191             ) {
192 0 0       0 $verbose > 1 and print " Brushing off uninteresting $file\n";
193 0         0 return;
194             }
195             } else {
196 4146 100       21134 unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
197 2052 50       4118 $verbose > 1 and print " Brushing off oddly-named $file\n";
198 2052         4168 return;
199             }
200             }
201              
202 2094 50       4515 $verbose and print "Considering item $file\n";
203 2094         5628 my $name = $self->_path2modname( $file, $shortname, $modname_bits );
204 2094 50       4613 $verbose > 0.01 and print " Nominating $file as $name\n";
205            
206 2094 100 100     4667 if($limit_re and $name !~ m/$limit_re/i) {
207 62 50       132 $verbose and print "Shunning $name as not matching $limit_re\n";
208 62         109 return;
209             }
210              
211 2032 100 100     5072 if( !$shadows and $seen->($name) ) {
212 75 50       151 $verbose and print "Not worth considering $file ",
213             "-- already saw $name as ",
214             join(' ', $files_for->($name)), "\n";
215 75         195 return;
216             }
217              
218             # Put off until as late as possible the expense of
219             # actually reading the file:
220 1957 50       3702 $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
221 1957 100       4213 return unless $self->contains_pod( $file );
222 1208         2923 ++ $self->{'_scan_count'};
223              
224             # Or finally take note of it:
225 1208 100       2581 if ( my $prev = $seen->($name) ) {
226 10 50       24 $verbose and print
227             "Duplicate POD found (shadowing?): $name ($file)\n",
228             " Already seen in ", join(' ', $files_for->($name)), "\n";
229             } else {
230 1198         2447 $remember->($name, $file); # Noting just the first occurrence
231             }
232 1208 50       2496 $verbose and print " Noting $name = $file\n";
233 1208 100       2359 if( $callback ) {
234 1131         1875 local $_ = $_; # insulate from changes, just in case
235 1131         3133 $callback->($file, $name);
236             }
237 1208         7706 $path2name->{$file} = $name;
238 1208         2856 return;
239             }
240 38         614 }
241              
242             #==========================================================================
243              
244             sub _path2modname {
245 2094     2094   4103 my($self, $file, $shortname, $modname_bits) = @_;
246              
247             # this code simplifies the POD name for Perl modules:
248             # * remove "site_perl"
249             # * remove e.g. "i586-linux" (from 'archname')
250             # * remove e.g. 5.00503
251             # * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
252             # * dig into the file for case-preserved name if not already mixed case
253              
254 2094         5201 my @m = @$modname_bits;
255 2094         3281 my $x;
256 2094         4327 my $verbose = $self->verbose;
257              
258             # Shaving off leading naughty-bits
259 2094   66     29558 while(@m
      66        
      66        
260             and defined($x = lc( $m[0] ))
261             and( $x eq 'site_perl'
262             or($x =~ m/^pods?$/ and @m == 1 and $shortname =~ m{^perl.*\.pod$}s )
263             or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum
264             or $x eq lc( $Config::Config{'archname'} )
265 228         739 )) { shift @m }
266              
267 2094         7699 my $name = join '::', @m, $shortname;
268 2094         5385 $self->_simplify_base($name);
269              
270             # On VMS, case-preserved document names can't be constructed from
271             # filenames, so try to extract them from the "=head1 NAME" tag in the
272             # file instead.
273 2094 0 0     4224 if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
      33        
274 0 0       0 open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
275 0         0 my $in_pod = 0;
276 0         0 my $in_name = 0;
277 0         0 my $line;
278 0         0 while ($line = ) {
279 0         0 chomp $line;
280 0 0       0 $in_pod = 1 if ($line =~ m/^=\w/);
281 0 0       0 $in_pod = 0 if ($line =~ m/^=cut/);
282 0 0       0 next unless $in_pod; # skip non-pod text
283 0 0       0 next if ($line =~ m/^\s*\z/); # and blank lines
284 0 0 0     0 next if ($in_pod && ($line =~ m/^X
285 0 0       0 if ($in_name) {
286 0 0       0 if ($line =~ m/(\w+::)?(\w+)/) {
287             # substitute case-preserved version of name
288 0         0 my $podname = $2;
289 0   0     0 my $prefix = $1 || '';
290 0 0       0 $verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
291 0 0       0 unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
292 0 0       0 $verbose and print "Attempting case restore of '$name' from '$podname'\n";
293 0         0 $name =~ s/$podname/$podname/i;
294             }
295 0         0 last;
296             }
297             }
298 0 0       0 $in_name = 1 if ($line =~ m/^=head1 NAME/);
299             }
300 0         0 close PODFILE;
301             }
302              
303 2094         5061 return $name;
304             }
305              
306             #==========================================================================
307              
308             sub _recurse_dir {
309 38     38   150 my($self, $startdir, $callback, $modname_bits) = @_;
310              
311 38   50     402 my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
312 38         147 my $verbose = $self->verbose;
313              
314 38         506 my $here_string = File::Spec->curdir;
315 38         282 my $up_string = File::Spec->updir;
316 38   100     344 $modname_bits ||= [];
317              
318 38         60 my $recursor;
319             $recursor = sub {
320 646     646   1554 my($dir_long, $dir_bare) = @_;
321 646 50       1485 if( @$modname_bits >= 10 ) {
322 0 0       0 $verbose and print "Too deep! [@$modname_bits]\n";
323 0         0 return;
324             }
325              
326 646 50       9679 unless(-d $dir_long) {
327 0 0       0 $verbose > 2 and print "But it's not a dir! $dir_long\n";
328 0         0 return;
329             }
330 646 50       15709 unless( opendir(INDIR, $dir_long) ) {
331 0 0       0 $verbose > 2 and print "Can't opendir $dir_long : $!\n";
332 0         0 closedir(INDIR);
333             return
334 0         0 }
335              
336             # Load all items; put no extension before .pod before .pm before .plx?.
337 6124         10827 my @items = map { $_->[0] }
338 27388 50       47779 sort { $a->[1] cmp $b->[1] || $b->[2] cmp $a->[2] }
339             map {
340 646         17828 (my $t = $_) =~ s/[.]p(m|lx?|od)\z//;
  6124         16211  
341 6124   100     29811 [$_, $t, lc($1 || 'z') ]
342             } readdir(INDIR);
343 646         8950 closedir(INDIR);
344              
345 646 100       3452 push @$modname_bits, $dir_bare unless $dir_bare eq '';
346              
347 646         1017 my $i_full;
348 646         1381 foreach my $i (@items) {
349 6124 100 100     25446 next if $i eq $here_string or $i eq $up_string or $i eq '';
      66        
350 4832         43681 $i_full = File::Spec->catfile( $dir_long, $i );
351              
352 4832 50       155654 if(!-r $i_full) {
    100          
    50          
353 0 0       0 $verbose and print "Skipping unreadable $i_full\n";
354            
355             } elsif(-f $i_full) {
356 4146         13163 $_ = $i;
357 4146         9868 $callback->( $i_full, $i, 0, $modname_bits );
358              
359             } elsif(-d _) {
360 686 50       3294 $i =~ s/\.DIR\z//i if $^O eq 'VMS';
361 686         1679 $_ = $i;
362 686   100     1880 my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
363              
364 686 100       1491 if($rv eq 'PRUNE') {
365 78 50       238 $verbose > 1 and print "OK, pruning";
366             } else {
367             # Otherwise, recurse into it
368 608         4505 $recursor->( File::Spec->catdir($dir_long, $i) , $i);
369             }
370             } else {
371 0 0       0 $verbose > 1 and print "Skipping oddity $i_full\n";
372             }
373             }
374 646         1051 pop @$modname_bits;
375 646         2442 return;
376 38         370 };;
377              
378 38         114 local $_;
379 38         216 $recursor->($startdir, '');
380              
381 38         708 undef $recursor; # allow it to be GC'd
382              
383 38         98 return;
384             }
385              
386              
387             #==========================================================================
388              
389             sub run {
390             # A function, useful in one-liners
391              
392 0     0 0 0 my $self = __PACKAGE__->new;
393 0 0       0 $self->limit_glob($ARGV[0]) if @ARGV;
394             $self->callback( sub {
395 0     0   0 my($file, $name) = @_;
396 0         0 my $version = '';
397            
398             # Yes, I know we won't catch the version in like a File/Thing.pm
399             # if we see File/Thing.pod first. That's just the way the
400             # cookie crumbles. -- SMB
401            
402 0 0       0 if($file =~ m/\.pod$/i) {
    0          
403             # Don't bother looking for $VERSION in .pod files
404 0         0 DEBUG and print "Not looking for \$VERSION in .pod $file\n";
405             } elsif( !open(INPOD, $file) ) {
406 0         0 DEBUG and print "Couldn't open $file: $!\n";
407 0         0 close(INPOD);
408             } else {
409             # Sane case: file is readable
410 0         0 my $lines = 0;
411 0         0 while() {
412 0 0       0 last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
413 0 0 0     0 if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
414 0         0 DEBUG and print "Found version line (#$lines): $_";
415 0         0 s/\s*\#.*//s;
416 0         0 s/\;\s*$//s;
417 0         0 s/\s+$//s;
418 0         0 s/\t+/ /s; # nix tabs
419             # Optimize the most common cases:
420 0 0 0     0 $_ = "v$1"
421             if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
422             # like in $VERSION = "3.14159";
423             or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
424             # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
425             ;
426            
427             # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
428             $_ = sprintf("v%d.%s",
429 0 0       0 map {s/_//g; $_}
  0         0  
  0         0  
430             $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
431             if m{\$Name:\s*([^\$]+)\$}s
432             ;
433 0         0 $version = $_;
434 0         0 DEBUG and print "Noting $version as version\n";
435 0         0 last;
436             }
437             }
438 0         0 close(INPOD);
439             }
440 0         0 print "$name\t$version\t$file\n";
441 0         0 return;
442             # End of callback!
443 0         0 });
444              
445 0         0 $self->survey;
446             }
447              
448             #==========================================================================
449              
450             sub simplify_name {
451 0     0 1 0 my($self, $str) = @_;
452            
453             # Remove all path components
454             # XXX Why not just use basename()? -- SMB
455              
456 0 0       0 if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
  0         0  
457 0         0 else { $str =~ s{^.*/+}{}s }
458            
459 0         0 $self->_simplify_base($str);
460 0         0 return $str;
461             }
462              
463             #==========================================================================
464              
465             sub _simplify_base { # Internal method only
466              
467             # strip Perl's own extensions
468 2094     2094   9196 $_[1] =~ s/\.(pod|pm|plx?)\z//i;
469              
470             # strip meaningless extensions on Win32 and OS/2
471 2094 50       9782 $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
472              
473             # strip meaningless extensions on VMS
474 2094 50       4663 $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
475              
476 2094         2873 return;
477             }
478              
479             #==========================================================================
480              
481             sub _expand_inc {
482 1130     1130   2330 my($self, $search_dirs) = @_;
483            
484 1130 100       2580 return unless $self->{'inc'};
485 1115         1671 my %seen = map { File::Spec->rel2abs($_) => 1 } @{ $search_dirs };
  0         0  
  1115         2257  
486              
487 1115 50       3846 if ($^O eq 'MacOS') {
488             push @$search_dirs,
489 0         0 grep { !$seen{ File::Spec->rel2abs($_) }++ } $self->_mac_whammy(@INC);
  0         0  
490             # Any other OSs need custom handling here?
491             } else {
492             push @$search_dirs,
493 1115         2484 grep { !$seen{ File::Spec->rel2abs($_) }++ } @INC;
  12265         93437  
494             }
495              
496 1115         3286 $self->{'laborious'} = 0; # Since inc said to use INC
497 1115         3193 return;
498             }
499              
500             #==========================================================================
501              
502             sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
503 0     0   0 my @them;
504 0         0 (undef,@them) = @_;
505 0         0 for $_ (@them) {
506 0 0       0 if ( $_ eq '.' ) {
    0          
507 0         0 $_ = ':';
508 0         0 } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
509 0         0 $_ = ':'. $_;
510             } else {
511 0         0 $_ =~ s|^\./|:|;
512             }
513             }
514 0         0 return @them;
515             }
516              
517             #==========================================================================
518              
519             sub _limit_glob_to_limit_re {
520 5     5   19 my $self = $_[0];
521 5   50     55 my $limit_glob = $self->{'limit_glob'} || return;
522              
523 5         32 my $limit_re = '^' . quotemeta($limit_glob) . '$';
524 5         52 $limit_re =~ s/\\\?/./g; # glob "?" => "."
525 5         43 $limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?"
526 5         39 $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
527              
528 5 50       31 $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
529              
530             # A common optimization:
531 5 100 66     84 if(!exists($self->{'dir_prefix'})
532             and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*"
533             # Optimize for sane and common cases (but not things like "*::File")
534             ) {
535 1         15 $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
536 1 50       10 $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
537             }
538              
539 5         47 return $limit_re;
540             }
541              
542             #==========================================================================
543              
544             # contribution mostly from Tim Jenness
545              
546             sub _actual_filenames {
547 18012     18012   43160 my $dir = shift;
548 18012         30005 my $fn = lc shift;
549 18012 50       448493 opendir my ($dh), $dir or return;
550 2369         50106 return map { File::Spec->catdir($dir, $_) }
551 18012         649005 grep { lc $_ eq $fn } readdir $dh;
  319484         760896  
552             }
553              
554             sub find {
555 1115     1115 1 696816 my($self, $pod, @search_dirs) = @_;
556 1115 50       3988 $self = $self->new unless ref $self; # tolerate being a class method
557              
558             # Check usage
559 1115 50 33     5145 Carp::carp 'Usage: \$self->find($podname, ...)'
560             unless defined $pod and length $pod;
561              
562 1115         2666 my $verbose = $self->verbose;
563              
564             # Split on :: and then join the name together using File::Spec
565 1115         4267 my @parts = split /::/, $pod;
566 1115 50       2661 $verbose and print "Chomping {$pod} => {@parts}\n";
567              
568             #@search_dirs = File::Spec->curdir unless @search_dirs;
569            
570 1115         3755 $self->_expand_inc(\@search_dirs);
571             # Add location of binaries such as pod2text:
572 1115 100       3168 push @search_dirs, $Config::Config{'scriptdir'} if $self->inc;
573              
574 1115         2737 my %seen_dir;
575 1115         2786 while (my $dir = shift @search_dirs ) {
576 10121 50 33     44117 next unless defined $dir and length $dir;
577 10121 50       23344 next if $seen_dir{$dir};
578 10121         18163 $seen_dir{$dir} = 1;
579 10121 50       145721 unless(-d $dir) {
580 0 0       0 print "Directory $dir does not exist\n" if $verbose;
581             }
582              
583 10121 50       29477 print "Looking in directory $dir\n" if $verbose;
584 10121         119937 my $fullname = File::Spec->catfile( $dir, @parts );
585 10121 50       27957 print "Filename is now $fullname\n" if $verbose;
586              
587 10121         18157 foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions
588 39071         99423 my $fullext = $fullname . $ext;
589 39071 100 100     478888 if ( -f $fullext and $self->contains_pod($fullext) ) {
590 1115 50       2338 print "FOUND: $fullext\n" if $verbose;
591 1115 50 100     5575 if (@parts > 1 && lc $parts[0] eq 'pod' && $self->is_case_insensitive() && $ext eq '.pod') {
      66        
      33        
592             # Well, this file could be for a program (perldoc) but we actually
593             # want a module (Pod::Perldoc). So see if there is a .pm with the
594             # proper casing.
595 0         0 my $subdir = dirname $fullext;
596 0 0       0 unless (grep { $fullext eq $_ } _actual_filenames $subdir, "$parts[-1].pod") {
  0         0  
597 0 0       0 print "# Looking for alternate spelling in $subdir\n" if $verbose;
598             # Try the .pm file.
599 0         0 my $pm = $fullname . '.pm';
600 0 0 0     0 if ( -f $pm and $self->contains_pod($pm) ) {
601             # Prefer the .pm if its case matches.
602 0 0       0 if (grep { $pm eq $_ } _actual_filenames $subdir, "$parts[-1].pm") {
  0         0  
603 0 0       0 print "FOUND: $fullext\n" if $verbose;
604 0         0 return $pm;
605             }
606             }
607             }
608             }
609 1115         7141 return $fullext;
610             }
611             }
612              
613             # Case-insensitively Look for ./pod directories and slip them in.
614 9006         29202 for my $subdir ( _actual_filenames($dir, 'pods'), _actual_filenames($dir, 'pod') ) {
615 2369 50       37723 if (-d $subdir) {
616 2369 50       6591 $verbose and print "Noticing $subdir and looking there...\n";
617 2369         17778 unshift @search_dirs, $subdir;
618             }
619             }
620             }
621              
622 0         0 return undef;
623             }
624              
625             #==========================================================================
626              
627             sub contains_pod {
628 3073     3073 1 7359 my($self, $file) = @_;
629 3073         5351 my $verbose = $self->{'verbose'};
630              
631             # check for one line of POD
632 3073 50       5879 $verbose > 1 and print " Scanning $file for pod...\n";
633 3073 50       99537 unless( open(MAYBEPOD,"<$file") ) {
634 0         0 print "Error: $file is unreadable: $!\n";
635 0         0 return undef;
636             }
637              
638 3073 50       13089 sleep($SLEEPY - 1) if $SLEEPY;
639             # avoid totally hogging the processor on OSs with poor process control
640            
641 3073         5507 local $_;
642 3073         51371 while( ) {
643 823842 100       1690023 if(m/^=(head\d|pod|over|item)\b/s) {
644 2323 50       31279 close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
645 2323         8160 chomp;
646 2323 50       5231 $verbose > 1 and print " Found some pod ($_) in $file\n";
647 2323         10863 return 1;
648             }
649             }
650 750 50       7539 close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
651 750 50       2027 $verbose > 1 and print " No POD in $file, skipping.\n";
652 750         3739 return 0;
653             }
654              
655             #==========================================================================
656              
657             sub _accessorize { # A simple-minded method-maker
658 14     14   28 shift;
659 14     14   160 no strict 'refs';
  14         29  
  14         928  
660 14         32 foreach my $attrname (@_) {
661 196         686 *{caller() . '::' . $attrname} = sub {
662 14     14   82 use strict;
  14         29  
  14         5106  
663 5044 50 66 5044   29880 $Carp::CarpLevel = 1, Carp::croak(
      33        
664             "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
665             ) unless (@_ == 1 or @_ == 2) and ref $_[0];
666              
667             # Read access:
668 5044 100       23887 return $_[0]->{$attrname} if @_ == 1;
669              
670             # Write access:
671 147         490 $_[0]->{$attrname} = $_[1];
672 147         217 return $_[0]; # RETURNS MYSELF!
673 196         497 };
674             }
675             # Ya know, they say accessories make the ensemble!
676 14         31 return;
677             }
678              
679             #==========================================================================
680             sub _state_as_string {
681 11     11   35727 my $self = $_[0];
682 11 50       202 return '' unless ref $self;
683 11         133 my @out = "{\n # State of $self ...\n";
684 11         305 foreach my $k (sort keys %$self) {
685 51         256 push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n";
686             }
687 11         65 push @out, "}\n";
688 11         99 my $x = join '', @out;
689 11         240 $x =~ s/^/#/mg;
690 11         409 return $x;
691             }
692              
693             sub _esc {
694 102     102   233 my $in = $_[0];
695 102 100       394 return 'undef' unless defined $in;
696 91         268 $in =~
697 2         11 s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
698 91         561 <'\\x'.(unpack("H2",$1))>eg;
699             return qq{"$in"};
700             }
701              
702             #==========================================================================
703              
704             run() unless caller; # run if "perl whatever/Search.pm"
705              
706             1;
707              
708             #==========================================================================
709              
710             __END__