File Coverage

blib/lib/Package/Butcher.pm

Criterion	Covered	Total	%
statement	135	147	91.8
branch	20	42	47.6
condition	1	3	33.3
subroutine	28	29	96.5
pod	3	3	100.0
total	187	224	83.4

package Package::Butcher;

use warnings;
use strict;

use Package::Butcher::Inflator;
use Carp ();

use constant VALID_PACKAGE_RE => qr/^\w+(?:::\w+)*$/;
use constant VALID_SUBROUTINE_RE  => qr/^[_[:alpha:]][[:word:]]*$/;

our $VERSION = '0.02';

sub new {
    my ( $class, $arg_for ) = @_;
    my $self = bless {} => $class;
    return $self->_initialize($arg_for);
}

sub _initialize {
    my ( $self, $arg_for ) = @_;
    my %default_for = (
        package           => delete $arg_for->{package},
        import_on_use     => delete $arg_for->{import_on_use},
        is_package_loaded => 0,
        subs_installed    => {},
    );
    foreach my $method ( keys %default_for ) {
        $self->{$method} = $default_for{$method};
        no strict 'refs';
        *$method = sub { $_[0]->{$method} };
    }
    $self->_do_not_load( delete $arg_for->{do_not_load} );
    # _sub() must be called before _predeclare
    $self->_subs( delete $arg_for->{subs} );
    $self->_predeclare( delete $arg_for->{predeclare} );
    $self->_method_chains( delete $arg_for->{method_chains} );

    return $self;
}

sub _is_package_loaded { $_[0]->{is_package_loaded} = $_[1] }

sub _assert_looks_like_package {
    my ( $proto, $package ) = @_;
    unless ( $package =~ VALID_PACKAGE_RE ) {
        Carp::confess(
            "'$package' does not look like a valid package name to me");
    }
}

sub _assert_looks_like_subroutine {
    my ( $proto, $subroutine ) = @_;
    unless ( $subroutine =~ VALID_SUBROUTINE_RE ) {
        Carp::confess("'$subroutine' does not look like a valid subroutine name to me");
    }
}

sub _do_not_load {
    my ( $self, $packages ) = @_;
    return unless $packages;
    $packages = [$packages] unless 'ARRAY' eq ref $packages;
    foreach my $package (@$packages) {
        $self->_assert_looks_like_package($package);
        my $file = "$package.pm";
        $file =~ s{::}{/}g;
        my $butcher = ref $self;
        my $message = "loaded via '$butcher'";
        if ( $INC{$file} && $INC{$file} ne $message ) {
            Carp::cluck("'$package' already loaded via '$INC{$file}'");
        }
        else {
            $INC{$file} = $message;

            # This ensures that "use Foo 'bar'" won't generate "package Foo
            # doesn't export bar" errors
            no strict 'refs';
            *{"${package}::import"} = sub {};
        }
    }
}

sub _subs {
    my ( $self, $subs ) = @_;
    return unless $subs;
    my $subs_installed = $self->subs_installed;
    foreach my $sub (keys %$subs) {
        $self->_assert_looks_like_subroutine($sub);
        if (exists $subs_installed->{$sub} ) {
            Carp::confess("Cannot install a subroutine already installed: '$sub'");
        }
        my $code = $subs->{$sub};
        unless ( 'CODE' eq ref $code ) {
            Carp::confess("The value for '$sub' must be a subroutine reference");
        }
        $subs_installed->{$sub} = $code;
    }
}

sub _method_chains {
    my ( $self, $chains ) = @_;
    return unless $chains;
    foreach my $chain (@$chains) {
        my ( $class_to_override, @methods ) = @$chain;
        my $code = pop @methods;

        unless (@methods) {
            Carp::confess("Must have at least one method name to call on $class_to_override");
        }
        unless ( 'CODE' eq ref $code ) {
            Carp::confess("Final argument to install_method_chain must be a coderef");
        }

        $self->_assert_looks_like_package($class_to_override);
        $self->_assert_looks_like_subroutine($_) foreach @methods;

        my $first   = shift @methods;
        my $inflate = $code;
        while ( my $method = pop @methods ) {
            $inflate = { $method => $inflate };
        }
        {
            no strict 'refs';
            *{"${class_to_override}::$first"} = sub {
                  Package::Butcher::Inflator->new($inflate);
            };
        }
    }
    return;
}

sub _uniq {
    my %seen = ();
    grep { not $seen{$_}++ } @_;
}

sub _predeclare {
    my ( $self, $subs ) = @_;
    return unless $subs;
    $subs = [$subs] unless 'ARRAY' eq ref $subs;
    my $installed = $self->subs_installed;

    # we have to predeclare subs we're installing lest we hit subtle parsing
    # issues where Perl thinks they're indirect method calls. See 'perldoc
    # perlobj' for more information. Thanks for Flavio for spotting this
    # issue.
    @$subs = _uniq(@$subs, keys %$installed);
    my $package = $self->package;
    my $forward_declarations = join '' => map { "sub $_;" } @$subs;
    eval "package $package; $forward_declarations";
    Carp::confess($@) if $@;
}

sub use {
    my ( $self, @import ) = @_;
    $self->_load( 'use', @import );
}

sub require {
    my ($self) = @_;
    if ( @_ > 1 ) {
        Carp::confess("require() does not take arguments");
    }
    $self->_load('require');
}

sub _load {
    my ( $self, $use_or_require, @import ) = @_;

    my $package = $self->package;
    if ( my $loaded = $self->is_package_loaded ) {
        Carp::confess("You have already loaded '$package' via '$loaded'");
    }

    my $caller = caller(1);

    my $import = '';
    if (@import) {
        require Data::Dumper;
        no warnings 'once';
        local $Data::Dumper::Terse  = 1;
        local $Data::Dumper::Indent = 0;
        $import = join ', ' => Data::Dumper::Dumper(@import);
    }

    my $import_list = $self->import_on_use ? $import : '()';
    eval <<"    USE";
    package $caller;
    $use_or_require $package $import_list;
    USE
    Carp::confess($@) if $@;

    my $to_install = $self->subs_installed;
    foreach my $sub (keys %$to_install) {
        # XXX we were going to do nifty checks to see if you could 'install'
        # or 'replace' a sub, but merely the existance of
        # Some::Package::subname() in another package would create the stash
        # slot. We're taking the easy way out.
        # my $stash = do { no strict 'refs'; \%{"${package}::"} };
        # if (exists $stash->{$sub} ) {}
        no strict 'refs';
        no warnings 'redefine';
        *{"${package}::$sub"} = $to_install->{$sub};
    }

    unless ( $self->import_on_use ) {
        eval <<"        IMPORT";
        package $caller;
        $package->import($import);
        IMPORT
        Carp::confess($@) if $@;
    }

    $self->_is_package_loaded($use_or_require);
}

1;

__END__