1require 5.005;
2package Pod::Simple::Search;
3use strict;
4
5use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
6$VERSION = '3.43';   ## Current version of this package
7
8BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; }   # set DEBUG level
9use Carp ();
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;
19use File::Spec ();
20use File::Basename qw( basename dirname );
21use Config ();
22use Cwd qw( cwd );
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
32sub new {
33  my $class = shift;
34  my $self = bless {}, ref($class) || $class;
35  $self->init;
36  return $self;
37}
38
39sub init {
40  my $self = shift;
41  $self->inc(1);
42  $self->recurse(1);
43  $self->verbose(DEBUG);
44  $self->is_case_insensitive(-e uc __FILE__ && -e lc __FILE__);
45  return $self;
46}
47
48#--------------------------------------------------------------------------
49
50sub survey {
51  my($self, @search_dirs) = @_;
52  $self = $self->new unless ref $self; # tolerate being a class method
53
54  $self->_expand_inc( \@search_dirs );
55
56  $self->{'_scan_count'} = 0;
57  $self->{'_dirs_visited'} = {};
58  $self->path2name( {} );
59  $self->name2path( {} );
60  $self->ciseen( {} );
61  $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
62  my $cwd = cwd();
63  my $verbose  = $self->verbose;
64  local $_; # don't clobber the caller's $_ !
65
66  foreach my $try (@search_dirs) {
67    unless( File::Spec->file_name_is_absolute($try) ) {
68      # make path absolute
69      $try = File::Spec->catfile( $cwd ,$try);
70    }
71    # simplify path
72    $try =  File::Spec->canonpath($try);
73
74    my $start_in;
75    my $modname_prefix;
76    if($self->{'dir_prefix'}) {
77      $start_in = File::Spec->catdir(
78        $try,
79        grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
80      );
81      $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
82      $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
83        "giving $start_in (= @$modname_prefix)\n";
84    } else {
85      $start_in = $try;
86    }
87
88    if( $self->{'_dirs_visited'}{$start_in} ) {
89      $verbose and print "Directory '$start_in' already seen, skipping.\n";
90      next;
91    } else {
92      $self->{'_dirs_visited'}{$start_in} = 1;
93    }
94
95    unless(-e $start_in) {
96      $verbose and print "Skipping non-existent $start_in\n";
97      next;
98    }
99
100    my $closure = $self->_make_search_callback;
101
102    if(-d $start_in) {
103      # Normal case:
104      $verbose and print "Beginning excursion under $start_in\n";
105      $self->_recurse_dir( $start_in, $closure, $modname_prefix );
106      $verbose and print "Back from excursion under $start_in\n\n";
107
108    } elsif(-f _) {
109      # A excursion consisting of just one file!
110      $_ = basename($start_in);
111      $verbose and print "Pondering $start_in ($_)\n";
112      $closure->($start_in, $_, 0, []);
113
114    } else {
115      $verbose and print "Skipping mysterious $start_in\n";
116    }
117  }
118  $self->progress and $self->progress->done(
119   "Noted $$self{'_scan_count'} Pod files total");
120  $self->ciseen( {} );
121
122  return unless defined wantarray; # void
123  return $self->name2path unless wantarray; # scalar
124  return $self->name2path, $self->path2name; # list
125}
126
127#==========================================================================
128sub _make_search_callback {
129  my $self = $_[0];
130
131  # Put the options in variables, for easy access
132  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  my ($seen, $remember, $files_for);
138  if ($is_case_insensitive) {
139      $seen      = sub { $ciseen->{ lc $_[0] } };
140      $remember  = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; };
141      $files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } };
142  } else {
143      $seen      = sub { $name2path->{ $_[0] } };
144      $remember  = sub { $name2path->{ $_[0] } = $_[1] };
145      $files_for = sub { my $n = $_[0]; grep { $path2name->{$_} eq $n } %{ $path2name } };
146  }
147
148  my($file, $shortname, $isdir, $modname_bits);
149  return sub {
150    ($file, $shortname, $isdir, $modname_bits) = @_;
151
152    if($isdir) { # this never gets called on the startdir itself, just subdirs
153
154      unless( $recurse ) {
155        $verbose and print "Not recursing into '$file' as per requested.\n";
156        return 'PRUNE';
157      }
158
159      if( $self->{'_dirs_visited'}{$file} ) {
160        $verbose and print "Directory '$file' already seen, skipping.\n";
161        return 'PRUNE';
162      }
163
164      print "Looking in dir $file\n" if $verbose;
165
166      unless ($laborious) { # $laborious overrides pruning
167        if( m/^(\d+\.[\d_]{3,})\z/s
168             and do { my $x = $1; $x =~ tr/_//d; $x != $] }
169           ) {
170          $verbose and print "Perl $] version mismatch on $_, skipping.\n";
171          return 'PRUNE';
172        }
173
174        if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
175          $verbose and print "$_ is a well-named module subdir.  Looking....\n";
176        } else {
177          $verbose and print "$_ is a fishy directory name.  Skipping.\n";
178          return 'PRUNE';
179        }
180      } # end unless $laborious
181
182      $self->{'_dirs_visited'}{$file} = 1;
183      return; # (not pruning);
184    }
185
186    # Make sure it's a file even worth even considering
187    if($laborious) {
188      unless(
189        m/\.(pod|pm|plx?)\z/i || -x _ and -T _
190         # Note that the cheapest operation (the RE) is run first.
191      ) {
192        $verbose > 1 and print " Brushing off uninteresting $file\n";
193        return;
194      }
195    } else {
196      unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
197        $verbose > 1 and print " Brushing off oddly-named $file\n";
198        return;
199      }
200    }
201
202    $verbose and print "Considering item $file\n";
203    my $name = $self->_path2modname( $file, $shortname, $modname_bits );
204    $verbose > 0.01 and print " Nominating $file as $name\n";
205
206    if($limit_re and $name !~ m/$limit_re/i) {
207      $verbose and print "Shunning $name as not matching $limit_re\n";
208      return;
209    }
210
211    if( !$shadows and $seen->($name) ) {
212      $verbose and print "Not worth considering $file ",
213        "-- already saw $name as ",
214        join(' ', $files_for->($name)), "\n";
215      return;
216    }
217
218    # Put off until as late as possible the expense of
219    #  actually reading the file:
220    $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
221    return unless $self->contains_pod( $file );
222    ++ $self->{'_scan_count'};
223
224    # Or finally take note of it:
225    if ( my $prev = $seen->($name)  ) {
226      $verbose and print
227       "Duplicate POD found (shadowing?): $name ($file)\n",
228       "    Already seen in ", join(' ', $files_for->($name)), "\n";
229    } else {
230      $remember->($name, $file); # Noting just the first occurrence
231    }
232    $verbose and print "  Noting $name = $file\n";
233    if( $callback ) {
234      local $_ = $_; # insulate from changes, just in case
235      $callback->($file, $name);
236    }
237    $path2name->{$file} = $name;
238    return;
239  }
240}
241
242#==========================================================================
243
244sub _path2modname {
245  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  my @m = @$modname_bits;
255  my $x;
256  my $verbose = $self->verbose;
257
258  # Shaving off leading naughty-bits
259  while(@m
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  )) { shift @m }
266
267  my $name = join '::', @m, $shortname;
268  $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  if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
274      open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
275      my $in_pod = 0;
276      my $in_name = 0;
277      my $line;
278      while ($line = <PODFILE>) {
279        chomp $line;
280        $in_pod = 1 if ($line =~ m/^=\w/);
281        $in_pod = 0 if ($line =~ m/^=cut/);
282        next unless $in_pod;         # skip non-pod text
283        next if ($line =~ m/^\s*\z/);           # and blank lines
284        next if ($in_pod && ($line =~ m/^X</)); # and commands
285        if ($in_name) {
286          if ($line =~ m/(\w+::)?(\w+)/) {
287            # substitute case-preserved version of name
288            my $podname = $2;
289            my $prefix = $1 || '';
290            $verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
291            unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
292              $verbose and print "Attempting case restore of '$name' from '$podname'\n";
293              $name =~ s/$podname/$podname/i;
294            }
295            last;
296          }
297        }
298        $in_name = 1 if ($line =~ m/^=head1 NAME/);
299    }
300    close PODFILE;
301  }
302
303  return $name;
304}
305
306#==========================================================================
307
308sub _recurse_dir {
309  my($self, $startdir, $callback, $modname_bits) = @_;
310
311  my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
312  my $verbose = $self->verbose;
313
314  my $here_string = File::Spec->curdir;
315  my $up_string   = File::Spec->updir;
316  $modname_bits ||= [];
317
318  my $recursor;
319  $recursor = sub {
320    my($dir_long, $dir_bare) = @_;
321    if( @$modname_bits >= 10 ) {
322      $verbose and print "Too deep! [@$modname_bits]\n";
323      return;
324    }
325
326    unless(-d $dir_long) {
327      $verbose > 2 and print "But it's not a dir! $dir_long\n";
328      return;
329    }
330    unless( opendir(INDIR, $dir_long) ) {
331      $verbose > 2 and print "Can't opendir $dir_long : $!\n";
332      closedir(INDIR);
333      return
334    }
335
336    # Load all items; put no extension before .pod before .pm before .plx?.
337    my @items = map { $_->[0] }
338      sort { $a->[1] cmp $b->[1] || $b->[2] cmp $a->[2] }
339      map {
340        (my $t = $_) =~ s/[.]p(m|lx?|od)\z//;
341        [$_, $t, lc($1 || 'z') ]
342      } readdir(INDIR);
343    closedir(INDIR);
344
345    push @$modname_bits, $dir_bare unless $dir_bare eq '';
346
347    my $i_full;
348    foreach my $i (@items) {
349      next if $i eq $here_string or $i eq $up_string or $i eq '';
350      $i_full = File::Spec->catfile( $dir_long, $i );
351
352      if(!-r $i_full) {
353        $verbose and print "Skipping unreadable $i_full\n";
354
355      } elsif(-f $i_full) {
356        $_ = $i;
357        $callback->(          $i_full, $i, 0, $modname_bits );
358
359      } elsif(-d _) {
360        $i =~ s/\.DIR\z//i if $^O eq 'VMS';
361        $_ = $i;
362        my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
363
364        if($rv eq 'PRUNE') {
365          $verbose > 1 and print "OK, pruning";
366        } else {
367          # Otherwise, recurse into it
368          $recursor->( File::Spec->catdir($dir_long, $i) , $i);
369        }
370      } else {
371        $verbose > 1 and print "Skipping oddity $i_full\n";
372      }
373    }
374    pop @$modname_bits;
375    return;
376  };;
377
378  local $_;
379  $recursor->($startdir, '');
380
381  undef $recursor;  # allow it to be GC'd
382
383  return;
384}
385
386
387#==========================================================================
388
389sub run {
390  # A function, useful in one-liners
391
392  my $self = __PACKAGE__->new;
393  $self->limit_glob($ARGV[0]) if @ARGV;
394  $self->callback( sub {
395    my($file, $name) = @_;
396    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    if($file =~ m/\.pod$/i) {
403      # Don't bother looking for $VERSION in .pod files
404      DEBUG and print "Not looking for \$VERSION in .pod $file\n";
405    } elsif( !open(INPOD, $file) ) {
406      DEBUG and print "Couldn't open $file: $!\n";
407      close(INPOD);
408    } else {
409      # Sane case: file is readable
410      my $lines = 0;
411      while(<INPOD>) {
412        last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
413        if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
414          DEBUG and print "Found version line (#$lines): $_";
415          s/\s*\#.*//s;
416          s/\;\s*$//s;
417          s/\s+$//s;
418          s/\t+/ /s; # nix tabs
419          # Optimize the most common cases:
420          $_ = "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            map {s/_//g; $_}
430              $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
431           if m{\$Name:\s*([^\$]+)\$}s
432          ;
433          $version = $_;
434          DEBUG and print "Noting $version as version\n";
435          last;
436        }
437      }
438      close(INPOD);
439    }
440    print "$name\t$version\t$file\n";
441    return;
442    # End of callback!
443  });
444
445  $self->survey;
446}
447
448#==========================================================================
449
450sub simplify_name {
451  my($self, $str) = @_;
452
453  # Remove all path components
454  #                             XXX Why not just use basename()? -- SMB
455
456  if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
457  else                { $str =~ s{^.*/+}{}s }
458
459  $self->_simplify_base($str);
460  return $str;
461}
462
463#==========================================================================
464
465sub _simplify_base {   # Internal method only
466
467  # strip Perl's own extensions
468  $_[1] =~ s/\.(pod|pm|plx?)\z//i;
469
470  # strip meaningless extensions on Win32 and OS/2
471  $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
472
473  # strip meaningless extensions on VMS
474  $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
475
476  return;
477}
478
479#==========================================================================
480
481sub _expand_inc {
482  my($self, $search_dirs) = @_;
483
484  return unless $self->{'inc'};
485  my %seen = map { File::Spec->rel2abs($_) => 1 } @{ $search_dirs };
486
487  if ($^O eq 'MacOS') {
488    push @$search_dirs,
489      grep { !$seen{ File::Spec->rel2abs($_) }++ } $self->_mac_whammy(@INC);
490  # Any other OSs need custom handling here?
491  } else {
492    push @$search_dirs,
493      grep { !$seen{ File::Spec->rel2abs($_) }++ } @INC;
494  }
495
496  $self->{'laborious'} = 0;   # Since inc said to use INC
497  return;
498}
499
500#==========================================================================
501
502sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
503  my @them;
504  (undef,@them) = @_;
505  for $_ (@them) {
506    if ( $_ eq '.' ) {
507      $_ = ':';
508    } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
509      $_ = ':'. $_;
510    } else {
511      $_ =~ s|^\./|:|;
512    }
513  }
514  return @them;
515}
516
517#==========================================================================
518
519sub _limit_glob_to_limit_re {
520  my $self = $_[0];
521  my $limit_glob = $self->{'limit_glob'} || return;
522
523  my $limit_re = '^' . quotemeta($limit_glob) . '$';
524  $limit_re =~ s/\\\?/./g;    # glob "?" => "."
525  $limit_re =~ s/\\\*/.*?/g;  # glob "*" => ".*?"
526  $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
527
528  $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
529
530  # A common optimization:
531  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    $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
536    $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
537  }
538
539  return $limit_re;
540}
541
542#==========================================================================
543
544# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu>
545
546sub _actual_filenames {
547    my $dir = shift;
548    my $fn = lc shift;
549    opendir my ($dh), $dir or return;
550    return map { File::Spec->catdir($dir, $_) }
551        grep { lc $_  eq $fn } readdir $dh;
552}
553
554sub find {
555  my($self, $pod, @search_dirs) = @_;
556  $self = $self->new unless ref $self; # tolerate being a class method
557
558  # Check usage
559  Carp::carp 'Usage: \$self->find($podname, ...)'
560   unless defined $pod and length $pod;
561
562  my $verbose = $self->verbose;
563
564  # Split on :: and then join the name together using File::Spec
565  my @parts = split /::/, $pod;
566  $verbose and print "Chomping {$pod} => {@parts}\n";
567
568  #@search_dirs = File::Spec->curdir unless @search_dirs;
569
570  $self->_expand_inc(\@search_dirs);
571  # Add location of binaries such as pod2text:
572  push @search_dirs, $Config::Config{'scriptdir'} if $self->inc;
573
574  my %seen_dir;
575  while (my $dir = shift @search_dirs ) {
576    next unless defined $dir and length $dir;
577    next if $seen_dir{$dir};
578    $seen_dir{$dir} = 1;
579    unless(-d $dir) {
580      print "Directory $dir does not exist\n" if $verbose;
581    }
582
583    print "Looking in directory $dir\n" if $verbose;
584    my $fullname = File::Spec->catfile( $dir, @parts );
585    print "Filename is now $fullname\n" if $verbose;
586
587    foreach my $ext ('', '.pod', '.pm', '.pl') {   # possible extensions
588      my $fullext = $fullname . $ext;
589      if ( -f $fullext and $self->contains_pod($fullext) ) {
590        print "FOUND: $fullext\n" if $verbose;
591        if (@parts > 1 && lc $parts[0] eq 'pod' && $self->is_case_insensitive() && $ext eq '.pod') {
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          my $subdir = dirname $fullext;
596          unless (grep { $fullext eq $_  } _actual_filenames $subdir, "$parts[-1].pod") {
597            print "# Looking for alternate spelling in $subdir\n" if $verbose;
598            # Try the .pm file.
599            my $pm = $fullname . '.pm';
600            if ( -f $pm and $self->contains_pod($pm) ) {
601              # Prefer the .pm if its case matches.
602              if (grep { $pm eq $_  } _actual_filenames $subdir, "$parts[-1].pm") {
603                print "FOUND: $fullext\n" if $verbose;
604                return $pm;
605              }
606            }
607          }
608        }
609        return $fullext;
610      }
611    }
612
613    # Case-insensitively Look for ./pod directories and slip them in.
614    for my $subdir ( _actual_filenames($dir, 'pods'), _actual_filenames($dir, 'pod') ) {
615      if (-d $subdir) {
616        $verbose and print "Noticing $subdir and looking there...\n";
617        unshift @search_dirs, $subdir;
618      }
619    }
620  }
621
622  return undef;
623}
624
625#==========================================================================
626
627sub contains_pod {
628  my($self, $file) = @_;
629  my $verbose = $self->{'verbose'};
630
631  # check for one line of POD
632  $verbose > 1 and print " Scanning $file for pod...\n";
633  unless( open(MAYBEPOD,"<$file") ) {
634    print "Error: $file is unreadable: $!\n";
635    return undef;
636  }
637
638  sleep($SLEEPY - 1) if $SLEEPY;
639   # avoid totally hogging the processor on OSs with poor process control
640
641  local $_;
642  while( <MAYBEPOD> ) {
643    if(m/^=(head\d|pod|over|item)\b/s) {
644      close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
645      chomp;
646      $verbose > 1 and print "  Found some pod ($_) in $file\n";
647      return 1;
648    }
649  }
650  close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
651  $verbose > 1 and print "  No POD in $file, skipping.\n";
652  return 0;
653}
654
655#==========================================================================
656
657sub _accessorize {  # A simple-minded method-maker
658  shift;
659  no strict 'refs';
660  foreach my $attrname (@_) {
661    *{caller() . '::' . $attrname} = sub {
662      use strict;
663      $Carp::CarpLevel = 1,  Carp::croak(
664       "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
665      ) unless (@_ == 1 or @_ == 2) and ref $_[0];
666
667      # Read access:
668      return $_[0]->{$attrname} if @_ == 1;
669
670      # Write access:
671      $_[0]->{$attrname} = $_[1];
672      return $_[0]; # RETURNS MYSELF!
673    };
674  }
675  # Ya know, they say accessories make the ensemble!
676  return;
677}
678
679#==========================================================================
680sub _state_as_string {
681  my $self = $_[0];
682  return '' unless ref $self;
683  my @out = "{\n  # State of $self ...\n";
684  foreach my $k (sort keys %$self) {
685    push @out, "  ", _esc($k), " => ", _esc($self->{$k}), ",\n";
686  }
687  push @out, "}\n";
688  my $x = join '', @out;
689  $x =~ s/^/#/mg;
690  return $x;
691}
692
693sub _esc {
694  my $in = $_[0];
695  return 'undef' unless defined $in;
696  $in =~
697    s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
698     <'\\x'.(unpack("H2",$1))>eg;
699  return qq{"$in"};
700}
701
702#==========================================================================
703
704run() unless caller;  # run if "perl whatever/Search.pm"
705
7061;
707
708#==========================================================================
709
710__END__
711
712
713=head1 NAME
714
715Pod::Simple::Search - find POD documents in directory trees
716
717=head1 SYNOPSIS
718
719  use Pod::Simple::Search;
720  my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey;
721  print "Looky see what I found: ",
722    join(' ', sort keys %$name2path), "\n";
723
724  print "LWPUA docs = ",
725    Pod::Simple::Search->new->find('LWP::UserAgent') || "?",
726    "\n";
727
728=head1 DESCRIPTION
729
730B<Pod::Simple::Search> is a class that you use for running searches
731for Pod files.  An object of this class has several attributes
732(mostly options for controlling search options), and some methods
733for searching based on those attributes.
734
735The way to use this class is to make a new object of this class,
736set any options, and then call one of the search options
737(probably C<survey> or C<find>).  The sections below discuss the
738syntaxes for doing all that.
739
740
741=head1 CONSTRUCTOR
742
743This class provides the one constructor, called C<new>.
744It takes no parameters:
745
746  use Pod::Simple::Search;
747  my $search = Pod::Simple::Search->new;
748
749=head1 ACCESSORS
750
751This class defines several methods for setting (and, occasionally,
752reading) the contents of an object. With two exceptions (discussed at
753the end of this section), these attributes are just for controlling the
754way searches are carried out.
755
756Note that each of these return C<$self> when you call them as
757C<< $self->I<whatever(value)> >>.  That's so that you can chain
758together set-attribute calls like this:
759
760  my $name2path =
761    Pod::Simple::Search->new
762    -> inc(0) -> verbose(1) -> callback(\&blab)
763    ->survey(@there);
764
765...which works exactly as if you'd done this:
766
767  my $search = Pod::Simple::Search->new;
768  $search->inc(0);
769  $search->verbose(1);
770  $search->callback(\&blab);
771  my $name2path = $search->survey(@there);
772
773=over
774
775=item $search->inc( I<true-or-false> );
776
777This attribute, if set to a true value, means that searches should
778implicitly add perl's I<@INC> paths. This
779automatically considers paths specified in the C<PERL5LIB> environment
780as this is prepended to I<@INC> by the Perl interpreter itself.
781This attribute's default value is B<TRUE>.  If you want to search
782only specific directories, set $self->inc(0) before calling
783$inc->survey or $inc->find.
784
785
786=item $search->verbose( I<nonnegative-number> );
787
788This attribute, if set to a nonzero positive value, will make searches output
789(via C<warn>) notes about what they're doing as they do it.
790This option may be useful for debugging a pod-related module.
791This attribute's default value is zero, meaning that no C<warn> messages
792are produced.  (Setting verbose to 1 turns on some messages, and setting
793it to 2 turns on even more messages, i.e., makes the following search(es)
794even more verbose than 1 would make them.)
795
796=item $search->limit_glob( I<some-glob-string> );
797
798This option means that you want to limit the results just to items whose
799podnames match the given glob/wildcard expression. For example, you
800might limit your search to just "LWP::*", to search only for modules
801starting with "LWP::*" (but not including the module "LWP" itself); or
802you might limit your search to "LW*" to see only modules whose (full)
803names begin with "LW"; or you might search for "*Find*" to search for
804all modules with "Find" somewhere in their full name. (You can also use
805"?" in a glob expression; so "DB?" will match "DBI" and "DBD".)
806
807
808=item $search->callback( I<\&some_routine> );
809
810This attribute means that every time this search sees a matching
811Pod file, it should call this callback routine.  The routine is called
812with two parameters: the current file's filespec, and its pod name.
813(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would
814be in C<@_>.)
815
816The callback routine's return value is not used for anything.
817
818This attribute's default value is false, meaning that no callback
819is called.
820
821=item $search->laborious( I<true-or-false> );
822
823Unless you set this attribute to a true value, Pod::Search will
824apply Perl-specific heuristics to find the correct module PODs quickly.
825This attribute's default value is false.  You won't normally need
826to set this to true.
827
828Specifically: Turning on this option will disable the heuristics for
829seeing only files with Perl-like extensions, omitting subdirectories
830that are numeric but do I<not> match the current Perl interpreter's
831version ID, suppressing F<site_perl> as a module hierarchy name, etc.
832
833=item $search->recurse( I<true-or-false> );
834
835Unless you set this attribute to a false value, Pod::Search will
836recurse into subdirectories of the search directories.
837
838=item $search->shadows( I<true-or-false> );
839
840Unless you set this attribute to a true value, Pod::Simple::Search will
841consider only the first file of a given modulename as it looks thru the
842specified directories; that is, with this option off, if
843Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this
844search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm>
845later on in that search, because that file is merely a "shadow". But if
846you turn on C<< $self->shadows(1) >>, then these "shadow" files are
847inspected too, and are noted in the pathname2podname return hash.
848
849This attribute's default value is false; and normally you won't
850need to turn it on.
851
852=item $search->is_case_insensitive( I<true-or-false> );
853
854Pod::Simple::Search will by default internally make an assumption
855based on the underlying filesystem where the class file is found
856whether it is case insensitive or not.
857
858If it is determined to be case insensitive, during survey() it may
859skip pod files/modules that happen to be equal to names it's already
860seen, ignoring case.
861
862However, it's possible to have distinct files in different directories
863that intentionally has the same name, just differing in case, that should
864be reported. Hence, you may force the behavior by setting this to true
865or false.
866
867=item $search->limit_re( I<some-regxp> );
868
869Setting this attribute (to a value that's a regexp) means that you want
870to limit the results just to items whose podnames match the given
871regexp. Normally this option is not needed, and the more efficient
872C<limit_glob> attribute is used instead.
873
874=item $search->dir_prefix( I<some-string-value> );
875
876Setting this attribute to a string value means that the searches should
877begin in the specified subdirectory name (like "Pod" or "File::Find",
878also expressible as "File/Find"). For example, the search option
879C<< $search->limit_glob("File::Find::R*") >>
880is the same as the combination of the search options
881C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>.
882
883Normally you don't need to know about the C<dir_prefix> option, but I
884include it in case it might prove useful for someone somewhere.
885
886(Implementationally, searching with limit_glob ends up setting limit_re
887and usually dir_prefix.)
888
889
890=item $search->progress( I<some-progress-object> );
891
892If you set a value for this attribute, the value is expected
893to be an object (probably of a class that you define) that has a
894C<reach> method and a C<done> method.  This is meant for reporting
895progress during the search, if you don't want to use a simple
896callback.
897
898Normally you don't need to know about the C<progress> option, but I
899include it in case it might prove useful for someone somewhere.
900
901While a search is in progress, the progress object's C<reach> and
902C<done> methods are called like this:
903
904  # Every time a file is being scanned for pod:
905  $progress->reach($count, "Scanning $file");   ++$count;
906
907  # And then at the end of the search:
908  $progress->done("Noted $count Pod files total");
909
910Internally, we often set this to an object of class
911Pod::Simple::Progress.  That class is probably undocumented,
912but you may wish to look at its source.
913
914
915=item $name2path = $self->name2path;
916
917This attribute is not a search parameter, but is used to report the
918result of C<survey> method, as discussed in the next section.
919
920=item $path2name = $self->path2name;
921
922This attribute is not a search parameter, but is used to report the
923result of C<survey> method, as discussed in the next section.
924
925=back
926
927=head1 MAIN SEARCH METHODS
928
929Once you've actually set any options you want (if any), you can go
930ahead and use the following methods to search for Pod files
931in particular ways.
932
933
934=head2 C<< $search->survey( @directories ) >>
935
936The method C<survey> searches for POD documents in a given set of
937files and/or directories.  This runs the search according to the various
938options set by the accessors above.  (For example, if the C<inc> attribute
939is on, as it is by default, then the perl @INC directories are implicitly
940added to the list of directories (if any) that you specify.)
941
942The return value of C<survey> is two hashes:
943
944=over
945
946=item C<name2path>
947
948A hash that maps from each pod-name to the filespec (like
949"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm")
950
951=item C<path2name>
952
953A hash that maps from each Pod filespec to its pod-name (like
954"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing")
955
956=back
957
958Besides saving these hashes as the hashref attributes
959C<name2path> and C<path2name>, calling this function also returns
960these hashrefs.  In list context, the return value of
961C<< $search->survey >> is the list C<(\%name2path, \%path2name)>.
962In scalar context, the return value is C<\%name2path>.
963Or you can just call this in void context.
964
965Regardless of calling context, calling C<survey> saves
966its results in its C<name2path> and C<path2name> attributes.
967
968E.g., when searching in F<$HOME/perl5lib>, the file
969F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
970whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
971I<Myclass::Subclass>. The name information can be used for POD
972translators.
973
974Only text files containing at least one valid POD command are found.
975
976In verbose mode, a warning is printed if shadows are found (i.e., more
977than one POD file with the same POD name is found, e.g. F<CPAN.pm> in
978different directories).  This usually indicates duplicate occurrences of
979modules in the I<@INC> search path, which is occasionally inadvertent
980(but is often simply a case of a user's path dir having a more recent
981version than the system's general path dirs in general.)
982
983The options to this argument is a list of either directories that are
984searched recursively, or files.  (Usually you wouldn't specify files,
985but just dirs.)  Or you can just specify an empty-list, as in
986$name2path; with the C<inc> option on, as it is by default.
987
988The POD names of files are the plain basenames with any Perl-like
989extension (.pm, .pl, .pod) stripped, and path separators replaced by
990C<::>'s.
991
992Calling Pod::Simple::Search->search(...) is short for
993Pod::Simple::Search->new->search(...).  That is, a throwaway object
994with default attribute values is used.
995
996
997=head2 C<< $search->simplify_name( $str ) >>
998
999The method B<simplify_name> is equivalent to B<basename>, but also
1000strips Perl-like extensions (.pm, .pl, .pod) and extensions like
1001F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
1002
1003
1004=head2 C<< $search->find( $pod ) >>
1005
1006=head2 C<< $search->find( $pod, @search_dirs ) >>
1007
1008Returns the location of a Pod file, given a Pod/module/script name
1009(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of
1010what files/directories to look in.
1011It searches according to the various options set by the accessors above.
1012(For example, if the C<inc> attribute is on, as it is by default, then
1013the perl @INC directories are implicitly added to the list of
1014directories (if any) that you specify.)
1015
1016This returns the full path of the first occurrence to the file.
1017Package names (eg 'A::B') are automatically converted to directory
1018names in the selected directory.  Additionally, '.pm', '.pl' and '.pod'
1019are automatically appended to the search as required.
1020(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm",
1021"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.)
1022
1023If no such Pod file is found, this method returns undef.
1024
1025If any of the given search directories contains a F<pod/> subdirectory,
1026then it is searched.  (That's how we manage to find F<perlfunc>,
1027for example, which is usually in F<pod/perlfunc> in most Perl dists.)
1028
1029The C<verbose> and C<inc> attributes influence the behavior of this
1030search; notably, C<inc>, if true, adds @INC I<and also
1031$Config::Config{'scriptdir'}> to the list of directories to search.
1032
1033It is common to simply say C<< $filename = Pod::Simple::Search-> new
1034->find("perlvar") >> so that just the @INC (well, and scriptdir)
1035directories are searched.  (This happens because the C<inc>
1036attribute is true by default.)
1037
1038Calling Pod::Simple::Search->find(...) is short for
1039Pod::Simple::Search->new->find(...).  That is, a throwaway object
1040with default attribute values is used.
1041
1042
1043=head2 C<< $self->contains_pod( $file ) >>
1044
1045Returns true if the supplied filename (not POD module) contains some Pod
1046documentation.
1047
1048=head1 SUPPORT
1049
1050Questions or discussion about POD and Pod::Simple should be sent to the
1051pod-people@perl.org mail list. Send an empty email to
1052pod-people-subscribe@perl.org to subscribe.
1053
1054This module is managed in an open GitHub repository,
1055L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
1056to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
1057
1058Patches against Pod::Simple are welcome. Please send bug reports to
1059<bug-pod-simple@rt.cpan.org>.
1060
1061=head1 COPYRIGHT AND DISCLAIMERS
1062
1063Copyright (c) 2002 Sean M. Burke.
1064
1065This library is free software; you can redistribute it and/or modify it
1066under the same terms as Perl itself.
1067
1068This program is distributed in the hope that it will be useful, but
1069without any warranty; without even the implied warranty of
1070merchantability or fitness for a particular purpose.
1071
1072=head1 AUTHOR
1073
1074Pod::Simple was created by Sean M. Burke <sburke@cpan.org> with code borrowed
1075from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from
1076Nick Ing-Simmons' C<PodToHtml>.
1077
1078But don't bother him, he's retired.
1079
1080Pod::Simple is maintained by:
1081
1082=over
1083
1084=item * Allison Randal C<allison@perl.org>
1085
1086=item * Hans Dieter Pearcey C<hdp@cpan.org>
1087
1088=item * David E. Wheeler C<dwheeler@cpan.org>
1089
1090=back
1091
1092=cut
1093