adding simple checksum role

[gitmo/MooseX-Storage.git] / lib / MooseX / Storage / Engine.pm

diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm
index 50294c2..430634a 100644 (file)
--- a/lib/MooseX/Storage/Engine.pm
+++ b/lib/MooseX/Storage/Engine.pm
@@ -2,7 +2,7 @@
 package MooseX::Storage::Engine;
 use Moose;
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 # the class marker when 
 # serializing an object. 
@@ -33,18 +33,21 @@ sub collapse_object {
        $self->seen->{$self->object} = undef;
        
     $self->map_attributes('collapse_attribute');
-    $self->storage->{$CLASS_MARKER} = $self->object->meta->name;    
+    $self->storage->{$CLASS_MARKER} = $self->object->meta->identifier;    
        return $self->storage;
 }
 
 sub expand_object {
-    my ($self, $data) = @_;
+    my ($self, $data, %options) = @_;
+    
+    $options{check_version}   = 1 unless exists $options{check_version};
+    $options{check_authority} = 1 unless exists $options{check_authority};   
     
        # NOTE:
        # mark the root object as seen ...
        $self->seen->{$data} = undef;    
     
-    $self->map_attributes('expand_attribute', $data);
+    $self->map_attributes('expand_attribute', $data, \%options);
        return $self->storage;    
 }
 
@@ -56,8 +59,8 @@ sub collapse_attribute {
 }
 
 sub expand_attribute {
-    my ($self, $attr, $data)  = @_;
-    $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}) || return;
+    my ($self, $attr, $data, $options)  = @_;
+    $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}, $options) || return;
 }
 
 sub collapse_attribute_value {
@@ -68,7 +71,7 @@ sub collapse_attribute_value {
        # this might not be enough, we might 
        # need to make it possible for the 
        # cycle checker to return the value
-    $self->check_for_cycle_in_collapse($value) 
+    $self->check_for_cycle_in_collapse($attr, $value) 
         if ref $value;
        
     if (defined $value && $attr->has_type_constraint) {
@@ -81,16 +84,16 @@ sub collapse_attribute_value {
 }
 
 sub expand_attribute_value {
-    my ($self, $attr, $value)  = @_;
+    my ($self, $attr, $value, $options)  = @_;
 
        # NOTE:
        # (see comment in method above ^^)
-    $self->check_for_cycle_in_expansion($value) 
+    $self->check_for_cycle_in_expansion($attr, $value) 
         if ref $value;    
     
     if (defined $value && $attr->has_type_constraint) {
         my $type_converter = $self->find_type_handler($attr->type_constraint);
-        $value = $type_converter->{expand}->($value);
+        $value = $type_converter->{expand}->($value, $options);
     }
        return $value;
 }
@@ -103,16 +106,20 @@ sub expand_attribute_value {
 # anyway.
 
 sub check_for_cycle_in_collapse {
-    my ($self, $value) = @_;
+    my ($self, $attr, $value) = @_;
     (!exists $self->seen->{$value})
-        || confess "Basic Engine does not support cycles";
+        || confess "Basic Engine does not support cycles in class(" 
+                 . ($attr->associated_class->name) . ").attr("
+                 . ($attr->name) . ") with $value";
     $self->seen->{$value} = undef;
 }
 
 sub check_for_cycle_in_expansion {
-    my ($self, $value) = @_;
+    my ($self, $attr, $value) = @_;
     (!exists $self->seen->{$value})
-        || confess "Basic Engine does not support cycles";
+    || confess "Basic Engine does not support cycles in class(" 
+             . ($attr->associated_class->name) . ").attr("
+             . ($attr->name) . ") with $value";
     $self->seen->{$value} = undef;
 }
 
@@ -140,15 +147,50 @@ sub map_attributes {
 # below, so I need easy access 
 my %OBJECT_HANDLERS = (
     expand => sub {
-        my $data = shift;   
+        my ($data, $options) = @_;   
         (exists $data->{$CLASS_MARKER})
             || confess "Serialized item has no class marker";
-        $data->{$CLASS_MARKER}->unpack($data);
+        # check the class more thoroughly here ...
+        my ($class, $version, $authority) = (split '-' => $data->{$CLASS_MARKER});
+        my $meta = eval { $class->meta };
+        confess "Class ($class) is not loaded, cannot unpack" if $@;     
+        
+        if ($options->{check_version}) {
+            my $meta_version = $meta->version;
+            if (defined $meta_version && $version) {            
+                if ($options->{check_version} eq 'allow_less_than') {
+                    ($meta_version <= $version)
+                        || confess "Class ($class) versions is not less than currently available." 
+                                 . " got=($version) available=($meta_version)";                
+                }
+                elsif ($options->{check_version} eq 'allow_greater_than') {
+                    ($meta->version >= $version)
+                        || confess "Class ($class) versions is not greater than currently available." 
+                                 . " got=($version) available=($meta_version)";                
+                }            
+                else {
+                    ($meta->version == $version)
+                        || confess "Class ($class) versions don't match." 
+                                 . " got=($version) available=($meta_version)";
+                }
+            }
+        }
+        
+        if ($options->{check_authority}) {
+            my $meta_authority = $meta->authority;
+            ($meta->authority eq $authority)
+                || confess "Class ($class) authorities don't match." 
+                         . " got=($authority) available=($meta_authority)"
+                if defined $meta_authority && defined $authority;            
+        }
+            
+        # all is well ...
+        $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->can('does') && $obj->does('MooseX::Storage::Basic'))
+#            || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
         $obj->pack();
     },
 );