lib/Module/Pluggable/Object.pm

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