diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index 8d14072..41ade8b 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -213,7 +213,8 @@ my %OBJECT_HANDLERS = ( ); -my %TYPES = ( +my %TYPES; +%TYPES = ( # NOTE: # we need to make sure that we properly numify the numbers # before and after them being futzed with, because some of @@ -225,23 +226,20 @@ my %TYPES = ( 'Value' => { expand => sub { shift }, collapse => sub { shift } }, 'Bool' => { expand => sub { shift }, collapse => sub { shift } }, # These are the trickier ones, (see notes) - # NOTE: - # Because we are nice guys, we will check - # your ArrayRef and/or HashRef one level - # down and inflate any objects we find. - # But this is where it ends, it is too - # expensive to try and do this any more - # recursively, when it is probably not - # necessary in most of the use cases. - # However, if you need more then this, subtype - # and add a custom handler. 'ArrayRef' => { expand => sub { my ( $array, @args ) = @_; foreach my $i (0 .. $#{$array}) { - next unless ref($array->[$i]) eq 'HASH' - && exists $array->[$i]->{$CLASS_MARKER}; - $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i], @args); + if (ref($array->[$i]) eq 'HASH') { + $array->[$i] = exists($array->[$i]{$CLASS_MARKER}) + ? $TYPES{ $array->[$i]{$CLASS_MARKER} } + ? $TYPES{ $array->[$i]{$CLASS_MARKER} }{expand}->($array->[$i], @args) + : $OBJECT_HANDLERS{expand}->($array->[$i], @args) + : $TYPES{HashRef}{expand}->($array->[$i], @args); + } + elsif (ref($array->[$i]) eq 'ARRAY') { + $array->[$i] = $TYPES{ArrayRef}{expand}->($array->[$i], @args); + } } $array; }, @@ -252,7 +250,9 @@ my %TYPES = ( # otherwise it will affect the # other real version. [ map { - blessed($_) + $TYPES{ref($_)} + ? $TYPES{ref($_)}->{collapse}->($_, @args) + : blessed($_) ? $OBJECT_HANDLERS{collapse}->($_, @args) : $_ } @$array ] @@ -262,9 +262,16 @@ my %TYPES = ( expand => sub { my ( $hash, @args ) = @_; foreach my $k (keys %$hash) { - next unless ref($hash->{$k}) eq 'HASH' - && exists $hash->{$k}->{$CLASS_MARKER}; - $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}, @args); + if (ref($hash->{$k}) eq 'HASH' ) { + $hash->{$k} = exists($hash->{$k}->{$CLASS_MARKER}) + ? $TYPES{ $hash->{$k}->{$CLASS_MARKER} } + ? $TYPES{ $hash->{$k}->{$CLASS_MARKER} }{expand}->($hash->{$k}, @args) + : $OBJECT_HANDLERS{expand}->($hash->{$k}, @args) + : $TYPES{HashRef}{expand}->($hash->{$k}, @args); + } + elsif (ref($hash->{$k}) eq 'ARRAY') { + $hash->{$k} = $TYPES{ArrayRef}{expand}->($hash->{$k}, @args); + } } $hash; }, @@ -275,9 +282,11 @@ my %TYPES = ( # otherwise it will affect the # other real version. +{ map { - blessed($hash->{$_}) - ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args)) - : ($_ => $hash->{$_}) + $TYPES{ref($hash->{$_})} + ? ($_ => $TYPES{ref($hash->{$_})}{collapse}->($hash->{$_}, @args)) + : blessed($hash->{$_}) + ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args)) + : ($_ => $hash->{$_}) } keys %$hash } } }, @@ -292,6 +301,13 @@ my %TYPES = ( #} ); +%TYPES = ( + %TYPES, + 'HASH' => $TYPES{HashRef}, + 'ARRAY' => $TYPES{ArrayRef}, +); + + sub add_custom_type_handler { my ($self, $type_name, %handlers) = @_; (exists $handlers{expand} && exists $handlers{collapse}) diff --git a/t/003_basic_w_embedded_objects.t b/t/003_basic_w_embedded_objects.t index 30f5e4c..958b636 100644 --- a/t/003_basic_w_embedded_objects.t +++ b/t/003_basic_w_embedded_objects.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 46; +use Test::More tests => 57; use Test::Deep; =pod @@ -42,6 +42,22 @@ ArrayRef and HashRef type handlers. is => 'ro', isa => 'HashRef[Bar]' ); + + package Qux; + use Moose; + use MooseX::Storage; + + with Storage; + + has foos_aa => ( is => 'ro', isa => 'ArrayRef[ArrayRef[Foo]]' ); + has foos_ah => ( is => 'ro', isa => 'ArrayRef[HashRef[Foo]]' ); + has foos_ha => ( is => 'ro', isa => 'HashRef[ArrayRef[Foo]]' ); + has foos_hh => ( is => 'ro', isa => 'HashRef[HashRef[Foo]]' ); + + has bazs_aa => ( is => 'ro', isa => 'ArrayRef[ArrayRef[Baz]]' ); + has bazs_ah => ( is => 'ro', isa => 'ArrayRef[HashRef[Baz]]' ); + has bazs_ha => ( is => 'ro', isa => 'HashRef[ArrayRef[Baz]]' ); + has bazs_hh => ( is => 'ro', isa => 'HashRef[HashRef[Baz]]' ); } { @@ -133,3 +149,520 @@ ArrayRef and HashRef type handlers. is($baz->bars->{$k}->number, $k, "... got the right number ($k) in the Bar in Baz"); } } + + +{ + my $qux = Qux->new( + foos_aa => [ + map { + [ + map { + Foo->new( + bars => [ + map { Bar->new( number => $_ ) } ( 1 .. 10 ) + ] + ) + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + ], + + foos_ah => [ + map { + { + map { + $_ => Foo->new( + bars => [ + map { Bar->new( number => $_ ) } ( 1 .. 10 ) + ] + ) + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + ], + + foos_ha => { + map { + $_ => [ + map { + Foo->new( + bars => [ + map { Bar->new( number => $_ ) } ( 1 .. 10 ) + ] + ) + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + }, + + foos_hh => { + map { + $_ => { + map { + $_ => Foo->new( + bars => [ + map { Bar->new( number => $_ ) } ( 1 .. 10 ) + ] + ) + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + }, + + bazs_aa => [ + map { + [ + map { + Baz->new( + bars => { + map { ( $_ => Bar->new( number => $_ ) ) } + ( 1 .. 10 ) + } + ) + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + ], + + bazs_ah => [ + map { + { + map { + $_ => Baz->new( + bars => { + map { ( $_ => Bar->new( number => $_ ) ) } + ( 1 .. 10 ) + } + ) + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + ], + + bazs_ha => { + map { + $_ => [ + map { + Baz->new( + bars => { + map { ( $_ => Bar->new( number => $_ ) ) } + ( 1 .. 10 ) + } + ) + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + }, + + bazs_hh => { + map { + $_ => { + map { + $_ => Baz->new( + bars => { + map { ( $_ => Bar->new( number => $_ ) ) } + ( 1 .. 10 ) + } + ) + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + }, + + ); + isa_ok( $qux, 'Qux' ); + + cmp_deeply( + $qux->pack, + { + __CLASS__ => 'Qux', + foos_aa => [ + map { + [ + map { + { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + ], + + foos_ah => [ + map { + { + map { + $_ => { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + ], + + foos_ha => { + map { + $_ => [ + map { + { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + }, + + foos_hh => { + map { + $_ => { + map { + $_ => { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + }, + + bazs_aa => [ + map { + [ + map { + { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + ], + + bazs_ah => [ + map { + { + map { + $_ => { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + ], + + bazs_ha => { + map { + $_ => [ + map { + { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + }, + + bazs_hh => { + map { + $_ => { + map { + $_ => { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + }, + }, + '... got the right frozen class' + ); +} + +{ + my $qux = Qux->unpack( + { + __CLASS__ => 'Qux', + foos_aa => [ + map { + [ + map { + { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + ], + + foos_ah => [ + map { + { + map { + $_ => { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + ], + + foos_ha => { + map { + $_ => [ + map { + { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + }, + + foos_hh => { + map { + $_ => { + map { + $_ => { + __CLASS__ => 'Foo', + bars => [ + map { + { + __CLASS__ => 'Bar', + number => $_, + } + } ( 1 .. 10 ) + ], + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + }, + + bazs_aa => [ + map { + [ + map { + { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + ], + + bazs_ah => [ + map { + { + map { + $_ => { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + ], + + bazs_ha => { + map { + $_ => [ + map { + { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + ] + } ( 1 .. 10 ) + }, + + bazs_hh => { + map { + $_ => { + map { + $_ => { + __CLASS__ => 'Baz', + bars => { + map { + ( + $_ => { + __CLASS__ => 'Bar', + number => $_, + } + ) + } ( 1 .. 10 ) + }, + } + } ( 1 .. 10 ) + } + } ( 1 .. 10 ) + }, + } + ); + isa_ok( $qux, 'Qux' ); + + + my $deep_check_isa; + $deep_check_isa = sub { + my ($what) = @_; + + if ( ref $what eq 'HASH' ) { + subtest 'HASH' => sub { + foreach my $k ( keys %{$what} ) { + $deep_check_isa->( $what->{$k} ); + } + }; + } + elsif ( ref $what eq 'ARRAY' ) { + subtest 'ARRAY' => sub { + foreach my $i ( 1 .. scalar @{$what} ) { + $deep_check_isa->( $what->[ $i - 1 ] ); + } + }; + } + elsif ( ref $what eq 'Foo' ) { + foreach my $i ( 1 .. scalar @{ $what->bars } ) { + isa_ok( $what->bars->[ $i - 1 ], 'Bar' ); + is( $what->bars->[ $i - 1 ]->number, + $i, "... got the right number ($i) in the Bar" ); + } + } + elsif ( ref $what eq 'Baz' ) { + foreach my $k ( keys %{ $what->bars } ) { + isa_ok( $what->bars->{$k}, 'Bar' ); + is( $what->bars->{$k}->number, + $k, "... got the right number ($k) in the Bar" ); + } + } + }; + + for my $test ( + 'foos_aa', 'foos_ah', 'foos_ha', 'foos_hh', + 'bazs_aa', 'bazs_ah', 'bazs_ha', 'bazs_hh', + ) + { + subtest $test => sub { $deep_check_isa->( $qux->$test ) }; + } +} diff --git a/t/080_basic_json_boolean.t b/t/080_basic_json_boolean.t index e8ff86b..80517f8 100644 --- a/t/080_basic_json_boolean.t +++ b/t/080_basic_json_boolean.t @@ -11,14 +11,14 @@ use MooseX::Storage::Engine; MooseX::Storage::Engine->add_custom_type_handler( 'JSON::PP::Boolean' => ( - expand => sub { $_[0] ? JSON::PP::true : JSON::PP::false }, - collapse => sub { "$_[0]" }, + expand => sub { $_[0]{__value} ? JSON::PP::true : JSON::PP::false }, + collapse => sub { { __CLASS__ => 'JSON::PP::Boolean', __value => "$_[0]" } }, ) ); # support for this was tentatively added in v0.49, but there were unwanted # side effects, and the tests in this file do not pass even with those changes. -local $TODO = 'ability to pack/unpack nested objects is not quite functional'; +#local $TODO = 'ability to pack/unpack nested objects is not quite functional'; { package Foo; @@ -36,12 +36,18 @@ local $TODO = 'ability to pack/unpack nested objects is not quite functional'; is => 'ro', isa => 'ArrayRef[JSON::PP::Boolean]' ); + + has 'hash_bools' => ( + is => 'ro', + isa => 'HashRef[JSON::PP::Boolean]' + ); } { my $foo = Foo->new( one_bool => JSON::PP::true, many_bools => [ JSON::PP::false, JSON::PP::true ], + hash_bools => { true => JSON::PP::true, false => JSON::PP::false }, ); isa_ok($foo, 'Foo'); @@ -57,8 +63,9 @@ local $TODO = 'ability to pack/unpack nested objects is not quite functional'; $pack_result, { __CLASS__ => 'Foo', - one_bool => 1, - many_bools => [ 0, 1 ], + one_bool => { __CLASS__ => 'JSON::PP::Boolean', __value => 1 }, + many_bools => [ { __CLASS__ => 'JSON::PP::Boolean', __value => 0 } , { __CLASS__ => 'JSON::PP::Boolean', __value => 1 } ], + hash_bools => { false => { __CLASS__ => 'JSON::PP::Boolean', __value => 0 } , true => { __CLASS__ => 'JSON::PP::Boolean', __value => 1 } }, }, '... got the right frozen structure' ); @@ -71,8 +78,9 @@ local $TODO = 'ability to pack/unpack nested objects is not quite functional'; $foo = Foo->unpack( { __CLASS__ => 'Foo', - one_bool => 1, - many_bools => [ 0, 1 ], + one_bool => { __CLASS__ => 'JSON::PP::Boolean', __value => 1 }, + many_bools => [ { __CLASS__ => 'JSON::PP::Boolean', __value => 0 } , { __CLASS__ => 'JSON::PP::Boolean', __value => 1 } ], + hash_bools => { false => { __CLASS__ => 'JSON::PP::Boolean', __value => 0 } , true => { __CLASS__ => 'JSON::PP::Boolean', __value => 1 } }, }, ) }, @@ -87,14 +95,24 @@ local $TODO = 'ability to pack/unpack nested objects is not quite functional'; 'one_bool attr is correct', ); + cmp_deeply( $foo->many_bools, [ - all(type('JSON::PP::Boolean'), JSON::PP::false), - all(type('JSON::PP::Boolean'), JSON::PP::true), + all(is_type(class_type('JSON::PP::Boolean')), JSON::PP::false), + all(is_type(class_type('JSON::PP::Boolean')), JSON::PP::true), ], 'many_bools attr is correct', ); + + cmp_deeply( + $foo->hash_bools, + { + false => all(is_type(class_type('JSON::PP::Boolean')), JSON::PP::false), + true => all(is_type(class_type('JSON::PP::Boolean')), JSON::PP::true), + }, + 'hash_bools attr is correct', + ); }; }