search.pm

source of perl for linux application,

        $i =~ s/\.DIR\z//i if $^O eq 'VMS';
        $_ = $i;
        my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';

        if($rv eq 'PRUNE') {
          $verbose > 1 and print "OK, pruning";
        } else {
          # Otherwise, recurse into it
          $recursor->( File::Spec->catdir($dir_long, $i) , $i);
        }
      } else {
        $verbose > 1 and print "Skipping oddity $i_full\n";
      }
    }
    pop @$modname_bits;
    return;
  };;

  local $_;
  $recursor->($startdir, '');

  undef $recursor;  # allow it to be GC'd

  return;  
}


#==========================================================================

sub run {
  # A function, useful in one-liners

  my $self = __PACKAGE__->new;
  $self->limit_glob($ARGV[0]) if @ARGV;
  $self->callback( sub {
    my($file, $name) = @_;
    my $version = '';
     
    # Yes, I know we won't catch the version in like a File/Thing.pm
    #  if we see File/Thing.pod first.  That's just the way the
    #  cookie crumbles.  -- SMB
     
    if($file =~ m/\.pod$/i) {
      # Don't bother looking for $VERSION in .pod files
      DEBUG and print "Not looking for \$VERSION in .pod $file\n";
    } elsif( !open(INPOD, $file) ) {
      DEBUG and print "Couldn't open $file: $!\n";
      close(INPOD);
    } else {
      # Sane case: file is readable
      my $lines = 0;
      while(<INPOD>) {
        last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
        if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
          DEBUG and print "Found version line (#$lines): $_";
          s/\s*\#.*//s;
          s/\;\s*$//s;
          s/\s+$//s;
          s/\t+/ /s; # nix tabs
          # Optimize the most common cases:
          $_ = "v$1"
            if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
             # like in $VERSION = "3.14159";
             or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
             # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
          ;
           
          # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
          $_ = sprintf("v%d.%s",
            map {s/_//g; $_}
              $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
           if m{\$Name:\s*([^\$]+)\$}s 
          ;
          $version = $_;
          DEBUG and print "Noting $version as version\n";
          last;
        }
      }
      close(INPOD);
    }
    print "$name\t$version\t$file\n";
    return;
    # End of callback!
  });

  $self->survey;
}

#==========================================================================

sub simplify_name {
  my($self, $str) = @_;
    
  # Remove all path components
  #                             XXX Why not just use basename()? -- SMB

  if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
  else                { $str =~ s{^.*/+}{}s }
  
  $self->_simplify_base($str);
  return $str;
}

#==========================================================================

sub _simplify_base {   # Internal method only

  # strip Perl's own extensions
  $_[1] =~ s/\.(pod|pm|plx?)\z//i;

  # strip meaningless extensions on Win32 and OS/2
  $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;

  # strip meaningless extensions on VMS
  $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';

  return;
}

#==========================================================================

sub _expand_inc {
  my($self, $search_dirs) = @_;
  
  return unless $self->{'inc'};

  if ($^O eq 'MacOS') {
    push @$search_dirs,
      grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC);
  # Any other OSs need custom handling here?
  } else {
    push @$search_dirs, grep $_ ne File::Spec->curdir,  @INC;
  }

  $self->{'laborious'} = 0;   # Since inc said to use INC
  return;
}

#==========================================================================

sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
  my @them;
  (undef,@them) = @_;
  for $_ (@them) {
    if ( $_ eq '.' ) {
      $_ = ':';
    } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
      $_ = ':'. $_;
    } else {
      $_ =~ s|^\./|:|;
    }
  }
  return @them;
}

#==========================================================================

sub _limit_glob_to_limit_re {
  my $self = $_[0];
  my $limit_glob = $self->{'limit_glob'} || return;

  my $limit_re = '^' . quotemeta($limit_glob) . '$';
  $limit_re =~ s/\\\?/./g;    # glob "?" => "."
  $limit_re =~ s/\\\*/.*?/g;  # glob "*" => ".*?"
  $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""

  $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";

  # A common optimization:
  if(!exists($self->{'dir_prefix'})
    and $limit_glob =~ m/^(?:\w+\:\:)+/s  # like "File::*" or "File::Thing*"
    # Optimize for sane and common cases (but not things like "*::File")
  ) {
    $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
    $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
  }

  return $limit_re;
}

#==========================================================================

# contribution mostly from Tim Jenness <[e-mail]>

