File Coverage

blib/lib/DCI/Cast.pm

Criterion	Covered	Total	%
statement	53	54	98.1
branch	8	10	80.0
condition	21	27	77.7
subroutine	16	17	94.1
pod	13	13	100.0
total	111	121	91.7

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

use Carp();
use Scalar::Util();

sub dci_new {
    my $class = shift;
    my ( $direct_core, $context, %state ) = @_;

    Carp::croak( "You must provide a core object" )
        unless $direct_core;

    Carp::croak( "You must provide a context" )
        unless $context;

    my $direct_core_type = Scalar::Util::blessed( $direct_core )
                        || Scalar::Util::reftype( $direct_core );

    my @allowed_cores = $class->dci_meta->allowed_cores;
    if ( @allowed_cores && !(grep { $direct_core->isa( $_ ) } @allowed_cores )) {
        Carp::croak "Invalid core '$direct_core_type' is not one of: "
            . join( ', ', @allowed_cores )
    }

    my $true_core = $direct_core;
    $true_core = $true_core->dci_core
        if Scalar::Util::blessed($true_core)
        && $true_core->isa( __PACKAGE__ );

    my $true_core_type = Scalar::Util::blessed( $true_core )
                      || Scalar::Util::reftype( $true_core );

    return bless {
        'state'          => \%state,
        true_core        => $true_core,
        direct_core      => $direct_core,
        context          => $context,
        true_core_type   => $true_core_type,
        direct_core_type => $direct_core_type,
        context_type     => Scalar::Util::blessed( $context )
                         || Scalar::Util::reftype( $context ),
    }, $class;
}

sub dci_meta {
    my $self_or_class = shift;
    my $class = Scalar::Util::blessed( $self_or_class )
             || $self_or_class;

    require DCI::Meta::Cast;
    DCI::Meta::Cast->new( $class );
}

sub dci_state { shift->{'state'} }

sub dci_context      { shift->{context}      }
sub dci_context_type { shift->{context_type} }

sub dci_core      { shift->dci_true_core      }
sub dci_core_type { shift->dci_true_core_type }

sub dci_true_core      { shift->{true_core}      }
sub dci_true_core_type { shift->{true_core_type} }

sub dci_direct_core      { shift->{direct_core}      }
sub dci_direct_core_type { shift->{direct_core_type} }

sub dci_debug {
    my $self = shift;

    my $out_start = "";
    my $out_end = "";
    my ( $type, $core_type, $core );
    do {
        my $one    = $core || $self;
        $type      = Scalar::Util::blessed($one);
        $core      = $one->dci_direct_core;
        $core_type = $one->dci_direct_core_type;

        $out_start = "$out_start$type( ";
        $out_end = ")$out_end";
    } while $core_type && $core_type->isa( __PACKAGE__ );

    return "$out_start$core $out_end";
}

sub isa {
    my $self = shift;

    return $self->SUPER::isa( @_ )
        unless Scalar::Util::blessed( $self );

    my $core = $self->dci_core;
    return $self->SUPER::isa( @_ ) || $core->isa( @_ );
}

1;

__END__