File Coverage

blib/lib/Coat/Types.pm

Criterion	Covered	Total	%
statement	112	114	98.2
branch	27	36	75.0
condition	12	21	57.1
subroutine	37	38	97.3
pod	13	19	68.4
total	201	228	88.1

package Coat::Types;

use strict;
use warnings;

use Carp 'confess';
use base 'Exporter';
use vars qw(@EXPORT);

use Coat::Meta::TypeConstraint;

# Moose/Coat keywords
sub as      ($);
sub from    ($);
sub where   (&);
sub message (&);
sub type    ($$;$);
sub subtype ($$;$$);
sub enum    ($;@);
sub via     (&);
sub coerce  ($@);

@EXPORT = qw(
    type subtype enum coerce
    from as where via message

    register_type_constraint
    find_type_constraint
    find_or_create_type_constraint

    list_all_type_constraints
    list_all_builtin_type_constraints

    create_parameterized_type_constraint
    find_or_create_parameterized_type_constraint
);

sub as      ($) { $_[0] }
sub from    ($) { $_[0] }
sub where   (&) { $_[0] }
sub via     (&) { $_[0] }
sub message (&) { $_[0] }

# {{{ - Registry
# singleton for storing Coat::Meta::Typeconstrain objects

my $REGISTRY = { };

sub register_type_constraint {
    my ($tc) = @_;

    confess "can't register an unnamed type constraint"
        unless defined $tc->name;

    $REGISTRY->{$tc->name} = $tc;
}

sub find_type_constraint         { $REGISTRY->{$_[0]} }
sub list_all_type_constraints    { keys %$REGISTRY    }
sub get_type_constraint_registry { $REGISTRY          }

sub find_or_create_type_constraint {
    my ($type_name) = @_;

    my $tc = find_type_constraint( $type_name );
    return $tc if defined $tc;

    return register_type_constraint( Coat::Meta::TypeConstraint->new(
        name       => $type_name,
        parent     => 'Object',
        validation => sub { $_->isa($type_name) },
        message    => sub { "Value is not a member of class '$type_name' ($_)" },
    ));
}

# }}}

# {{{ - macro (type, subtype, coerce, enum)

sub type($$;$) {
    my ($type_name, $validation_code, $message) = @_;

    register_type_constraint( new Coat::Meta::TypeConstraint(
        name       => $type_name,
        parent     => undef,
        validation => $validation_code,
        message    => $message) );
}

sub subtype ($$;$$) {
    my ($type_name, $parent, $validation_code, $message) = @_;

    register_type_constraint( new Coat::Meta::TypeConstraint(
        name       => $type_name,
        parent     => $parent,
        validation => $validation_code,
        message    => $message ) );
}

sub enum ($;@) {
    my ($type_name, @values) = @_;
    confess "You must have at least two values to enumerate through"
        unless (scalar @values >= 2);

    my $regexp = join( '|', @values );

    subtype $type_name
        => as 'Str'
        => where { /^$regexp$/i };
}

sub coerce($@) {
    my ($type_name, %coercion_map) = @_;
    my $tc = find_or_create_type_constraint($type_name);

    if ($tc->has_coercion) {
        my $map = { %{ $tc->coercion_map }, %coercion_map };
        $tc->coercion_map ( $map );
    }
    else {
        $tc->coercion_map ( \%coercion_map );
    }
}

# }}}

# {{{ - exported functions

sub export_type_constraints_as_functions {
    my $caller = caller;
    foreach my $t ( list_all_type_constraints() ) {
        my $constraint = find_type_constraint( $t );
        my $constraint_symbol = "${caller}::${t}";
        my $constraint_sub = sub {
            my ($value) = @_;
            local $_ = $value;
            return $constraint->validation->($value) ? 1 : undef;
        };
        {
            no strict 'refs';
            no warnings 'redefine', 'prototype';
            *$constraint_symbol = $constraint_sub;
        }
    }
}

sub validate {
    my ($class, $attr, $attribute, $value, $type_name) = @_;
    $type_name ||= $attr->{isa};

    # Exception if not defined and required attribute
    confess "Attribute \($attribute\) is required and cannot be undef"
        if ($attr->{required} && ! defined $value);

    # Bypass the type check if not defined and not required
    return $value if (! defined $value && ! $attr->{required});

    # get the current TypeConstraint object (or create it if not defined)
    my $tc = (_is_parameterized_type_constraint( $type_name ))
        ? find_or_create_parameterized_type_constraint( $type_name )
        : find_or_create_type_constraint( $type_name ) ;

    # look for coercion : if the constraint has coercion and
    # current value is of a supported coercion source type, coerce.
    if ($attr->{coerce}) {
        (not $tc->has_coercion) &&
            confess "Coercion is not available for type '".$tc->name."'";
        # coercing...
        $value = $tc->coerce($value);
    }

    # validate the value through the type-constraint
    $tc->validate( $value );

    return $value;
}

