File Coverage

blib/lib/Coat/Meta/TypeConstraint.pm

Criterion	Covered	Total	%
statement	40	40	100.0
branch	13	14	92.8
condition	7	12	58.3
subroutine	13	13	100.0
pod	4	10	40.0
total	77	89	86.5

package Coat::Meta::TypeConstraint;

use strict;
use warnings;
use Carp 'confess';

sub new {
    my ($class, %values) = @_;
    my $self = { %values };
    return bless $self, $class;
}

# accessors
sub name         { $_[0]->{name}         ||= $_[1] }
sub validation   { $_[0]->{validation}   ||= $_[1] }
sub message      { $_[0]->{message}      ||= $_[1] }
sub parent       { $_[0]->{parent}       ||= $_[1] }

sub coercion_map {
    my ($self, $map) = @_;
    if (@_ == 1) {
        return $self->{coercion_map};
    }
    else {
        return $self->{coercion_map} = $map;
    }
}

# coerce the given value with the first matching type
sub coerce {
    my ($self, $value) = @_;

    # for each source registered, try coercion if the source is a valid type
    local $_ = $value;
    foreach my $source (keys %{ $self->coercion_map }) {
        # if current value passes the current source check, coercing
        my $tc = Coat::Types::find_type_constraint($source);
        return $self->{coercion_map}{$source}->($value)
            if $tc->silent_validate($value);
    }
    return $value;
}

# check the value through the type constraints
sub silent_validate {
    my ($self, $value) = @_;
    local $_ = $value;

    # validates the parent's type-constraint if exists
    if (defined $self->parent) {
        Coat::Types::find_type_constraint( $self->parent )->silent_validate( $value )
            or return 0;
    }
    return $self->validation->($value);
}

sub validate {
    my ($self, $value) = @_;
    unless ($self->silent_validate($value)) {
        local $_ = $value;
        my $msg = (defined $self->message)
            ? $self->message->()
            : "Value '" .(defined $value ? $value : 'undef')
            ."' does not validate type constraint '".$self->name."'";
        confess $msg;
    }
    return 1;
}

sub has_coercion {
    my ($self) = @_;
    return defined $self->coercion_map;
}

1;
__END__