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