[Summary view] [Print] [Text view]

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