[Summary view] [Print] [Text view]

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