From: Stevan Little Date: Fri, 30 Mar 2007 21:14:55 +0000 (+0000) Subject: adding test with subtypes X-Git-Tag: 0_02~27 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Storage.git;a=commitdiff_plain;h=e1bb45ff93e1eaba58f34d889f58c62c80ca0314 adding test with subtypes --- diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index 1c66577..91125c4 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -41,11 +41,6 @@ sub expand_attribute { sub collapse_attribute_value { my ($self, $attr) = @_; my $value = $attr->get_value($self->object); - # TODO: - # we want to explicitly disallow - # cycles here, because the base - # storage engine does not support - # them if (defined $value && $attr->has_type_constraint) { my $type_converter = $self->match_type($attr->type_constraint); (defined $type_converter) @@ -57,10 +52,6 @@ sub collapse_attribute_value { sub expand_attribute_value { my ($self, $attr, $value) = @_; - # TODO: - # we need to check $value here to - # make sure that we do not have - # a cycle here. if (defined $value && $attr->has_type_constraint) { my $type_converter = $self->match_type($attr->type_constraint); $value = $type_converter->{expand}->($value); @@ -93,35 +84,61 @@ my %TYPES = ( collapse => sub { my $obj = shift; ($obj->can('does') && $obj->does('MooseX::Storage::Basic')) - || confess "Bad object ($obj) does not do MooseX::Storage::Base role"; + || confess "Bad object ($obj) does not do MooseX::Storage::Basic role"; $obj->pack(); }, - } + }, + # NOTE: + # The sanity of enabling this feature by + # default is very questionable. + # - SL + #'CodeRef' => { + # expand => sub {}, # use eval ... + # collapse => sub {}, # use B::Deparse ... + #} ); sub match_type { my ($self, $type_constraint) = @_; - return $TYPES{$type_constraint->name} if exists $TYPES{$type_constraint->name}; + + # this should handle most type usages + # since they they are usually just + # the standard set of built-ins + return $TYPES{$type_constraint->name} + if exists $TYPES{$type_constraint->name}; + + # the next possibility is they are + # a subtype of the built-in types, + # in which case this will DWIM in + # most cases. It is probably not + # 100% ideal though, but until I + # come up with a decent test case + # it will do for now. foreach my $type (keys %TYPES) { return $TYPES{$type} if $type_constraint->is_subtype_of($type); } - # TODO: - # from here we can expand this to support the following: - # - if it is subtype of Ref - # -- if it is a subtype of Object - # --- treat it like an object - # -- else - # --- treat it like any other Ref - # - else - # -- if it is a subtype of Num or Str - # --- treat it like Num or Str - # -- else - # --- pass it on - # this should cover 80% of all use cases - - # CHRIS: To cover the last 20% we need a way - # for people to extend this process. + + # NOTE: + # the reason the above will work has to + # do with the fact that custom subtypes + # are mostly used for validation of + # the guts of a type, and not for some + # weird structural thing which would + # need to be accomidated by the serializer. + # Of course, mst or phaylon will probably + # do something to throw this assumption + # totally out the door ;) + # - SL + + + # To cover the last possibilities we + # need a way for people to extend this + # process. Which they can do by subclassing + # this class and overriding the method + # below to handle things. + my $match = $self->custom_type_match($type_constraint); + return $match if defined $match; # NOTE: # if this method hasnt returned by now @@ -130,6 +147,11 @@ sub match_type { confess "Cannot handle type constraint (" . $type_constraint->name . ")"; } +sub custom_type_match { + return; + # my ($self, $type_constraint) = @_; +} + 1; __END__ diff --git a/t/001_basic.t b/t/001_basic.t index 2a4026c..ea761ab 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -22,7 +22,7 @@ BEGIN { has 'float' => ( is => 'ro', isa => 'Num' ); has 'array' => ( is => 'ro', isa => 'ArrayRef' ); has 'hash' => ( is => 'ro', isa => 'HashRef' ); - has 'object' => ( is => 'ro', isa => 'Object' ); + has 'object' => ( is => 'ro', isa => 'Foo' ); } { diff --git a/t/002_basic_w_subtypes.t b/t/002_basic_w_subtypes.t new file mode 100644 index 0000000..ee78d14 --- /dev/null +++ b/t/002_basic_w_subtypes.t @@ -0,0 +1,110 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; + +BEGIN { + use_ok('MooseX::Storage'); +} + +{ + + 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 => 'Natural' ); + has 'string' => ( is => 'ro', isa => 'FooString' ); + has 'float' => ( is => 'ro', isa => 'HalfNum' ); + has 'array' => ( is => 'ro', isa => 'IntArray' ); + has 'hash' => ( is => 'ro', isa => 'UndefHash' ); + has 'object' => ( is => 'ro', isa => '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)' ); +}