view release on metacpan or  search on metacpan

lib/Package/Butcher.pm  view on Meta::CPAN

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