File Coverage

blib/lib/KiokuDB/TypeMap/Composite.pm

Criterion	Covered	Total	%
statement	55	57	96.4
branch	8	12	66.6
condition	3	6	50.0
subroutine	14	14	100.0
pod			n/a
total	80	89	89.8

#!/usr/bin/perl

package KiokuDB::TypeMap::Composite;
use Moose::Role;

use KiokuDB::TypeMap;

use namespace::clean -except => 'meta';

{
    package KiokuDB::TypeMap::Composite::TypeMapAttr;
    use Moose::Role;

    use namespace::clean -except => 'meta';

    sub Moose::Meta::Attribute::Custom::Trait::KiokuDB::TypeMap::register_implementation { __PACKAGE__ }
}

has override => (
    isa     => "HashRef[HashRef]",
    is      => "ro",
    default => sub { +{} },
);

has exclude => (
    isa     => "ArrayRef[Str]",
    is      => "ro",
    default => sub { [] },
);

has _exclude => (
    is         => "ro",
    lazy_build => 1,
);

sub _build__exclude {
    my $self = shift;
    return { map { $_ => undef } @{ $self->exclude } };
}

sub _build_includes {
    my $self = shift;

    my @attrs = $self->meta->get_all_attributes;

    my $exclude = $self->_exclude;

    my @typemap_attrs = grep {
        ( my $short_name = $_->name ) =~ s/_typemap$//;

        $_->does("KiokuDB::TypeMap::Composite::TypeMapAttr")
            and
        ( !$short_name or !exists($exclude->{$short_name}) )
            and
        !exists($exclude->{$_->name})
    } @attrs;

    return [ map { $_->get_value($self) } @typemap_attrs ];
}

sub _construct_entry {
    my ( $self, @args ) = @_;

    my $args = $self->_entry_options(@args);

    my $type = delete $args->{type};
    Class::MOP::load_class($type);

    $type->new($args);
}

sub _entry_options {
    my ( $self, %args ) = @_;

    my $class = delete $args{class};

    return { %args, %{ $self->override->{$class} || {} }, };
}

sub _create_entry {
    my ( $self, $class, $entry ) = @_;

    return if exists $self->_exclude->{$class};

    if ( blessed $entry ) {
        return ( $class => $entry );
    } elsif ( ref $entry ) {
        return ( $class => $self->_construct_entry( %$entry, class => $class ) );
    } else {
        return ( $class => $self->_construct_entry( type => $entry, class => $class ) );
    }
}

sub _create_entries {
    my ( $self, $entries ) = @_;

    my $excl;

    return {
        map {
            my $class = $_;
            my $entry = $entries->{$class};

            $self->_create_entry($class, $entry);
        } keys %$entries
    };
}

sub _create_typemap {
    my ( $self, %args ) = @_;

    foreach my $entries ( @args{grep { exists $args{$_} } qw(entries isa_entries does_entries)} ) {
        next unless $entries;
        $entries = $self->_create_entries($entries);
    }

    KiokuDB::TypeMap->new(%args);
}

sub _naive_isa_typemap {
    my ( $self, $class, @args ) = @_;

    $self->_create_typemap(
        isa_entries => {
            $class => {
                type => "KiokuDB::TypeMap::Entry::Naive",
                @args,
            },
        },
    );
}

__PACKAGE__

__END__

=pod

=head1 NAME

KiokuDB::TypeMap::Composite - A role for L<KiokuDB::TypeMaps> created out of
many smaller typemaps

=head1 SYNOPSIS

    package MyTypeMap;
    use Moose;

    extends qw(KiokuDB::TypeMap);

	with qw(KiokuDB::TypeMap::Composite);


    # declare typemaps to inherit from using the KiokuDB::TypeMap trait
    # the 'includes' attribute will be built by collecting these attrs:

    has foo_typemap => (
        traits => [qw(KiokuDB::TypeMap)], # register for inclusion
        does   => "KiokUDB::Role::TypeMap",
        is     => "ro",
        lazy_build => 1,
    );


    # this role also provides convenience methods for creating typemap objects
    # easily:
    sub _build_foo_typemap {
        my $self = shift;

        $self->_create_typemap(
            isa_entries => {
                $class => {
                    type      => 'KiokuDB::TypeMap::Entry::Callback',
                    intrinsic => 1,
                    collapse  => "collapse",
                    expand    => "new",
                },
            },
        );
    }

    sub _build_bar_typemap {
        my $self = shift;

        # create a typemap with one naive isa entry
        $self->_naive_isa_typemap("Class::Foo", @entry_args);
    }





    # you also get some construction time customization:

    MyTypeMap->new(
        exclude => [qw(Class::Blort foo)],
        override => {
            "Class::Blah", => $alternate_entry,
        },
    );

=head1 DESCRIPTION

This role provides a declarative, customizable way to set values for
L<KiokuDB::TypeMap>'s C<includes> attribute.

Any class consuming this role can declare attributes with the trait
C<KiokuDB::TypeMap>.

The result is a typemap instance that inherits from the specified typemap in a
way that is composable for the author and flexible for the user.

L<KiokuDB::TypeMap::Default> is created using this role.

=head1 ATTRIBUTES

=over 4

=item exclude

An array reference containing typemap attribute names (e.g. C<path_class> in
the default typemap) or class name to exclude.

Class exclusions are handled by C<_create_typemap> and do not apply to already
constructed typemaps.

=item override

A hash reference of classes to L<KiokuDB::TypeMap::Entry> objects.

Class overrides are handled by C<_create_typemap> and do not apply to already
constructed typemaps.

Classes which don't have a definition will not be merged into the resulting
typemap, simply create a typemap of your own and inherit if that's what you
want.

=back

=head1 METHODS

=over 4

=item _create_typemap %args

Creates a new typemap.

The entry arguments are converted before passing to L<KiokuDB::TypeMap/new>:

    $self->_create_typemap(
        entries => {
            Foo => {
                type => "KiokuDB::TypeMap::Entry::Naive",
                intrinsic => 1,
            },
        },
    );

The nested hashref will be used as arguments to
L<KiokuDB::TypeMap::Entry::Naive/new> in this example.

C<exclude> and C<override> are taken into account by the hashref conversion
code.

=item _naive_isa_typemap $class, %entry_args

A convenience method to create a one entry typemap with a single inherited
entry for C<$class> of the type L<KiokuDB::TypeMap::Entry::Naive>.

This is useful for when you have a base class that you'd like KiokuDB to
persist automatically:

    sub _build_my_class_typemap {
        shift->_naive_isa_typemap( "My::Class::Base" );
    }

=back

=cut