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