diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm | 164 |
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; } |