Initial Commit
This commit is contained in:
Riley Schneider
429
database/perl/vendor/lib/Module/Pluggable/Object.pm
vendored
Normal file
429
database/perl/vendor/lib/Module/Pluggable/Object.pm
vendored
Normal file
@@ -0,0 +1,429 @@
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user