sub find {
  my($self, $pod, @search_dirs) = @_;
  $self = $self->new unless ref $self; # tolerate being a class method

  # Check usage
  Carp::carp 'Usage: \$self->find($podname, ...)'
   unless defined $pod and length $pod;

  my $verbose = $self->verbose;

  # Split on :: and then join the name together using File::Spec
  my @parts = split /::/, $pod;
  $verbose and print "Chomping {$pod} => {@parts}\n";

  #@search_dirs = File::Spec->curdir unless @search_dirs;
  
  if( $self->inc ) {
    if( $^O eq 'MacOS' ) {
      push @search_dirs, $self->_mac_whammy(@INC);
    } else {
      push @search_dirs,                    @INC;
    }

    # Add location of pod documentation for perl man pages (eg perlfunc)
    # This is a pod directory in the private install tree
    #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
    #					'pod');
    #push (@search_dirs, $perlpoddir)
    #  if -d $perlpoddir;

    # Add location of binaries such as pod2text:
    push @search_dirs, $Config::Config{'scriptdir'};
     # and if that's undef or q{} or nonexistent, we just ignore it later
  }

  my %seen_dir;
 Dir:
  foreach my $dir ( @search_dirs ) {
    next unless defined $dir and length $dir;
    next if $seen_dir{$dir};
    $seen_dir{$dir} = 1;
    unless(-d $dir) {
      print "Directory $dir does not exist\n" if $verbose;
      next Dir;
    }

    print "Looking in directory $dir\n" if $verbose;
    my $fullname = File::Spec->catfile( $dir, @parts );
    print "Filename is now $fullname\n" if $verbose;

    foreach my $ext ('', '.pod', '.pm', '.pl') {   # possible extensions
      my $fullext = $fullname . $ext;
      if( -f $fullext  and  $self->contains_pod( $fullext ) ){
        print "FOUND: $fullext\n" if $verbose;
        return $fullext;
      }
    }
    my $subdir = File::Spec->catdir($dir,'pod');
    if(-d $subdir) {  # slip in the ./pod dir too
      $verbose and print "Noticing $subdir and stopping there...\n";
      $dir = $subdir;
      redo Dir;
    }
  }

  return undef;
}

#==========================================================================

sub contains_pod {
  my($self, $file) = @_;
  my $verbose = $self->{'verbose'};

  # check for one line of POD
  $verbose > 1 and print " Scanning $file for pod...\n";
  unless( open(MAYBEPOD,"<$file") ) {
    print "Error: $file is unreadable: $!\n";
    return undef;
  }

  sleep($SLEEPY - 1) if $SLEEPY;
   # avoid totally hogging the processor on OSs with poor process control
  
  local $_;
  while( <MAYBEPOD> ) {
    if(m/^=(head\d|pod|over|item)\b/s) {
      close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
      chomp;
      $verbose > 1 and print "  Found some pod ($_) in $file\n";
      return 1;
    }
  }
  close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
  $verbose > 1 and print "  No POD in $file, skipping.\n";
  return 0;
}

#==========================================================================

sub _accessorize {  # A simple-minded method-maker
  shift;
  no strict 'refs';
  foreach my $attrname (@_) {
    *{caller() . '::' . $attrname} = sub {
      use strict;
      $Carp::CarpLevel = 1,  Carp::croak(
       "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
      ) unless (@_ == 1 or @_ == 2) and ref $_[0];

      # Read access:
      return $_[0]->{$attrname} if @_ == 1;

      # Write access:
      $_[0]->{$attrname} = $_[1];
      return $_[0]; # RETURNS MYSELF!
    };
  }
  # Ya know, they say accessories make the ensemble!
  return;
}

#==========================================================================
sub _state_as_string {
  my $self = $_[0];
  return '' unless ref $self;
  my @out = "{\n  # State of $self ...\n";
  foreach my $k (sort keys %$self) {
    push @out, "  ", _esc($k), " => ", _esc($self->{$k}), ",\n";
  }
  push @out, "}\n";
  my $x = join '', @out;
  $x =~ s/^/#/mg;
  return $x;
}

sub _esc {
  my $in = $_[0];
  return 'undef' unless defined $in;
  $in =~
    s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
     <'\\x'.(unpack("H2",$1))>eg;
  return qq{"$in"};
}

#==========================================================================

run() unless caller;  # run if "perl whatever/Search.pm"

1;

#==========================================================================

__END__