File Coverage

lib/Class/Dot/Registry.pm

Criterion	Covered	Total	%
statement	86	95	90.5
branch	29	40	72.5
condition	6	6	100.0
subroutine	23	24	95.8
pod	12	12	100.0
total	156	177	88.1

# $Id$
# $Source$
# $Author$
# $HeadURL$
# $Revision$
# $Date$
package Class::Dot::Registry;

use strict;
use warnings;
use version;
use 5.00600;

our $VERSION   = qv('2.0.0_15');
our $AUTHORITY = 'cpan:ASKSH';

use Carp qw(croak);
use Class::Plugin::Util qw(require_class);

my $DEFAULT_METACLASS = 'Class::Dot::Meta::Class';

STATE: {
    my $THE_REGISTRY; # << This is a singleton object.

    my $scalar_ref = do { my $scalar; \$scalar };

    sub new {
        my ($class) = @_;

        if (! defined $THE_REGISTRY) {
            $THE_REGISTRY = bless $scalar_ref, $class;
        }

        return $THE_REGISTRY;
    }
}

PRIVATE: {
    my %METACLASS_FOR;
    my %IS_FINALIZED;
    my %ISA_CACHE_FOR;
    my %CLASS_META_FOR;
    my %OPTIONS_FOR;
    my %REGISTERED_CLASSES;

    sub _get_metaclasses {
        return \%METACLASS_FOR;
    }

    sub _get_finalized {
        return \%IS_FINALIZED;
    }

    sub _get_isa_cache {
        return \%ISA_CACHE_FOR;
    }

    sub _get_class_meta {
        return \%CLASS_META_FOR;
    }

    sub _get_options {
        return \%OPTIONS_FOR;
    }

    sub _get_registered_classes {
        return \%REGISTERED_CLASSES;
    }
}

sub register_class {
    my ($self, $the_class) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;

    my $class_register = _get_registered_classes();
    $class_register->{$class} = 1;
    return;
}

sub is_class_registered {
    my ($self, $the_class) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;

    return _get_registered_classes()->{$class};
}

sub finalize_class {
    my ($self, $the_class, $isa_cache) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;
    return if not defined $class;

    my $is_finalized = _get_finalized();

    return 1 if $is_finalized->{$class};

    if ($isa_cache) {
        $self->update_isa_cache_for($class, $isa_cache);
    }

    $is_finalized->{$class} = 1;

    return 1;
}

sub is_finalized {
    my ($self, $the_class) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;

    return _get_finalized()->{$class} ? 1 : 0;
}

sub get_isa_cache_for {
    my ($self, $the_class) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;
    my $isa_cache_for = _get_isa_cache();
    return if not exists $isa_cache_for->{$class};

    # Can be undef. If it is, the class is probably not finalized.
    return $isa_cache_for->{$class};
}

sub update_isa_cache_for {
    my ($self, $class, $isa_cache) = @_;

    my $isa_cache_for = _get_isa_cache();
    $isa_cache_for->{$class} = $isa_cache;
    return;
}

sub get_meta_for {
    my ($self, $class) = @_;
    my $class_meta_for = _get_class_meta();

    $class_meta_for->{$class} ||= { };
    return $class_meta_for->{$class};
}

sub get_options_for {
    my ($self, $the_class, $initial_options) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;
    my $options_for = _get_options();

    $initial_options ||= { };

    # Must be a copy of the options because it probably
    # comes from %Class::Dot::Policy::DEFAULT_OPTIONS, so if we
    # just use that reference all class options will be
    # the same as the last class initialized.
    $options_for->{$class} ||= { %{$initial_options} };

    return $options_for->{$class};
}

sub set_options_for {
    my ($self, $class, $options_ref) = @_;
    return if not ref $options_ref;
    return if not ref $options_ref eq 'HASH';
    my $options_for = _get_options();

    $options_for->{$class} = $options_ref;
    return;
}

sub get_metaclass_for {
    my ($self, $the_class) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;
    my $metaclass_for = _get_metaclasses();

    if (! exists $metaclass_for->{$class}) {
        $self->init_metaclass_for($class);
    }

    return $metaclass_for->{$class};
}

sub init_metaclass_for {
    my ($self, $the_class, $metaclass, $options_ref) = @_;
    my $class = ref $the_class ? ref $the_class
        : $the_class;
    my $metaclass_for = _get_metaclasses();

    if (not defined $metaclass) {
        $metaclass = $DEFAULT_METACLASS;
    }

    if (! require_class($metaclass)) {
        croak "!!! COULD NOT LOAD METACLASS $metaclass FOR CLASS $class !!!";
    }

    # -override gets priority over -optimized.
    if ($options_ref->{'-override'}) {
        $options_ref->{'-optimized'} = 0;
    };

    my %metaclass_options  = %{ $options_ref };
    $metaclass_options{for_class} = $class;

    my $metaclass_instance = $metaclass->new(\%metaclass_options);
    $metaclass_for->{$class} = $metaclass_instance;

    return $metaclass_instance;
}

1;

__END__