lib/Module/Pluggable/Object.pm

   1 package Module::Pluggable::Object;
   2
   3 $VERSION = '3.5_01';
   4
   5 use strict;
   6 use File::Find ();
   7 use File::Basename;
   8 use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
   9 use Carp qw(croak carp);
  10 use Devel::InnerPackage;
  11 use Data::Dumper;
  12
  13 sub new {
  14     my $class = shift;
  15     my %opts  = @_;
  16
  17     return bless \%opts, $class;
  18
  19 }
  20
  21
  22 sub plugins {
  23         my $self = shift;
  24
  25         # override 'require'
  26         $self->{'require'} = 1 if $self->{'inner'};
  27
  28         my $filename   = $self->{'filename'};
  29         my $pkg        = $self->{'package'};
  30
  31         # automatically turn a scalar search path or namespace into a arrayref
  32         for (qw(search_path search_dirs)) {
  33             $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
  34         }
  35
  36
  37
  38
  39         # default search path is '<Module>::<Name>::Plugin'
  40         $self->{'search_path'} = ["${pkg}::Plugin"] unless $self->{'search_path'};
  41
  42
  43         #my %opts = %$self;
  44
  45
  46         # check to see if we're running under test
  47         my @SEARCHDIR = exists $INC{"blib.pm"} && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;
  48
  49         # add any search_dir params
  50         unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
  51
  52
  53         my @plugins = $self->search_directories(@SEARCHDIR);
  54
  55         # push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}});
  56
  57         # return blank unless we've found anything
  58         return () unless @plugins;
  59
  60
  61         # exceptions
  62         my %only;
  63         my %except;
  64         my $only;
  65         my $except;
  66
  67         if (defined $self->{'only'}) {
  68             if (ref($self->{'only'}) eq 'ARRAY') {
  69                 %only   = map { $_ => 1 } @{$self->{'only'}};
  70             } elsif (ref($self->{'only'}) eq 'Regexp') {
  71                 $only = $self->{'only'}
  72             } elsif (ref($self->{'only'}) eq '') {
  73                 $only{$self->{'only'}} = 1;
  74             }
  75         }
  76
  77
  78         if (defined $self->{'except'}) {
  79             if (ref($self->{'except'}) eq 'ARRAY') {
  80                 %except   = map { $_ => 1 } @{$self->{'except'}};
  81             } elsif (ref($self->{'except'}) eq 'Regexp') {
  82                 $except = $self->{'except'}
  83             } elsif (ref($self->{'except'}) eq '') {
  84                 $except{$self->{'except'}} = 1;
  85             }
  86         }
  87
  88
  89         # remove duplicates
  90         # probably not necessary but hey ho
  91         my %plugins;
  92         for(@plugins) {
  93             next if (keys %only   && !$only{$_}     );
  94             next unless (!defined $only || m!$only! );
  95
  96             next if (keys %except &&  $except{$_}   );
  97             next if (defined $except &&  m!$except! );
  98             $plugins{$_} = 1;
  99         }
 100
 101         # are we instantiating or requring?
 102         if (defined $self->{'instantiate'}) {
 103             my $method = $self->{'instantiate'};
 104             return map { ($_->can($method)) ? $_->$method(@_) : () } keys %plugins;
 105         } else {
 106             # no? just return the names
 107             return keys %plugins;
 108         }
 109
 110
 111 }
 112
 113 sub search_directories {
 114     my $self      = shift;
 115     my @SEARCHDIR = @_;
 116
 117     my @plugins;
 118     # go through our @INC
 119     foreach my $dir (@SEARCHDIR) {
 120         push @plugins, $self->search_paths($dir);
 121     }
 122
 123     return @plugins;
 124 }
 125
 126
 127 sub search_paths {
 128     my $self = shift;
 129     my $dir  = shift;
 130     my @plugins;
 131
 132     my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
 133
 134
 135     # and each directory in our search path
 136     foreach my $searchpath (@{$self->{'search_path'}}) {
 137         # create the search directory in a cross platform goodness way
 138         my $sp = catdir($dir, (split /::/, $searchpath));
 139
 140         # if it doesn't exist or it's not a dir then skip it
 141         next unless ( -e $sp && -d _ ); # Use the cached stat the second time
 142
 143         my @files = $self->find_files($sp);
 144
 145         # foreach one we've found
 146         foreach my $file (@files) {
 147             # untaint the file; accept .pm only
 148             next unless ($file) = ($file =~ /(.*$file_regex)$/);
 149             # parse the file to get the name
 150             my ($name, $directory, $suffix) = fileparse($file, $file_regex);
 151
 152             $directory = abs2rel($directory, $sp);
 153
 154             # If we have a mixed-case package name, assume case has been preserved
 155             # correctly.  Otherwise, root through the file to locate the case-preserved
 156             # version of the package name.
 157             my @pkg_dirs = ();
 158             if ( $name eq lc($name) || $name eq uc($name) ) {
 159                 my $pkg_file = catfile($sp, $directory, "$name$suffix");
 160                 open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
 161                 my $in_pod = 0;
 162                 while ( my $line = <PKGFILE> ) {
 163                     $in_pod = 1 if $line =~ m/^=\w/;
 164                     $in_pod = 0 if $line =~ /^=cut/;
 165                     next if ($in_pod || $line =~ /^=cut/);  # skip pod text
 166                     next if $line =~ /^\s*#/;               # and comments
 167                     if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
 168                         @pkg_dirs = split /::/, $1;
 169                         $name = $2;
 170                         last;
 171                     }
 172                 }
 173                 close PKGFILE;
 174             }
 175
 176             # then create the class name in a cross platform way
 177             $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);       # remove volume
 178             my @dirs = ();
 179             if ($directory) {
 180                 ($directory) = ($directory =~ /(.*)/);
 181                 @dirs = grep(length($_), splitdir($directory))
 182                     unless $directory eq curdir();
 183                 for my $d (reverse @dirs) {
 184                     my $pkg_dir = pop @pkg_dirs;
 185                     last unless defined $pkg_dir;
 186                     $d =~ s/\Q$pkg_dir\E/$pkg_dir/i;  # Correct case
 187                 }
 188             } else {
 189                 $directory = "";
 190             }
 191             my $plugin = join '::', $searchpath, @dirs, $name;
 192
 193             next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
 194
 195             my $err = $self->handle_finding_plugin($plugin);
 196             carp "Couldn't require $plugin : $err" if $err;
 197
 198             push @plugins, $plugin;
 199         }
 200
 201         # now add stuff that may have been in package
 202         # NOTE we should probably use all the stuff we've been given already
 203         # but then we can't unload it :(
 204         push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner});
 205     } # foreach $searchpath
 206
 207     return @plugins;
 208 }
 209
 210 sub handle_finding_plugin {
 211     my $self   = shift;
 212     my $plugin = shift;
 213
 214     return unless (defined $self->{'instantiate'} || $self->{'require'});
 215     $self->_require($plugin);
 216 }
 217
 218 sub find_files {
 219     my $self         = shift;
 220     my $search_path  = shift;
 221     my $file_regex   = $self->{'file_regex'} || qr/\.pm$/;
 222
 223
 224     # find all the .pm files in it
 225     # this isn't perfect and won't find multiple plugins per file
 226     #my $cwd = Cwd::getcwd;
 227     my @files = ();
 228     { # for the benefit of perl 5.6.1's Find, localize topic
 229         local $_;
 230         File::Find::find( { no_chdir => 1,
 231                            wanted => sub {
 232                              # Inlined from File::Find::Rule C< name => '*.pm' >
 233                              return unless $File::Find::name =~ /$file_regex/;
 234                              (my $path = $File::Find::name) =~ s#^\\./##;
 235                              push @files, $path;
 236                            }
 237                       }, $search_path );
 238     }
 239     #chdir $cwd;
 240     return @files;
 241
 242 }
 243
 244 sub handle_innerpackages {
 245     my $self = shift;
 246     my $path = shift;
 247     my @plugins;
 248
 249
 250     foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
 251         my $err = $self->handle_finding_plugin($plugin);
 252         #next if $err;
 253         #next unless $INC{$plugin};
 254         push @plugins, $plugin;
 255     }
 256     return @plugins;
 257
 258 }
 259
 260
 261 sub _require {
 262     my $self = shift;
 263     my $pack = shift;
 264     local $@;
 265     eval "CORE::require $pack";
 266     return $@;
 267 }
 268
 269
 270 1;
 271
 272 =pod
 273
 274 =head1 NAME
 275
 276 Module::Pluggable::Object - automatically give your module the ability to have plugins
 277
 278 =head1 SYNOPSIS
 279
 280
 281 Simple use Module::Pluggable -
 282
 283     package MyClass;
 284     use Module::Pluggable::Object;
 285
 286     my $finder = Module::Pluggable::Object->new(%opts);
 287     print "My plugins are: ".join(", ", $finder->plugins)."\n";
 288
 289 =head1 DESCRIPTION
 290
 291 Provides a simple but, hopefully, extensible way of having 'plugins' for
 292 your module. Obviously this isn't going to be the be all and end all of
 293 solutions but it works for me.
 294
 295 Essentially all it does is export a method into your namespace that
 296 looks through a search path for .pm files and turn those into class names.
 297
 298 Optionally it instantiates those classes for you.
 299
 300 =head1 AUTHOR
 301
 302 Simon Wistow <simon@thegestalt.org>
 303
 304 =head1 COPYING
 305
 306 Copyright, 2006 Simon Wistow
 307
 308 Distributed under the same terms as Perl itself.
 309
 310 =head1 BUGS
 311
 312 None known.
 313
 314 =head1 SEE ALSO
 315
 316 L<Module::Pluggable>
 317
 318 =cut
 319