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.pm405
1 files changed, 0 insertions, 405 deletions
diff --git a/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm b/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm
deleted file mode 100644
index 6b1d265456c..00000000000
--- a/Master/tlpkg/tlperl/lib/Module/Pluggable/Object.pm
+++ /dev/null
@@ -1,405 +0,0 @@
-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);
-
-use if $] > 5.017, 'deprecate';
-
-$VERSION = '4.6';
-
-
-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_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'};
- 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 { $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 {
- 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_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;
-
-}
-
-
-sub _require {
- my $self = shift;
- my $pack = shift;
- eval "CORE::require $pack";
- die ($@) if $@;
- return 1;
-}
-
-
-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
-