some thoughts and hacks on type handling,.. this probably needs some work

diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm
index 91125c4..0eb6e2c 100644 (file)
--- a/lib/MooseX/Storage/Engine.pm
+++ b/lib/MooseX/Storage/Engine.pm
@@ -68,26 +68,72 @@ sub map_attributes {
     } ($self->object || $self->class)->meta->compute_all_applicable_attributes;
 }
 
+## ------------------------------------------------------------------
+## Everything below here might need some re-thinking ...
+## ------------------------------------------------------------------
+
+# NOTE:
+# these are needed by the 
+# ArrayRef and HashRef handlers
+# below, so I need easy access 
+my %OBJECT_HANDLERS = (
+    expand => sub {
+        my $data = shift;   
+        (exists $data->{'__class__'})
+            || confess "Serialized item has no class marker";
+        $data->{'__class__'}->unpack($data);
+    },
+    collapse => sub {
+        my $obj = shift;
+        ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
+            || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
+        $obj->pack();
+    },
+);
+
+
 my %TYPES = (
     'Int'      => { expand => sub { shift }, collapse => sub { shift } },
     'Num'      => { expand => sub { shift }, collapse => sub { shift } },
     'Str'      => { expand => sub { shift }, collapse => sub { shift } },
-    'ArrayRef' => { expand => sub { shift }, collapse => sub { shift } },
-    'HashRef'  => { expand => sub { shift }, collapse => sub { shift } },
-    'Object'   => {
+    'ArrayRef' => { 
+        # FIXME:
+        # these should also probably be
+        # recursive as well, so they 
+        # can handle arbitrarily deep
+        # arrays and such. Or perhaps
+        # we force the user to handle 
+        # the types in a custom way. 
+        # This would require a more 
+        # sophisticated way of handling
+        # this %TYPES hash.
         expand => sub {
-            my $data = shift;   
-            (exists $data->{'__class__'})
-                || confess "Serialized item has no class marker";
-            $data->{'__class__'}->unpack($data);
-        },
-        collapse => sub {
-            my $obj = shift;
-            ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
-                || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
-            $obj->pack();
-        },
+            my $array = shift;
+            foreach my $i (0 .. $#{$array}) {
+                next unless ref($array->[$i]) eq 'HASH' 
+                         && exists $array->[$i]->{'__class__'};
+                $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i])
+            }
+            $array;
+        }, 
+        collapse => sub { 
+            my $array = shift;   
+            # NOTE:         
+            # we need to make a copy cause
+            # otherwise it will affect the 
+            # other real version.
+            [ map {
+                blessed($_)
+                    ? $OBJECT_HANDLERS{collapse}->($_)
+                    : $_
+            } @$array ] 
+        } 
+    },
+    'HashRef'  => { 
+        expand   => sub { shift }, 
+        collapse => sub { shift } 
     },
+    'Object'   => \%OBJECT_HANDLERS,
     # NOTE:
     # The sanity of enabling this feature by 
     # default is very questionable.
@@ -137,7 +183,7 @@ sub match_type {
        # 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);
+       my $match = $self->_custom_type_match($type_constraint);
        return $match if defined $match;
 
     # NOTE:
@@ -147,7 +193,7 @@ sub match_type {
     confess "Cannot handle type constraint (" . $type_constraint->name . ")";    
 }
 
-sub custom_type_match {
+sub _custom_type_match {
     return;
     # my ($self, $type_constraint) = @_;
 }

diff --git a/t/001_basic.t b/t/001_basic.t
index ea761ab..06c343c 100644 (file)
--- a/t/001_basic.t
+++ b/t/001_basic.t
@@ -15,7 +15,7 @@ BEGIN {
     use Moose;
     use MooseX::Storage;
 
-    with Storage();
+    with Storage;
 
     has 'number' => ( is => 'ro', isa => 'Int' );
     has 'string' => ( is => 'ro', isa => 'Str' );

diff --git a/t/002_basic_w_subtypes.t b/t/002_basic_w_subtypes.t
index ee78d14..3806d02 100644 (file)
--- a/t/002_basic_w_subtypes.t
+++ b/t/002_basic_w_subtypes.t
@@ -18,7 +18,7 @@ BEGIN {
 
     use Scalar::Util 'looks_like_number';
 
-    with Storage();    
+    with Storage;    
     
     subtype 'Natural' 
         => as 'Int'

diff --git a/t/003_basic_w_embedded_objects.t b/t/003_basic_w_embedded_objects.t
new file mode 100644 (file)
index 0000000..de33dff
--- /dev/null
+++ b/t/003_basic_w_embedded_objects.t
@@ -0,0 +1,76 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+    use_ok('MooseX::Storage');
+}
+
+{
+    package Bar;
+    use Moose;
+    use MooseX::Storage;
+
+    with Storage;
+    
+    has 'baz' => (is => 'ro', isa => 'Int');
+    
+    package Foo;
+    use Moose;
+    use MooseX::Storage;
+
+    with Storage;    
+
+    has 'bars' => ( 
+        is  => 'ro', 
+        isa => 'ArrayRef' 
+    );
+}
+
+{
+    my $foo = Foo->new(
+        bars => [ map { Bar->new(baz => $_) } (1 .. 10) ]
+    );
+    isa_ok( $foo, 'Foo' );
+    
+    is_deeply(
+        $foo->pack,
+        {
+            __class__ => 'Foo',
+            bars      => [ 
+                map {
+                  {
+                      __class__ => 'Bar',
+                      baz       => $_,
+                  }  
+                } (1 .. 10)
+            ],           
+        },
+        '... got the right frozen class'
+    );
+}
+
+{
+    my $foo = Foo->unpack(
+        {
+            __class__ => 'Foo',
+            bars      => [ 
+                map {
+                  {
+                      __class__ => 'Bar',
+                      baz       => $_,
+                  }  
+                } (1 .. 10)
+            ],           
+        }      
+    );
+    isa_ok( $foo, 'Foo' );
+
+    foreach my $i (1 .. scalar @{$foo->bars}) {
+        isa_ok($foo->bars->[$i - 1], 'Bar');
+        is($foo->bars->[$i - 1]->baz, $i, "... got the right baz ($i) in the Bar in Foo");
+    }
+}