File Coverage

blib/lib/Module/Finder.pm

Criterion	Covered	Total	%
statement	143	160	89.3
branch	42	56	75.0
condition	4	9	44.4
subroutine	22	25	88.0
pod	7	7	100.0
total	218	257	84.8

package Module::Finder;
$VERSION = v0.1.5;

use warnings;
use strict;
use Carp;

use File::Find ();
use File::Spec ();
use constant {fs => 'File::Spec'};

BEGIN {
package Module::Finder::Info;
use File::Spec ();
use constant {fs => 'File::Spec'};

use Class::Accessor::Classy;
with 'new';
#with 'clone'; # todo for C::A::C ?
ro 'filename';    # absolute path
ro 'module_path'; # relative to search directory (part 2 of filename)
ro 'inc_path';    # other part of filename
ro 'module_name'; # My::Module::Name
no  Class::Accessor::Classy;

sub new {
  my $class = shift;
  my $self = $class->SUPER::new(@_);
  $self->{inc_path} = fs->rel2abs($self->{inc_path});
  $self->{filename} = fs->catfile(
    $self->{inc_path},
    $self->{module_path}
  );
  return($self);
} # end sub new
} # end Module::Finder::Info package

=head1 NAME

Module::Finder - find and query modules in @INC and/or elsewhere

=head1 SYNOPSIS

  use Module::Finder;
  my $finder = Module::Finder->new(
    dirs => ['/usr/local/junk/', '/junk/', @INC],
    paths => {
      'Module::Name::Prefix' => '-',   # no recursion - just *.pm
      'This::Path'           => '-/-', # only This/Path/*/*.pm
      'My'                   => '*',   # everything below My/
    },
  );

  # dirs searches @INC only if it is blank

  # the first request will cache search results
  my @modnames = $finder->modules;

  my @modinfos = $finder->module_infos;

  my $info = $finder->module_info('My::Found');

  # if you're creating/installing code, you might want to rescan
  $finder->reset;

=cut

use Class::Accessor::Classy;
with 'new';
ro 'paths';
ro 'name';
no  Class::Accessor::Classy;

=head2 new

  my $finder = Module::Finder->new(%args);

=over

=item globs

