File Coverage

inc/Module/Pluggable/Object.pm

Criterion	Covered	Total	%
statement	173	230	75.2
branch	49	122	40.1
condition	28	63	44.4
subroutine	21	23	91.3
pod	0	8	0.0
total	271	446	60.7

#line 1
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 '::::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 =  ) {
                    $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;

#line 428