summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm164
1 files changed, 98 insertions, 66 deletions
diff --git a/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm b/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm
index e0ee993075d..6b1d265456c 100644
--- a/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm
+++ b/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm
@@ -4,11 +4,13 @@ use strict;
use File::Find ();
use File::Basename;
use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
-use Carp qw(croak carp);
+use Carp qw(croak carp confess);
use Devel::InnerPackage;
use vars qw($VERSION);
-$VERSION = '3.9';
+use if $] > 5.017, 'deprecate';
+
+$VERSION = '4.6';
sub new {
@@ -25,64 +27,74 @@ sub new {
sub plugins {
- my $self = shift;
-
- # 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"] unless $self->{'search_path'};
+ my $self = shift;
+ my @args = @_;
+ # override 'require'
+ $self->{'require'} = 1 if $self->{'inner'};
- #my %opts = %$self;
+ my $filename = $self->{'filename'};
+ my $pkg = $self->{'package'};
+ # Get the exception params instantiated
+ $self->_setup_exceptions;
- # check to see if we're running under test
- my @SEARCHDIR = exists $INC{"blib.pm"} && defined $filename && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;
+ # automatically turn a scalar search path or namespace into a arrayref
+ for (qw(search_path search_dirs)) {
+ $self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
+ }
- # add any search_dir params
- unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
+ # 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 };
- my @plugins = $self->search_directories(@SEARCHDIR);
- push(@plugins, $self->handle_innerpackages($_)) for @{$self->{'search_path'}};
+ # default whether to follow symlinks
+ $self->{'follow_symlinks'} = 1 unless exists $self->{'follow_symlinks'};
- # push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}});
-
- # return blank unless we've found anything
- return () unless @plugins;
+ # 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'};
- # remove duplicates
- # probably not necessary but hey ho
- my %plugins;
- for(@plugins) {
- next unless $self->_is_legit($_);
- $plugins{$_} = 1;
- }
+ my @plugins = $self->search_directories(@SEARCHDIR);
+ 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 requring?
- if (defined $self->{'instantiate'}) {
- my $method = $self->{'instantiate'};
- return map { ($_->can($method)) ? $_->$method(@_) : () } keys %plugins;
- } else {
- # no? just return the names
- return keys %plugins;
+ # are we instantiating or requring?
+ 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 {
@@ -127,12 +139,16 @@ sub _is_legit {
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;
}
@@ -193,7 +209,7 @@ sub search_paths {
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;
+ @pkg_dirs = split /::/, $1 if defined $1;;
$name = $2;
last;
}
@@ -220,10 +236,7 @@ sub search_paths {
next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
- my $err = $self->handle_finding_plugin($plugin);
- carp "Couldn't require $plugin : $err" if $err;
-
- push @plugins, $plugin;
+ $self->handle_finding_plugin($plugin, \@plugins)
}
# now add stuff that may have been in package
@@ -252,12 +265,33 @@ sub _is_editor_junk {
}
sub handle_finding_plugin {
- my $self = shift;
- my $plugin = shift;
-
- return unless (defined $self->{'instantiate'} || $self->{'require'});
+ my $self = shift;
+ my $plugin = shift;
+ my $plugins = shift;
+ my $no_req = shift || 0;
+
return unless $self->_is_legit($plugin);
- $self->_require($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 { $self->_require($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 {
@@ -273,7 +307,8 @@ sub find_files {
{ # for the benefit of perl 5.6.1's Find, localize topic
local $_;
File::Find::find( { no_chdir => 1,
- wanted => sub {
+ 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#^\\./##;
@@ -294,10 +329,7 @@ sub handle_innerpackages {
my @plugins;
foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
- my $err = $self->handle_finding_plugin($plugin);
- #next if $err;
- #next unless $INC{$plugin};
- push @plugins, $plugin;
+ $self->handle_finding_plugin($plugin, \@plugins, 1);
}
return @plugins;
@@ -305,11 +337,11 @@ sub handle_innerpackages {
sub _require {
- my $self = shift;
- my $pack = shift;
- local $@;
+ my $self = shift;
+ my $pack = shift;
eval "CORE::require $pack";
- return $@;
+ die ($@) if $@;
+ return 1;
}