CAF.pm

package Object::Container::CAF;

use parent qw(Class::Accessor::Fast Class::Singleton);

use Carp;
use Exporter::AutoClean;
use Module::Load;
use Class::Inspector;

our $VERSION = '0.01';

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

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

sub _new_instance {
    $_[0]->new;
}

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');
            Exporter::AutoClean->export(
                $caller,
                register => sub { $r->($caller, @_) },
            );
        }
        else {
            no strict 'refs';
            *{"${caller}::${name}"} = sub {
                my ($target) = @_;
                return $target ? $class->get($target) : $class;
            };
        }
    }
}

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

    my $initializer;
    if (@rest == 1 and ref($rest[0]) eq 'CODE') {
        $initializer = $rest[0];
    }
    else {
        $initializer = sub {
            $self->ensure_class_loaded($class);
            $class->new(@rest);
        };
    }

    $self->registered_classes->{$class} = $initializer;
}

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

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

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) : ();
    } 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 ensure_class_loaded {
    my ($self, $class) = @_;
    load($class) unless (Class::Inspector->loaded($class));
}

1;

__END__

=head1 NAME

Object::Container::CAF -

=head1 SYNOPSIS

  use Object::Container::CAF;

=head1 DESCRIPTION

Object::Container::CAF is

=head1 AUTHOR

Toru Yamaguchi E<lt>zigorou@cpan.orgE<gt>

=head1 SEE ALSO

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut