File Coverage

blib/lib/Object/Container.pm

Criterion	Covered	Total	%
statement	147	157	93.6
branch	53	68	77.9
condition	22	42	52.3
subroutine	28	31	90.3
pod	9	11	81.8
total	259	309	83.8

package Object::Container;

use strict;
use warnings;
use parent qw(Class::Accessor::Fast);
use Carp;

our $VERSION = '0.16';

__PACKAGE__->mk_accessors(qw/registered_classes autoloader_rules objects/);

BEGIN {
    our $_HAVE_EAC = 1;
    eval { local $SIG{__DIE__}; require Exporter::AutoClean; };
    if ($@) {
        $_HAVE_EAC = 0;
    }
}

do {
    my @EXPORTS;

    sub import {
        my ($class, $name) = @_;
        return unless $name;

        my $caller = caller;
        {
            no strict 'refs';
            if ($name =~ /^-base$/i) {
                push @{"${caller}::ISA"}, $class;
                my $r = $class->can('register');
                my $l = $class->can('autoloader');

                my %exports = (
                    register   => sub { $r->($caller, @_) },
                    autoloader => sub { $l->($caller, @_) },
                    preload    => sub {
                        $caller->instance->get($_) for @_;
                    },
                    preload_all_except => sub {
                        $caller->instance->load_all_except(@_);
                    },
                    preload_all => sub {
                        $caller->instance->load_all;
                    },
                );

                if ($Object::Container::_HAVE_EAC) {
                    Exporter::AutoClean->export( $caller, %exports );
                }
                else {
                    while (my ($name, $fn) = each %exports) {
                        *{"${caller}::${name}"} = $fn;
                    }
                    @EXPORTS = keys %exports;
                }
            }
            else {
                no strict 'refs';
                *{"${caller}::${name}"} = sub {
                    my ($target) = @_;
                    return $target ? $class->get($target) : $class;
                };
            }
        }
    }

    sub unimport {
        my $caller = caller;

        no strict 'refs';
        for my $name (@EXPORTS) {
            delete ${ $caller . '::' }{ $name };
        }

        1; # for EOF
    }
};

my %INSTANCES;
sub instance {
    my $class = shift;
    return $INSTANCES{$class} ||= $class->new;
}

sub has_instance {
    my $class = shift;
    $class = ref $class || $class;
    return $INSTANCES{$class};
};

sub new {
    $_[0]->SUPER::new( +{
        registered_classes => +{},
        autoloader_rules => +[],
        objects => +{},
    } );
}

sub register {
    my ($self, $args, @rest) = @_;
    $self = $self->instance unless ref $self;

    my ($class, $initializer, $is_preload);
    if (defined $args && !ref $args) {
        $class = $args;
        if (@rest == 1 and ref $rest[0] eq 'CODE') {
            $initializer = $rest[0];
        }
        else {
            $initializer = sub {
                $self->ensure_class_loaded($class);
                $class->new(@rest);
            };
        }
    }
    elsif (ref $args eq 'HASH') {
        $class = $args->{class};
        if (exists $args->{initializer} && ref $args->{initializer} eq 'CODE') {
            $initializer = $args->{initializer};
        }
        else {
            $initializer = sub {
                $self->ensure_class_loaded($class);
                $class->new(@{exists $args->{args} ? $args->{args} : []});
            };
        }

        $is_preload = 1 if $args->{preload};
    }
    else {
        croak "Usage: $self->register($class || { class => $class ... })";
    }

    $self->registered_classes->{$class} = $initializer;
    $self->get($class) if $is_preload;

    return $initializer;
}

sub unregister {
    my ($self, $class) = @_;
    $self = $self->instance unless ref $self;

    delete $self->registered_classes->{$class} and $self->remove($class);
}

sub autoloader {
    my ($self, $rule, $trigger) = @_;
    $self = $self->instance unless ref $self;

    push @{ $self->autoloader_rules }, [$rule, $trigger];
}

sub get {
    my ($self, $class) = @_;
    $self = $self->instance unless ref $self;

    my $obj = $self->objects->{ $class } ||= do {
        my $initializer = $self->registered_classes->{ $class };
        $initializer ? $initializer->($self) : ();
    };

    unless ($obj) {
        # autoloaderer
        if (my ($trigger) = grep { $class =~ /$_->[0]/ } @{ $self->autoloader_rules }) {
            $trigger->[1]->($self, $class);
        }

        $obj = $self->objects->{ $class } ||= do {
            my $initializer = $self->registered_classes->{ $class };
            $initializer ? $initializer->($self) : ();
        };
    }

    $obj or croak qq["$class" is not registered in @{[ ref $self ]}];
}

sub remove {
    my ($self, $class) = @_;
    $self = $self->instance unless ref $self;
    delete $self->objects->{ $class };
}

sub load_all {
    my ($self) = @_;
    $self->load_all_except;
}

sub load_all_except {
    my ($self, @except) = @_;
    $self = $self->instance unless ref $self;

    for my $class (keys %{ $self->registered_classes }) {
        next if grep { $class eq $_ } @except;
        $self->get($class);
    }
}

# taken from Mouse
sub _is_class_loaded {
    my $class = shift;

    return 0 if ref($class) || !defined($class) || !length($class);

    # walk the symbol table tree to avoid autovififying
    # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::

    my $pack = \%::;
    foreach my $part (split('::', $class)) {
        $part .= '::';
        return 0 if !exists $pack->{$part};

        my $entry = \$pack->{$part};
        return 0 if ref($entry) ne 'GLOB';
        $pack = *{$entry}{HASH};
    }

    return 0 if !%{$pack};

    # check for $VERSION or @ISA
    return 1 if exists $pack->{VERSION}
             && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
    return 1 if exists $pack->{ISA}
             && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;

    # check for any method
    foreach my $name( keys %{$pack} ) {
        my $entry = \$pack->{$name};
        return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
    }

    # fail
    return 0;
}


sub _try_load_one_class {
    my $class = shift;

    return '' if _is_class_loaded($class);
    my $klass = $class;
    $klass  =~ s{::}{/}g;
    $klass .= '.pm';

    return do {
        local $@;
        eval { require $klass };
        $@;
    };
}

sub ensure_class_loaded {
    my ($self, $class) = @_;
    my $e = _try_load_one_class($class);
    Carp::confess "Could not load class ($class) because : $e" if $e;

    return $class;
}

1;
__END__