File Coverage

blib/lib/DCI/Meta/Cast.pm

Criterion	Covered	Total	%
statement	87	88	98.8
branch	17	24	70.8
condition	4	10	40.0
subroutine	20	20	100.0
pod	5	7	71.4
total	133	149	89.2

package DCI::Meta::Cast;
use strict;
use warnings;

use base 'DCI::Meta';
use Carp qw/croak/;
use Scalar::Util qw/blessed reftype/;
use Exporter::Declare qw/export_tag export default_export gen_export export_to import/;
require DCI::Cast;

our $ANONYMOUS_CLASS = "AAAAAAAAAA";
our $AUTOLOAD;

sub base { 'DCI::Cast' }
sub init { shift->{allowed_cores} = [] }
sub allowed_cores { @{shift->{allowed_cores}} }

sub require_core {
    my $self = shift;
    push @{$self->{allowed_cores}} => @_;
}

export_tag auto_delegate => qw/ AUTOLOAD can -default /;

default_export delegate => sub {
    caller->dci_meta->delegate( @_ )
};

default_export require_core => sub {
    caller->dci_meta->require_core( @_ );
};

default_export accessors => sub {
    caller->dci_meta->accessors( @_ );
};

export can => sub {
    my $self = shift;
    my ( $name ) = @_;

    my $existing = $self->SUPER::can( $name );
    return $existing if $existing;

    return unless blessed( $self );

    my $sub = $self->dci_true_core->can( $name );

    unless ( $sub ) {
        return if grep { m/^$name$/ } qw/DESTROY import unimport/;
        croak "Core object " . $self->dci_true_core . " has no method '$name()'";
    }

    $self->dci_meta->delegate( $name );

    $self->SUPER::can( $name );
};

gen_export AUTOLOAD => sub {
    my ( $exported_by, $import_class ) = @_;

    return sub {
        my ($self) = @_;
        my ( $package, $name ) = ( $AUTOLOAD =~ m/^(.+)::([^:]+)$/ );
        $AUTOLOAD = undef;
        my $sub = $self->can($name) || return;
        goto &$sub;
    };
};

sub accessors {
    my $self = shift;
    my $target = $self->target;

    for my $accessor ( @_ ) {
        croak "'$accessor()' already defined by '$target'"
            if $target->can( $accessor );

        $self->inject( $target, $accessor, sub {
            my $self = shift;

            croak "$accessor cannot be called on unblessed reference '$self'"
                unless blessed( $self );

            my $state = $self->dci_state();
            ($state->{$accessor}) = @_ if @_;
            return $state->{$accessor};
        });
    }
};

sub delegate {
    my $self = shift;
    my @methods = @_;
    my $target = $self->target;

    for my $method ( @methods ) {
        $self->inject( $target, $method => sub {
            my $cast = shift;

            croak "method '$method()' cannot be called on string '$cast'"
                unless blessed $cast;

            my $core = $cast->dci_core;
            my $sub = $core->can($method);

            unless( $sub ) {
                my $core_class = blessed( $core );
                croak "method '$method()' is not implemented by core class '$core_class'";
            }

            unshift @_ => $core;

            goto &$sub;
        });
    }
}

sub anonymous {
    my $class = shift;
    my %params = @_;

    my $package = __PACKAGE__ . "::__ANON__::" . $ANONYMOUS_CLASS++;
    my $file = "/$package.pm";
    $file =~ s|::|/|g;
    $INC{$file} ||= __FILE__;

    my $meta = $class->new( $package );

    for my $sugar ( grep { $class->can( $_ )} keys %params ) {
        my $item = delete $params{$sugar};
        my $type = reftype( $item );

        croak "'$sugar' accepts either a string, or an array of strings, not '$type'"
            if $type && $type ne 'ARRAY';

        $meta->$sugar( $type ? (@$item) : ($item) );
    }

    for my $method ( keys %params ) {
        my $sub = delete $params{$method};
        my $type = reftype( $sub );

        croak "value for '$method' must be a subref, '$method' is not a method on '$class'"
            unless $type && $type eq 'CODE';

        $meta->inject( $package, $method => $sub );
    }

    return $package;
}

1;

__END__