File Coverage

blib/lib/Config/Registry.pm

Criterion	Covered	Total	%
statement	76	78	97.4
branch	17	24	70.8
condition	6	11	54.5
subroutine	17	18	94.4
pod	4	11	36.3
total	120	142	84.5

package Config::Registry;
our $VERSION = '0.04';
use strictures 2;

use Carp qw( croak );
use MRO::Compat;

use Moo;
use namespace::clean;

around BUILDARGS => sub{
    my $orig = shift;
    my $class = shift;

    my $args = $class->$orig( @_ );
    $args = $class->merge_documents( $class->document(), $args );
    $args = $class->render_document( $args );

    return $args;
};

sub BUILD {
    my ($self) = @_;

    my $class = ref $self;
    croak "$class must be published before an instance may be built"
        if !$class->_get_class_data('is_published');

    return;
}

my %DATA;

sub _set_class_data {
    my ($class, $key, $value) = @_;
    my $data = $DATA{$class} ||= {};
    $data->{$key} = $value;
    return;
}

sub _get_class_data {
    my ($class, $key) = @_;

    my $isas = mro::get_linear_isa( $class );

    foreach my $isa (@$isas) {
        my $data = $DATA{ $isa };
        next if !$data;
        next if !exists $data->{$key};
        return $data->{$key};
    }

    return undef;
}

sub merge_schemas {
    my $class = shift;
    return $class->merge( @_ );
}

sub merge_documents {
    my $class = shift;
    return $class->merge( @_ );
}

sub merge {
    my ($class, $l, $r) = @_;

    return $r if ref($l) ne 'HASH';
    return $r if ref($r) ne 'HASH';

    $r = { %$r };

    foreach my $key (keys %$l) {
        next if !exists $r->{$key};
        $r->{$key} = $class->merge( $l->{$key}, $r->{$key} );
    }

    return { %$l, %$r };
}

sub render_schema {
    my $class = shift;
    return $class->render( @_ );
}

sub render_document {
    my $class = shift;
    return $class->render( @_ );
}

sub render {
    shift;
    return shift;
}

my %REGISTRIES;

sub fetch {
    my ($class) = @_;
    return $REGISTRIES{ $class } ||= $class->new();
}

sub schema {
    my ($class, $extra) = @_;

    my $schema = $class->_get_class_data('schema') || {};
    return $schema if !$extra;

    croak "Cannot change the registry schema after publishing $class"
        if $class->_get_class_data('is_published');

    $schema = $class->merge_schemas( $schema, $extra );
    $class->_set_class_data( schema => $schema );

    return $schema;
}

sub document {
    my ($class, $extra) = @_;

    my $document = $class->_get_class_data('document') || {};
    return $document if !$extra;

    croak "Cannot change the registry document after publishing $class"
        if $class->_get_class_data('is_published');

    $document = $class->merge_documents( $document, $extra );
    $class->_set_class_data( document => $document );

    return $document;
}

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

    croak "$class, or an ancestor class of, has already been published"
        if $class->_get_class_data('is_published');

    my $schema = $class->_get_class_data('schema') || {};

    $schema = $class->render_schema( $schema );

    foreach my $key (keys %$schema) {
        my $spec = $schema->{$key};
        $spec = { isa=>$spec } if ref($spec) ne 'HASH';

        $spec = {
            is             => 'ro',
            required => 1,
            %$spec,
        };

        # This is what the has() function does in Moo.pm.
        Moo->_constructor_maker_for( $class )
            ->register_attribute_specs( $key, $spec );
        Moo->_accessor_maker_for( $class )
            ->generate_method( $class, $key, $spec );
        Moo->_maybe_reset_handlemoose( $class );
    }

    $class->_set_class_data( is_published => 1 );

    return;
}

1;
__END__