package Module::Pluggable::Object;
use strict;
use File::Find ();
use File::Basename;
use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
use Carp qw(croak carp confess);
use Devel::InnerPackage;
use vars qw($VERSION $MR);
use if $] > 5.017, 'deprecate';
$VERSION = '5.2';
BEGIN {
eval { require Module::Runtime };
unless ($@) {
Module::Runtime->import('require_module');
} else {
*require_module = sub {
my $module = shift;
my $path = $module . ".pm";
$path =~ s{::}{/}g;
require $path;
};
}
}
sub new {
my $class = shift;
my %opts = @_;
return bless \%opts, $class;
}
### Eugggh, this code smells
### This is what happens when you keep adding patches
### *sigh*
sub plugins {
my $self = shift;
my @args = @_;
# override 'require'
$self->{'require'} = 1 if $self->{'inner'};
my $filename = $self->{'filename'};
my $pkg = $self->{'package'};
# Get the exception params instantiated
$self->_setup_exceptions;
# automatically turn a scalar search path or namespace into a arrayref
for (qw(search_path search_dirs)) {
$self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
}
# default search path is '<Module>::<Name>::Plugin'
$self->{'search_path'} ||= ["${pkg}::Plugin"];
# default error handler
$self->{'on_require_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't require $plugin : $err"; return 0 };
$self->{'on_instantiate_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't instantiate $plugin: $err"; return 0 };
# default whether to follow symlinks
$self->{'follow_symlinks'} = 1 unless exists $self->{'follow_symlinks'};
# check to see if we're running under test
my @SEARCHDIR = exists $INC{"blib.pm"} && defined $filename && $filename =~ m!(^|/)blib/! && !$self->{'force_search_all_paths'} ? grep {/blib/} @INC : @INC;
# add any search_dir params
unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
# set our @INC up to include and prefer our search_dirs if necessary
my @tmp = @INC;
unshift @tmp, @{$self->{'search_dirs'} || []};
local @INC = @tmp if defined $self->{'search_dirs'};
my @plugins = $self->search_directories(@SEARCHDIR);
push(@plugins, $self->handle_inc_hooks($_, @SEARCHDIR)) for @{$self->{'search_path'}};
push(@plugins, $self->handle_innerpackages($_)) for @{$self->{'search_path'}};
# return blank unless we've found anything
return () unless @plugins;
# remove duplicates
# probably not necessary but hey ho
my %plugins;
for(@plugins) {
next unless $self->_is_legit($_);
$plugins{$_} = 1;
}
# are we instantiating or requiring?
if (defined $self->{'instantiate'}) {
my $method = $self->{'instantiate'};
my @objs = ();
foreach my $package (sort keys %plugins) {
next unless $package->can($method);
my $obj = eval { $package->$method(@_) };
$self->{'on_instantiate_error'}->($package, $@) if $@;
push @objs, $obj if $obj;
}
return @objs;
} else {
# no? just return the names
my @objs= sort keys %plugins;
return @objs;
}
}
sub _setup_exceptions {
my $self = shift;
my %only;
my %except;
my $only;
my $except;
if (defined $self->{'only'}) {
if (ref($self->{'only'}) eq 'ARRAY') {
%only = map { $_ => 1 } @{$self->{'only'}};
} elsif (ref($self->{'only'}) eq 'Regexp') {
$only = $self->{'only'}
} elsif (ref($self->{'only'}) eq '') {
$only{$self->{'only'}} = 1;
}
}
if (defined $self->{'except'}) {
if (ref($self->{'except'}) eq 'ARRAY') {
%except = map { $_ => 1 } @{$self->{'except'}};
} elsif (ref($self->{'except'}) eq 'Regexp') {
$except = $self->{'except'}
} elsif (ref($self->{'except'}) eq '') {
$except{$self->{'except'}} = 1;
}
}
$self->{_exceptions}->{only_hash} = \%only;
$self->{_exceptions}->{only} = $only;
$self->{_exceptions}->{except_hash} = \%except;
$self->{_exceptions}->{except} = $except;
}
sub _is_legit {
my $self = shift;
my $plugin = shift;
my %only = %{$self->{_exceptions}->{only_hash}||{}};
my %except = %{$self->{_exceptions}->{except_hash}||{}};
my $only = $self->{_exceptions}->{only};
my $except = $self->{_exceptions}->{except};
my $depth = () = split '::', $plugin, -1;
return 0 if (keys %only && !$only{$plugin} );
return 0 unless (!defined $only || $plugin =~ m!$only! );
return 0 if (keys %except && $except{$plugin} );
return 0 if (defined $except && $plugin =~ m!$except! );
return 0 if defined $self->{max_depth} && $depth>$self->{max_depth};
return 0 if defined $self->{min_depth} && $depth<$self->{min_depth};
return 1;
}
sub search_directories {
my $self = shift;
my @SEARCHDIR = @_;
my @plugins;
# go through our @INC
foreach my $dir (@SEARCHDIR) {
push @plugins, $self->search_paths($dir);
}
return @plugins;
}
sub search_paths {
my $self = shift;
my $dir = shift;
my @plugins;
my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
# and each directory in our search path
foreach my $searchpath (@{$self->{'search_path'}}) {
# create the search directory in a cross platform goodness way
my $sp = catdir($dir, (split /::/, $searchpath));
# if it doesn't exist or it's not a dir then skip it
next unless ( -e $sp && -d _ ); # Use the cached stat the second time
my @files = $self->find_files($sp);
# foreach one we've found
foreach my $file (@files) {
# untaint the file; accept .pm only
next unless ($file) = ($file =~ /(.*$file_regex)$/);
# parse the file to get the name
my ($name, $directory, $suffix) = fileparse($file, $file_regex);
next if (!$self->{include_editor_junk} && $self->_is_editor_junk($name));
$directory = abs2rel($directory, $sp);
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
my @pkg_dirs = ();
if ( $name eq lc($name) || $name eq uc($name) ) {
my $pkg_file = catfile($sp, $directory, "$name$suffix");
open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
my $in_pod = 0;
while ( my $line = <PKGFILE> ) {
$in_pod = 1 if $line =~ m/^=\w/;
$in_pod = 0 if $line =~ /^=cut/;
next if ($in_pod || $line =~ /^=cut/); # skip pod text
next if $line =~ /^\s*#/; # and comments
if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
@pkg_dirs = split /::/, $1 if defined $1;;
$name = $2;
last;
}
}
close PKGFILE;
}
# then create the class name in a cross platform way
$directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/); # remove volume
my @dirs = ();
if ($directory) {
($directory) = ($directory =~ /(.*)/);
@dirs = grep(length($_), splitdir($directory))
unless $directory eq curdir();
for my $d (reverse @dirs) {
my $pkg_dir = pop @pkg_dirs;
last unless defined $pkg_dir;
$d =~ s/\Q$pkg_dir\E/$pkg_dir/i; # Correct case
}
} else {
$directory = "";
}
my $plugin = join '::', $searchpath, @dirs, $name;
next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]*!i;
$self->handle_finding_plugin($plugin, \@plugins)
}
# now add stuff that may have been in package
# NOTE we should probably use all the stuff we've been given already
# but then we can't unload it :(
push @plugins, $self->handle_innerpackages($searchpath);
} # foreach $searchpath
return @plugins;
}
sub _is_editor_junk {
my $self = shift;
my $name = shift;
# Emacs (and other Unix-y editors) leave temp files ending in a
# tilde as a backup.
return 1 if $name =~ /~$/;
# Emacs makes these files while a buffer is edited but not yet
# saved.
return 1 if $name =~ /^\.#/;
# Vim can leave these files behind if it crashes.
return 1 if $name =~ /\.sw[po]$/;
return 0;
}
sub handle_finding_plugin {
my $self = shift;
my $plugin = shift;
my $plugins = shift;
my $no_req = shift || 0;
return unless $self->_is_legit($plugin);
unless (defined $self->{'instantiate'} || $self->{'require'}) {
push @$plugins, $plugin;
return;
}
$self->{before_require}->($plugin) || return if defined $self->{before_require};
unless ($no_req) {
my $tmp = $@;
my $res = eval { require_module($plugin) };
my $err = $@;
$@ = $tmp;
if ($err) {
if (defined $self->{on_require_error}) {
$self->{on_require_error}->($plugin, $err) || return;
} else {
return;
}
}
}
$self->{after_require}->($plugin) || return if defined $self->{after_require};
push @$plugins, $plugin;
}
sub find_files {
my $self = shift;
my $search_path = shift;
my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
# find all the .pm files in it
# this isn't perfect and won't find multiple plugins per file
#my $cwd = Cwd::getcwd;
my @files = ();
{ # for the benefit of perl 5.6.1's Find, localize topic
local $_;
File::Find::find( { no_chdir => 1,
follow => $self->{'follow_symlinks'},
wanted => sub {
# Inlined from File::Find::Rule C< name => '*.pm' >
return unless $File::Find::name =~ /$file_regex/;
(my $path = $File::Find::name) =~ s#^\\./##;
push @files, $path;
}
}, $search_path );
}
#chdir $cwd;
return @files;
}
sub handle_inc_hooks {
my $self = shift;
my $path = shift;
my @SEARCHDIR = @_;
my @plugins;
for my $dir ( @SEARCHDIR ) {
next unless ref $dir && eval { $dir->can( 'files' ) };
foreach my $plugin ( $dir->files ) {
$plugin =~ s/\.pm$//;
$plugin =~ s{/}{::}g;
next unless $plugin =~ m!^${path}::!;
$self->handle_finding_plugin( $plugin, \@plugins );
}
}
return @plugins;
}
sub handle_innerpackages {
my $self = shift;
return () if (exists $self->{inner} && !$self->{inner});
my $path = shift;
my @plugins;
foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
$self->handle_finding_plugin($plugin, \@plugins, 1);
}
return @plugins;
}
1;
=pod
=head1 NAME
Module::Pluggable::Object - automatically give your module the ability to have plugins
=head1 SYNOPSIS
Simple use Module::Pluggable -
package MyClass;
use Module::Pluggable::Object;
my $finder = Module::Pluggable::Object->new(%opts);
print "My plugins are: ".join(", ", $finder->plugins)."\n";
=head1 DESCRIPTION
Provides a simple but, hopefully, extensible way of having 'plugins' for
your module. Obviously this isn't going to be the be all and end all of
solutions but it works for me.
Essentially all it does is export a method into your namespace that
looks through a search path for .pm files and turn those into class names.
Optionally it instantiates those classes for you.
This object is wrapped by C<Module::Pluggable>. If you want to do something
odd or add non-general special features you're probably best to wrap this
and produce your own subclass.
=head1 OPTIONS
See the C<Module::Pluggable> docs.
=head1 AUTHOR
Simon Wistow <simon@thegestalt.org>
=head1 COPYING
Copyright, 2006 Simon Wistow
Distributed under the same terms as Perl itself.
=head1 BUGS
None known.
=head1 SEE ALSO
L<Module::Pluggable>
=cut