view release on metacpan or  search on metacpan

lib/Pickles/Container.pm  view on Meta::CPAN

package Pickles::Container;
use strict;
use Carp ();

sub new {
    my ($class, %args) = @_;
    bless {
        components     => {},
        home           => $args{home},
        objects        => {},
        scoped_objects => {},
    }, $class;
}

sub Pickles::Container::ScopeGuard::DESTROY {
    my $self = shift;
    $self->{container}->clear_scope();
}

sub new_scope {
    my $self = shift;
    return bless { container => $self }, 'Pickles::Container::ScopeGuard';
}

sub clear_scope {
    my $self = shift;
    $self->{scoped_objects} = {};
}

sub load {
    my ($self, $file) = @_;

    my $o = \&register;
    no warnings 'redefine';
    local *register = sub($$;$) {
        $o->( $self, @_ );
    };
    local *load_file = sub(@) {
        my $c = $self->get('config');
        # XXX what if there's no config?
        my $file = $c->path_to(@_);

        delete $INC{$file};
        my $rv = require $file;
        Carp::croak("Failed to parse file $file: $@") if $@;
        Carp::croak("Failed to run file (did you return a true value?)") unless $rv;
        return $rv;
    };
    my $result = do $file;
    die "Failed to parse file $file: $@" if $@;
    die "Failed to run file (did you return a true value?)" unless $result;
    $self;
}

sub components {
    my $self = shift;
    my $h = $self->{components};
    if (! $h) {
        $self->{components} = ($h = {});
    }
    return $h;
}

sub home { $_[0]->{home} }
sub objects { $_[0]->{objects} }
sub scoped_objects { $_[0]->{scoped_objects} }

sub register {
    my ($self, $name, $component, $opts) = @_;

    if (ref $component eq 'CODE') {
        $opts ||= {};
        my %data = (
            %$opts,
            initializer => $component,
        );
        $self->components->{ $name } = \%data;
    } else {
        $self->objects->{$name} = $component;
    }
}

sub get {
    my ($self, $name, @args) = @_;
    my $object = $self->{objects}->{$name} || $self->{scoped_objects}->{$name};
    if (! $object) {
        my $data = $self->components->{ $name };
        $object = $self->_construct_object($data, @args);
        if ($object) {
            if ($data->{persistent}) {
                $self->objects->{$name} = $object;
            } else {
                $self->scoped_objects->{$name} = $object;
            }
        }
    }
    return $object;
}

sub _construct_object {
    my ($self, $data, @args) = @_;
    if (! $data) {
        return ();
    }