File Coverage

blib/lib/Data/Object/Library.pm

Criterion	Covered	Total	%
statement	57	65	87.6
branch	8	22	36.3
condition	0	21	0.0
subroutine	9	12	75.0
pod	0	1	0.0
total	74	121	61.1

# ABSTRACT: Data::Object Type Library for Perl 5
package Data::Object::Library;

use 5.10.0;

use strict;
use warnings;

use Type::Library -base;
use Type::Utils   -all;

use Data::Object;

our $VERSION = '0.03'; # VERSION

extends 'Types::Standard';
extends 'Types::Common::Numeric';
extends 'Types::Common::String';

sub DECLARE {
    my ($name, %opts) = @_;

    return map +(DECLARE($_, %opts)), @$name if ref $name;

    ($opts{name} = $name) =~ s/:://g;

    my $registry = __PACKAGE__->meta;

    my @cans = ref($opts{can})  eq 'ARRAY' ? @{$opts{can}}  : $opts{can}  // ();
    my @isas = ref($opts{isa})  eq 'ARRAY' ? @{$opts{isa}}  : $opts{isa}  // ();
    my @does = ref($opts{does}) eq 'ARRAY' ? @{$opts{does}} : $opts{does} // ();

    my $code = $opts{constraint};
    my $text = $opts{inlined};

    $opts{constraint} = sub {
        my @args = @_;
        return if @isas and grep(not($args[0]->isa($_)),  @isas);
        return if @cans and grep(not($args[0]->can($_)),  @cans);
        return if @does and grep(not($args[0]->does($_)), @does);
        return if $code and not $code->(@args);
        return 1;
    };
    $opts{inlined} = sub {
        my $blessed = "Scalar::Util::blessed($_[1])";
        return join(' && ', map "($_)",
            join(' && ', map "($blessed and $_[1]->isa('$_'))",  @isas),
            join(' && ', map "($blessed and $_[1]->does('$_'))", @does),
            join(' && ', map "($blessed and $_[1]->can('$_'))",  @cans),
        $text ? $text : (),
        );
    };

    $opts{bless}   = "Type::Tiny";
    $opts{parent}  = "Object" unless $opts{parent};
    $opts{coerion} = 1;

    { no warnings "numeric"; $opts{_caller_level}++ }

    my $coerce = delete $opts{coerce};
    my $type   = declare(%opts);

    my $functions = {
        'Data::Object::Array'     => 'data_array',
        'Data::Object::Code'      => 'data_code',
        'Data::Object::Float'     => 'data_float',
        'Data::Object::Hash'      => 'data_hash',
        'Data::Object::Integer'   => 'data_integer',
        'Data::Object::Number'    => 'data_number',
        'Data::Object::Regexp'    => 'data_regexp',
        'Data::Object::Scalar'    => 'data_scalar',
        'Data::Object::String'    => 'data_string',
        'Data::Object::Undef'     => 'data_undef',
        'Data::Object::Universal' => 'data_universal',
    };

    my ($key) = grep { $functions->{$_} } @isas;

    for my $coercive ('ARRAY' eq ref $coerce ? @$coerce : $coerce) {
        my $object   = $registry->get_type($coercive);
        my $function = $$functions{$key};

        my $forward = Data::Object->can($function);
        coerce $opts{name}, from $coercive, via { $forward->($_) };

       $object->coercion->i_really_want_to_unfreeze;

        my $reverse = Data::Object->can('deduce_deep');
        coerce $coercive, from $opts{name}, via { $reverse->($_) };

        $object->coercion->freeze;
    }

    return $type;
}

DECLARE ["ArrayObj", "ArrayObject"] => (
    isa    => ["Data::Object::Array"],
    does   => ["Data::Object::Role::Array"],
    can    => ["data", "dump"],
    coerce => ["ArrayRef"],
    constraint_generator => sub {
        return Data::Object::Library::ArrayObject() unless @_;

        my $param = Types::TypeTiny::to_TypeTiny(shift);

        Types::TypeTiny::TypeTiny->check($param)
            or Types::Standard::_croak(
                "Parameter to ArrayObject[`a] expected ".
                "to be a type constraint; got $param"
            );

        return sub {
            my $arrayobj = shift;
            $param->check($_) || return for @$arrayobj;
            return !!1;
        }
    },
    deep_explanation => sub {
        my ($type, $value, $varname) = @_;
        my $param = $type->parameters->[0];

        for my $i (0 .. $#$value) {
            my $item = $value->[$i];
            next if $param->check($item);
            my $message  = '"%s" constrains each value in the array with "%s"';
            my @criteria = @{ $param->validate_explain($item, sprintf('%s->[%d]', $varname, $i)) };
            return [sprintf($message, $type, $param), @criteria]
        }

        return;
    },
);

