File Coverage

blib/lib/DCI/Meta/Context.pm

Criterion	Covered	Total	%
statement	79	83	95.1
branch	15	20	75.0
condition	11	17	64.7
subroutine	26	27	96.3
pod	9	11	81.8
total	140	158	88.6

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

use base 'DCI::Meta';

use Carp qw/croak confess/;
use Scalar::Util qw/blessed/;
use Exporter::Declare qw/export_to default_export import/;
require DCI::Context;

default_export cast    => sub { caller->dci_meta->cast( @_ )   };
default_export casting => sub { caller->dci_meta->casting( @_ )};
default_export sugar   => sub { caller->dci_meta->sugar( @_ )  };

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

sub base { 'DCI::Context' };

sub init {
    my $self = shift;
    %$self = (
        %$self,
        roles => {},
        maybe => {},
        sugar => {},
    );
}

sub roles       { keys %{ shift->{roles}}};
sub maybe_roles { keys %{ shift->{maybe}}};

sub get_role_cast {
    my $self = shift;
    my ( $role ) = @_;
    return $self->{roles}->{ $role }
        || $self->{maybe}->{ $role };
}

sub _add_role_method {
    my $self = shift;
    my ( $name, $cast ) = @_;
    my $target = $self->target;

    $self->inject( $target, $name => sub {
        my $context = shift;
        croak "Cannot call '$name' on unblessed '$context'"
            unless blessed( $context );

        if ( @_ ) {
            my ($val, @extra) = @_;
            croak "Extra arguments provided to '$name'"
                if @extra;

            $context->{$name} = $self->_normalize_core(
                $context, $cast, $val
            );
        }

        return $context->{$name};
    });
}

sub _normalize_core {
    my $self = shift;
    my ( $context, $cast, $val ) = @_;

    # No restrictions on core
    return $val unless defined $cast;

    # Val meets restrictions
    return $val if blessed $val && $val->isa( $cast );

    # Val can be wrapped used in cast
    return $cast->dci_new( $val, $context )
        if eval { $cast->isa( 'DCI::Cast' )};

    croak "'$val' is not a '$cast', and '$cast' is not a Cast type";
}

sub cast {
    my $self = shift;
    $self->_cast( $self->{roles}, @_ );
}

sub maybe_cast {
    my $self = shift;
    $self->_cast( $self->{maybe}, @_ );
}

sub _cast {
    my $self = shift;
    my ( $store, %roles ) = @_;
    for my $role ( keys %roles ) {
        croak "role $role already defined for '" . $self->target . "'"
            if $store->{$role};

        my $cast = $roles{$role};

        if ( $cast && !blessed( $cast ) && ref $cast eq 'HASH' ) {
            $cast = DCI::Meta::Cast->anonymous( %$cast );
        }

        $store->{$role} = $cast;
        $self->_add_role_method( $role, $cast );
    }
}

sub casting {
    my $self = shift;
    $self->_cast( $self->{roles}, map {( $_ => undef )} @_ );
}

sub maybe_casting {
    my $self = shift;
    $self->_cast( $self->{maybe}, map {( $_ => undef )} @_ );
}

sub sugar {
    my $self = shift;

    croak "sugar() called without args" unless @_;

    my ( $name, @args ) = @_;
    my %params = @args > 1 ? @args : ( method => @args );

    my $method = $params{method} || croak "No method specified for sugar";
    my $ordered = $params{ordered} || [];
    my $target = $self->target;

    $self->{sugar}->{$name} = sub {
        $target->new(
            (map {( $_ => shift( @_ ) )} @$ordered),
            @_,
        )->$method;
    }
}

sub dci_exports {
    my $self = shift;
    return %{ $self->{sugar} }
}

1;

__END__