File Coverage

blib/lib/Micro/Container.pm

Criterion	Covered	Total	%
statement	70	74	94.5
branch	17	22	77.2
condition	7	12	58.3
subroutine	12	12	100.0
pod	5	5	100.0
total	111	125	88.8

package Micro::Container;

use strict;
use warnings;
use 5.008_001;
our $VERSION = '0.03';

use parent qw(Class::Data::Inheritable);

use Carp qw(croak);

__PACKAGE__->mk_classdata(objects => {});

my %INSTANCES;
sub instance {
    my $class = shift;
    $INSTANCES{$class} ||= do {
        my $self = bless {}, $class;
        $self->{_parent_classes} = $self->_parent_classes($class);
        $self;
    };
}

sub register {
    my $self = shift;
    my $klass = ref $self;
    unless ($klass) {
        ($klass, $self) = ($self, $self->instance);
    }

    my $objects = $self->objects->{$klass} ||= {};
    while (@_) {
        my ($name, $args) = splice @_, 0, 2;
        if (ref $args eq 'CODE') {
            $objects->{$name} = $args->($self, $name);
        }
        else {
            local $Carp::CarpLevel = $Carp::CarpLevel + 1;
            $objects->{$name} = $self->load_class($name)->new(@$args);
        }
    }
}
*add = *register;

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

    my $objects = $self->objects->{$klass} ||= {};
    for my $name (@names) {
        delete $objects->{$name};
    }
}
*remove = *unregister;

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

    my $objects = $self->objects;
    my $obj = $objects->{$klass}{$name};

    # find from parent classes
    unless ($obj) {
        my $classes = $self->{_parent_classes};
        for my $class (@$classes) {
            $obj = $objects->{$class}{$name} and last;
        }
    }

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

sub load_class {
    my ($self, $class, $prefix) = @_;

    # taken from Plack::Util::load_class
    if ($prefix) {
        unless ($class =~ s/^\+// || $class =~ /^$prefix/) {
            $class = "$prefix\::$class";
        }
    }

    my $file = $class;
    $file =~ s!::!/!g;
    eval {
        require "$file.pm"; ## no critic
    };
    if (my $e = $@) {
        croak "$e";
    }

    return $class;
}

sub _parent_classes {
    my ($self, $klass, $classes) = @_;
    $classes ||= [];

    my @isa = do {
        no strict 'refs';
        @{"$klass\::ISA"};
    };
    push @$classes, @isa;

    for my $class (@isa) {
        next if $class eq __PACKAGE__;
        $self->_parent_classes($class, $classes);
    }

    return $classes;
}

1;
__END__