DECLARE ["CodeObj", "CodeObject"] => (
    isa    => ["Data::Object::Code"],
    does   => ["Data::Object::Role::Code"],
    can    => ["data", "dump"],
    coerce => ["CodeRef"],
);

DECLARE ["FloatObj", "FloatObject"] => (
    isa    => ["Data::Object::Float"],
    does   => ["Data::Object::Role::Float"],
    can    => ["data", "dump"],
    coerce => ["Str", "Num", "LaxNum"],
);

DECLARE ["HashObj", "HashObject"] => (
    isa    => ["Data::Object::Hash"],
    does   => ["Data::Object::Role::Hash"],
    can    => ["data", "dump"],
    coerce => ["HashRef"],
    constraint_generator => sub {
        return Data::Object::Library::HashObject() unless @_;

        my $param = Types::TypeTiny::to_TypeTiny(shift);

        Types::TypeTiny::TypeTiny->check($param)
            or Types::Standard::_croak(
                "Parameter to HashObject[`a] expected ".
                "to be a type constraint; got $param"
            );

        return sub {
            my $hashobj = shift;
            $param->check($_) || return for values %$hashobj;
            return !!1;
        }
    },
    deep_explanation => sub {
        my ($type, $value, $varname) = @_;
        my $param = $type->parameters->[0];

        for my $k (sort keys %$value) {
            my $item = $value->{$k};
            next if $param->check($item);
            my $message  = '"%s" constrains each value in the hash object with "%s"';
            my @criteria = @{ $param->validate_explain($item, sprintf('%s->{%s}', $varname, B::perlstring($k))) };
            return [sprintf($message, $type, $param), @criteria]
        }

        return;
    },
    my_methods => {
        hashref_allows_key => sub {
            my $self = shift;
            Data::Object::Library::Str()->check($_[0]);
        },
        hashref_allows_value => sub {
            my $self = shift;
            my ($key, $value) = @_;

            return !!0 unless $self->my_hashref_allows_key($key);
            return !!1 if $self == Data::Object::Library::HashRef();

            my $href  = $self->find_parent(sub {
                $_->has_parent && $_->parent == Data::Object::Library::HashRef()
            });

            my $param = $href->type_parameter;

            Data::Object::Library::Str()->check($key) and $param->check($value);
        },
    },
);

DECLARE ["IntObj", "IntObject", "IntegerObj", "IntegerObject"] => (
    isa    => ["Data::Object::Integer"],
    does   => ["Data::Object::Role::Integer"],
    can    => ["data", "dump"],
    coerce => ["Str", "Num", "LaxNum", "StrictNum", "Int"],
);

DECLARE ["NumObj", "NumObject", "NumberObj", "NumberObject"] => (
    isa    => ["Data::Object::Number"],
    does   => ["Data::Object::Role::Number"],
    can    => ["data", "dump"],
    coerce => ["Str", "Num", "LaxNum", "StrictNum"],
);

DECLARE ["RegexpObj", "RegexpObject"] => (
    isa    => ["Data::Object::Regexp"],
    does   => ["Data::Object::Role::Regexp"],
    can    => ["data", "dump"],
    coerce => ["RegexpRef"],
);

DECLARE ["ScalarObj", "ScalarObject"] => (
    isa    => ["Data::Object::Scalar"],
    does   => ["Data::Object::Role::Scalar"],
    can    => ["data", "dump"],
    coerce => ["ScalarRef"],
);

DECLARE ["StrObj", "StrObject", "StringObj", "StringObject"] => (
    isa    => ["Data::Object::String"],
    does   => ["Data::Object::Role::String"],
    can    => ["data", "dump"],
    coerce => ["Str"],
);

DECLARE ["UndefObj", "UndefObject"] => (
    isa    => ["Data::Object::Undef"],
    does   => ["Data::Object::Role::Undef"],
    can    => ["data", "dump"],
    coerce => ["Undef"],
);

DECLARE ["AnyObj", "AnyObject", "UniversalObj", "UniversalObject"] => (
    isa    => ["Data::Object::Universal"],
    does   => ["Data::Object::Role::Universal"],
    can    => ["data", "dump"],
    coerce => ["Any"],
);

1;

__END__