This isn't the same as shell glob syntax.  These globs say how deep (or
not) you want to look in a given path and whether you want to pickup
modules that appear along the way.  A list of shell glob equivalents
follows each one.

  /      just recurse              (*, */*, */*/*, ...)
  +      just this directory       (*)
  -/+    only one level down       (*/*)
  -/-/+  two levels down           (*/*/*)
  -/+/+  one and two levels down   (*/*, */*/*)
  +/+/+  zero thru two levels down (*, */*, */*/*)

If the glob spec is more that just "+", the trailing plus (which is
required to make sense) may be omitted (e.g. '-/+' and '-/' are
equivalent.)

=back

=cut

sub new {
  my $class = shift;
  (@_ % 2) and croak('odd number of elements in argument list');
  my %args = @_;

  my $self = {%args};
  bless($self, $class);
  $self->reset;
  return($self);
} # end subroutine new definition
########################################################################

=head2 _find

  $finder->_find;

=cut

sub _find {
  my $self = shift;

  exists($self->{_module_infos}) and return(%{$self->{_module_infos}});
  my $infos = $self->{_module_infos} = {};
  my @lookdirs = $self->_which_dirs;
  foreach my $look (@lookdirs) {
    my ($dir, $part, $nglob) = @$look;
    (-d $dir) or next;
    my $search_in = fs->catdir($dir, $part);
    if(my @globs = $self->_glob_parse($nglob)) {
      my $ret_dir = fs->rel2abs(fs->curdir);
      #warn "return to $ret_dir";
      chdir($dir) or die "cannot be in $dir";
      # things should be fairly sane once we're in the libdir
      # (famous last words?)
      foreach my $glob (map({$_, $_ . 'c'} @globs)) {
        my $look = join('/', fs->splitdir($part), $glob);
        foreach my $modpath (glob($look)) {
          (-e $modpath) or next;
          my $modname = join('::', fs->splitdir($modpath));
          $modname =~ s/\.pmc?$//;
          # TODO should I?
          # if(($modpath =~ m/\.pmc$/) and
          #   $infos->{$modname} and
          #   ($infos->{$modname}->inc_path eq $dir)) {
          #   next;
          # }
          my $obj = Module::Finder::Info->new(
            module_path => $modpath,
            inc_path    => '.', #$dir, # will get absolute in new()
            module_name => $modname,
          );
          $infos->{$modname} ||= [];
          push(@{$infos->{$modname}}, $obj);
        }
      }
      chdir($ret_dir) or die "ack";
    }
    else {
      my $wanted = sub {
        my $modpath = fs->abs2rel($_, $dir);
        return if($modpath eq $part);
        #warn "look $modpath";
        m/\.pmc?$/ or return;
        my $modname = join('::', fs->splitdir($modpath));
        $modname =~ s/\.pmc?$//;
        my $obj = Module::Finder::Info->new(
          module_path => $modpath,
          inc_path    => $dir,
          module_name => $modname,
        );
        $infos->{$modname} ||= [];
        push(@{$infos->{$modname}}, $obj);
      };
      # do the find
      (-e $search_in) or next;
      File::Find::find({wanted => $wanted, no_chdir => 1}, $search_in);
    }
  }

  return(%$infos);
} # end subroutine _find definition
########################################################################

=head2 _which_dirs

  my @dirs = $self->_which_dirs;

=cut

sub _which_dirs {
  my $self = shift;

  my @dirs = @{$self->{dirs}};
  my $paths = $self->paths;
  my $name = $self->name;
  if(defined($name)) { # make the glob be that filename
    $name =~ s#::#/#g;
    $name .= '.pm';
  }

  unless($paths) {
    return(map({[$_, '', ($name ? $name : '/')]} @dirs));
  }

  # TODO maybe bail if we get here and have $name
  # e.g. $path + $name is just $path::$name
  # somewhat sensible for multiple paths, but wouldn't that be a 'names'
  # thing instead?

  my @look_dirs;
  foreach my $dir (@dirs) {
    foreach my $path (keys(%$paths)) {
      #warn "check for $dir/$path";
      my $pathdir = fs->catdir(split(/::/, $path));
      if(-d fs->catdir($dir, $pathdir)) {
        push(@look_dirs,
          [
            $dir,
            $pathdir,
            ($name ? $name : $paths->{$path})
          ]
        );
      }
      #else {warn `pwd` ."-- no $dir/$path"};
    }
  }
  return(@look_dirs);
} # end subroutine _which_dirs definition
########################################################################

=head2 _glob_parse

  my $glob = $self->_glob_parse($glob);

=cut

sub _glob_parse {
  my $self = shift;
  my ($glob) = @_;
  (defined($glob) and length($glob)) or croak('glob must be defined');
  ($glob eq '/') and return; # recurse
  ($glob =~ m/\.pm$/) and return($glob); # explicit
  my @parts = split(/\//, $glob, -1);
  if($parts[-1] ne '') {
    ($parts[-1] eq '+') or
      croak("explicit trailing glob part must be + not '$parts[-1]'");
  }
  else {
    $parts[-1] = '+';
  }
  (1 == @parts) and return('*.pm');
  my @globs;
  my $base = '';
  foreach my $part (@parts) {
    $base .= '/*';
    if($part eq '+') {
      push(@globs, $base);
    }
    elsif($part eq '-') {
      # pass
    }
    else {
      croak "'$part' is not a valid glob segment";
    }
  }
  foreach my $glob (@globs) {
    $glob =~ s#^/##;
    $glob .= '.pm';
  }
  return(@globs);
} # end subroutine _glob_parse definition
########################################################################

=head2 reset

  $finder->reset;

=cut

sub reset {
  my $self = shift;

  if(my $dirs = $self->{dirs}) {
    ((ref($dirs) || '') eq 'ARRAY') or
      croak("'dirs' argument must be an array ref");
    my %seen;
    @$dirs = grep({exists($seen{$_}) ? 0 : ($seen{$_} = 1)} @$dirs);
  }
  else {
    $self->{dirs} = [@INC];
  }

  delete($self->{_module_infos});
} # end subroutine reset definition
########################################################################

=head2 modules

  my @modnames = $finder->modules;

=cut

sub modules {
  my $self = shift;

  my %infos = $self->_find;
  return(keys(%infos));
} # end subroutine modules definition
########################################################################

=head2 module_infos

Returns the info for the first hit of every found module.

  my %modinfos = $finder->module_infos;

=cut

sub module_infos {
  my $self = shift;
  my %infos = $self->_find;
  return(map({$_ => $infos{$_}[0]} keys(%infos)));
} # end subroutine module_infos definition
########################################################################

=head2 all_module_infos

Returns the info for all hits of every found module.  Each element of
the returned hash will be an array ref with one or more info objects.

  my %modinfos = $finder->all_module_infos;

=cut

sub all_module_infos {
  my $self = shift;
  my ($module) = @_;
  my %infos = $self->_find;
  return(%infos);
} # end subroutine all_module_infos definition
########################################################################

=head2 module_info

  my $info = $finder->module_info('My::Found');

=cut

sub module_info {
  my $self = shift;
  my ($module) = @_;
  my %infos = $self->_find;
  exists($infos{$module}) or return;
  my $inf = $infos{$module};
  return($inf->[0]);
} # end subroutine module_info definition
########################################################################

=head2 all_module_info

  my @info = $finder->all_module_info('My::Found');

=cut

sub all_module_info {
  my $self = shift;
  my ($module) = @_;
  my %infos = $self->_find;
  exists($infos{$module}) or return;
  my $inf = $infos{$module};
  return(@$inf);
} # end subroutine all_module_info definition
########################################################################


=head1 AUTHOR

Eric Wilhelm

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2006 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatseover.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

This module is inspired and/or informed by the following.  Maybe they do
what you want.

  File::Find
  File::Finder
  Module::Find
  Module::Require
  Module::Locate
  Module::Pluggable::Object
  Module::List

=cut

# vi:ts=2:sw=2:et:sta
1;