# }}}

# {{{ - parameterized type constraints

sub find_or_create_parameterized_type_constraint ($) {
    my ($type_name) = @_;
    $REGISTRY->{$type_name} ||= create_parameterized_type_constraint( $type_name );
}

sub create_parameterized_type_constraint ($) {
    my ($type_name) = @_;

    my ($base_type, $type_parameter) =
        _parse_parameterized_type_constraint($type_name);

    (defined $base_type && defined $type_parameter)
        || confess "Could not parse type name ($type_name) correctly";

    my $tc_base = find_type_constraint( $base_type );
    (defined $tc_base)
        || confess "Could not locate the base type ($base_type)";

    confess "Unsupported base type ($base_type)"
        if (! _base_type_is_arrayref($base_type) &&
            ! _base_type_is_hashref($base_type) );

    my $tc_param = find_type_constraint( $type_parameter );

    my $tc = Coat::Meta::TypeConstraint->new (
        name           => $type_name,
        parent         => $base_type,
        message        => sub { "Validation failed with value $_" });

    # now add parameterized type constraint validation code
    # depending on the base type
    if (_base_type_is_arrayref( $base_type )) {
        $tc->validation( sub {
            foreach my $e (@$_) {
                eval { $tc_param->validate( $e )};
                return 0 if $@;
            }
            return 1;
        });
    }
    elsif (_base_type_is_hashref( $base_type )) {
        $tc->validation( sub {
            my $value = $_ || $_[0];

            foreach my $k (keys %$value) {
                eval { $tc_param->validate( $value->{$k} )};
                return 0 if $@;
            }
            return 1;
        });
    }

    # the type-constraint object is ready!
    return $tc;
}

# private subs for parameterized type constraints handling

sub _base_type_is_arrayref ($) {
    my ($type) = @_;
    return $type =~ /^ArrayRef|ARRAY$/;
}

sub _base_type_is_hashref ($) {
    my ($type) = @_;
    return $type =~ /^HashRef|HASH$/;
}

sub _parse_parameterized_type_constraint ($) {
    my ($type_name) = @_;

    if ($type_name =~ /^(\w+)\[([\w:_\d]+)\]$/) {
        return ($1, $2);
    }
    else {
        return (undef, undef);
    }
}

sub _is_parameterized_type_constraint ($) {
    my ($type_name) = @_;
    return $type_name =~ /^\w+\[[\w:_\d]+\]$/;
}

# }}}

# {{{ - built-in types and subtypes

## --------------------------------------------------------
## some basic built-in types (mostly taken from Moose)
## --------------------------------------------------------

type 'Any'  => where { 1 }; # meta-type including all
type 'Item' => where { 1 }; # base-type

subtype 'Undef'   => as 'Item' => where { !defined($_) };
subtype 'Defined' => as 'Item' => where {  defined($_) };

subtype 'Bool'
    => as 'Item'
    => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };

subtype 'Value'
    => as 'Defined'
    => where { !ref($_) };

subtype 'Ref'
    => as 'Defined'
    => where {  ref($_) };

subtype 'Str'
    => as 'Value'
    => where { 1 };

subtype 'Num'
    => as 'Value'
    => where { "$_" =~ /^-?[\d\.]+$/ };

subtype 'Int'
    => as 'Num'
    => where { "$_" =~ /^-?[0-9]+$/ };

subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };
subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  };
subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   };
subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   };
subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };
subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   };

subtype 'FileHandle'
    => as 'GlobRef'
    => where { ref($_) eq 'GLOB' };

subtype 'Object'
    => as 'Ref'
    => where { ref($_) &&
               ref($_) ne 'Regexp' &&
               ref($_) ne 'ARRAY' &&
               ref($_) ne 'SCALAR' &&
               ref($_) ne 'CODE' &&
               ref($_) ne 'HASH'};

subtype 'ClassName'
    => as 'Str'
    => where { ref($_[0]) && ref($_[0]) eq $_[1] };

# accesor to all the built-in types
{
    my @BUILTINS = list_all_type_constraints();
    sub list_all_builtin_type_constraints { @BUILTINS }
}

# }}}

1;
__END__