From: Johannes Plunien Date: Mon, 1 Jun 2009 15:30:18 +0000 (+0200) Subject: Added support for Maybe[...] constraints X-Git-Tag: 0.18~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ef87e4a6d8b5aa0136e1342cbb1f7340d4d9315e;p=gitmo%2FMooseX-Storage.git Added support for Maybe[...] constraints --- diff --git a/Changes b/Changes index d692938..88c69ea 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for MooseX-Storage +0.18 + * Added support for Maybe[...] constraints + 0.17 * Change MooseX::Storage::Engine to use get_all_attributes, rather than the deprecated compute_all_applicable_attributes (t0m) diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index 72e4434..e7536f1 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -298,6 +298,14 @@ sub remove_custom_type_handler { sub find_type_handler { my ($self, $type_constraint) = @_; + # check if the type is a Maybe and + # if its parent is not parameterized. + # If both is true recurse this method + # using ->type_parameter. + return $self->find_type_handler($type_constraint->type_parameter) + if $type_constraint->parent eq 'Maybe' + and not $type_constraint->parent->can('type_parameter'); + # this should handle most type usages # since they they are usually just # the standard set of built-ins diff --git a/t/070_basic_maybe.t b/t/070_basic_maybe.t new file mode 100644 index 0000000..c154327 --- /dev/null +++ b/t/070_basic_maybe.t @@ -0,0 +1,193 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 22; + +BEGIN { + use_ok('MooseX::Storage'); +} + +{ + + package Foo; + use Moose; + use MooseX::Storage; + + with Storage; + + has 'number' => ( is => 'ro', isa => 'Maybe[Int]' ); + has 'string' => ( is => 'ro', isa => 'Maybe[Str]' ); + has 'boolean' => ( is => 'ro', isa => 'Maybe[Bool]' ); + has 'float' => ( is => 'ro', isa => 'Maybe[Num]' ); + has 'array' => ( is => 'ro', isa => 'Maybe[ArrayRef]' ); + has 'hash' => ( is => 'ro', isa => 'Maybe[HashRef]' ); + has 'object' => ( is => 'ro', isa => 'Maybe[Foo]' ); +} + +{ + my $foo = Foo->new( + number => 10, + string => 'foo', + boolean => 1, + float => 10.5, + array => [ 1 .. 10 ], + hash => { map { $_ => undef } ( 1 .. 10 ) }, + object => Foo->new( number => 2 ), + ); + isa_ok( $foo, 'Foo' ); + + is_deeply( + $foo->pack, + { + __CLASS__ => 'Foo', + number => 10, + string => 'foo', + boolean => 1, + float => 10.5, + array => [ 1 .. 10 ], + hash => { map { $_ => undef } ( 1 .. 10 ) }, + object => { + __CLASS__ => 'Foo', + number => 2 + }, + }, + '... got the right frozen class' + ); +} + +{ + my $foo = Foo->unpack( + { + __CLASS__ => 'Foo', + number => 10, + string => 'foo', + boolean => 1, + float => 10.5, + array => [ 1 .. 10 ], + hash => { map { $_ => undef } ( 1 .. 10 ) }, + object => { + __CLASS__ => 'Foo', + number => 2 + }, + } + ); + isa_ok( $foo, 'Foo' ); + + is( $foo->number, 10, '... got the right number' ); + is( $foo->string, 'foo', '... got the right string' ); + ok( $foo->boolean, '... got the right boolean' ); + is( $foo->float, 10.5, '... got the right float' ); + is_deeply( $foo->array, [ 1 .. 10 ], '... got the right array' ); + is_deeply( + $foo->hash, + { map { $_ => undef } ( 1 .. 10 ) }, + '... got the right hash' + ); + + isa_ok( $foo->object, 'Foo' ); + is( $foo->object->number, 2, + '... got the right number (in the embedded object)' ); +} + + +{ + + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use MooseX::Storage; + + use Scalar::Util 'looks_like_number'; + + with Storage; + + subtype 'Natural' + => as 'Int' + => where { $_ > 0 }; + + subtype 'HalfNum' + => as 'Num' + => where { "$_" =~ /\.5$/ }; + + subtype 'FooString' + => as 'Str' + => where { lc($_) eq 'foo' }; + + subtype 'IntArray' + => as 'ArrayRef' + => where { scalar grep { looks_like_number($_) } @{$_} }; + + subtype 'UndefHash' + => as 'HashRef' + => where { scalar grep { !defined($_) } values %{$_} }; + + has 'number' => ( is => 'ro', isa => 'Maybe[Natural]' ); + has 'string' => ( is => 'ro', isa => 'Maybe[FooString]' ); + has 'float' => ( is => 'ro', isa => 'Maybe[HalfNum]' ); + has 'array' => ( is => 'ro', isa => 'Maybe[IntArray]' ); + has 'hash' => ( is => 'ro', isa => 'Maybe[UndefHash]' ); + has 'object' => ( is => 'ro', isa => 'Maybe[Foo]' ); +} + +{ + my $foo = Foo->new( + number => 10, + string => 'foo', + float => 10.5, + array => [ 1 .. 10 ], + hash => { map { $_ => undef } ( 1 .. 10 ) }, + object => Foo->new( number => 2 ), + ); + isa_ok( $foo, 'Foo' ); + + is_deeply( + $foo->pack, + { + __CLASS__ => 'Foo', + number => 10, + string => 'foo', + float => 10.5, + array => [ 1 .. 10 ], + hash => { map { $_ => undef } ( 1 .. 10 ) }, + object => { + __CLASS__ => 'Foo', + number => 2 + }, + }, + '... got the right frozen class' + ); +} + +{ + my $foo = Foo->unpack( + { + __CLASS__ => 'Foo', + number => 10, + string => 'foo', + float => 10.5, + array => [ 1 .. 10 ], + hash => { map { $_ => undef } ( 1 .. 10 ) }, + object => { + __CLASS__ => 'Foo', + number => 2 + }, + } + ); + isa_ok( $foo, 'Foo' ); + + is( $foo->number, 10, '... got the right number' ); + is( $foo->string, 'foo', '... got the right string' ); + is( $foo->float, 10.5, '... got the right float' ); + is_deeply( $foo->array, [ 1 .. 10 ], '... got the right array' ); + is_deeply( + $foo->hash, + { map { $_ => undef } ( 1 .. 10 ) }, + '... got the right hash' + ); + + isa_ok( $foo->object, 'Foo' ); + is( $foo->object->number, 2, + '... got the right number (in the embedded object)' ); +}