adding in version and authority checks

diff --git a/Changes b/Changes
index 629c2f3..421374d 100644 (file)
--- a/Changes
+++ b/Changes
@@ -3,6 +3,10 @@ Revision history for MooseX-Storage
 0.02 
     * MooseX::Storage::Engine
       - better error reporting when cycles are found
+      - class names are now stored as the full identifier
+        (<class>-<version>-<authority>) and are checked
+        when they are expanded.
+        - added docs and tests for this
 
 0.01  Mon. April 30, 2007
     This was Chris's idea originally (blame him), and 

diff --git a/MANIFEST b/MANIFEST
index 5489d51..a268d68 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -20,6 +20,7 @@ t/001_basic.t
 t/002_basic_w_subtypes.t
 t/003_basic_w_embedded_objects.t
 t/004_w_cycles.t
+t/005_w_versions_and_authority_check.t
 t/010_basic_json.t
 t/020_basic_yaml.t
 t/100_io.t

diff --git a/lib/MooseX/Storage.pm b/lib/MooseX/Storage.pm
index 6d7f6e3..57a3347 100644 (file)
--- a/lib/MooseX/Storage.pm
+++ b/lib/MooseX/Storage.pm
@@ -64,6 +64,8 @@ MooseX::Storage - An serialization framework for Moose classes
   use Moose;
   use MooseX::Storage;
   
+  our $VERSION = '0.01';
+  
   with Storage('format' => 'JSON', 'io' => 'File');
   
   has 'x' => (is => 'rw', isa => 'Int');
@@ -77,20 +79,20 @@ MooseX::Storage - An serialization framework for Moose classes
   ## object in perl data structures
   
   # pack the class into a hash
-  $p->pack(); # { __CLASS__ => 'Point', x => 10, y => 10 }
+  $p->pack(); # { __CLASS__ => 'Point-0.01', x => 10, y => 10 }
   
   # unpack the hash into a class
-  my $p2 = Point->unpack({ __CLASS__ => 'Point', x => 10, y => 10 });
+  my $p2 = Point->unpack({ __CLASS__ => 'Point-0.01', x => 10, y => 10 });
 
   ## methods to freeze/thaw into 
   ## a specified serialization format
   ## (in this case JSON)
   
   # pack the class into a JSON string
-  $p->freeze(); # { "__CLASS__" : "Point", "x" : 10, "y" : 10 }
+  $p->freeze(); # { "__CLASS__" : "Point-0.01", "x" : 10, "y" : 10 }
   
   # unpack the JSON string into a class
-  my $p2 = Point->thaw('{ "__CLASS__" : "Point", "x" : 10, "y" : 10 }');  
+  my $p2 = Point->thaw('{ "__CLASS__" : "Point-0.01", "x" : 10, "y" : 10 }');  
 
   ## methods to load/store a class 
   ## on the file system

diff --git a/lib/MooseX/Storage/Basic.pm b/lib/MooseX/Storage/Basic.pm
index a6bf51e..a0745b2 100644 (file)
--- a/lib/MooseX/Storage/Basic.pm
+++ b/lib/MooseX/Storage/Basic.pm
@@ -34,6 +34,8 @@ MooseX::Storage::Basic - The simplest level of serialization
   use Moose;
   use MooseX::Storage;
   
+  our $VERSION = '0.01';
+  
   with Storage;
   
   has 'x' => (is => 'rw', isa => 'Int');
@@ -47,10 +49,10 @@ MooseX::Storage::Basic - The simplest level of serialization
   ## object in perl data structures
   
   # pack the class into a hash
-  $p->pack(); # { __CLASS__ => 'Point', x => 10, y => 10 }
+  $p->pack(); # { __CLASS__ => 'Point-0.01', x => 10, y => 10 }
   
   # unpack the hash into a class
-  my $p2 = Point->unpack({ __CLASS__ => 'Point', x => 10, y => 10 });
+  my $p2 = Point->unpack({ __CLASS__ => 'Point-0.01', x => 10, y => 10 });
 
 =head1 DESCRIPTION
 

diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm
index ec96c70..ca54b40 100644 (file)
--- a/lib/MooseX/Storage/Engine.pm
+++ b/lib/MooseX/Storage/Engine.pm
@@ -33,7 +33,7 @@ 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;
 }
 
@@ -106,7 +106,7 @@ sub check_for_cycle_in_collapse {
     my ($self, $attr, $value) = @_;
     (!exists $self->seen->{$value})
         || confess "Basic Engine does not support cycles in class(" 
-                 . ($attr->associated_metaclass->name) . ").attr("
+                 . ($attr->associated_class->name) . ").attr("
                  . ($attr->name) . ") with $value";
     $self->seen->{$value} = undef;
 }
@@ -115,7 +115,7 @@ sub check_for_cycle_in_expansion {
     my ($self, $attr, $value) = @_;
     (!exists $self->seen->{$value})
     || confess "Basic Engine does not support cycles in class(" 
-             . ($attr->associated_metaclass->name) . ").attr("
+             . ($attr->associated_class->name) . ").attr("
              . ($attr->name) . ") with $value";
     $self->seen->{$value} = undef;
 }
@@ -147,7 +147,20 @@ my %OBJECT_HANDLERS = (
         my $data = shift;   
         (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 $@;
+        ($meta->version eq $version)
+            || confess "Class ($class) versions don't match." 
+                     . " got=($version) available=(" . ($meta->version || '') . ")"
+            if defined $version;
+        ($meta->authority eq $authority)
+            || confess "Class ($class) authorities don't match." 
+                     . " got=($authority) available=(" . ($meta->authority || '') . ")"
+            if defined $authority;            
+        # all is well ...
+        $class->unpack($data);
     },
     collapse => sub {
         my $obj = shift;

diff --git a/t/005_w_versions_and_authority_check.t b/t/005_w_versions_and_authority_check.t
new file mode 100644 (file)
index 0000000..8d99b02
--- /dev/null
+++ b/t/005_w_versions_and_authority_check.t
@@ -0,0 +1,115 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+use Test::Exception;
+
+BEGIN {
+    use_ok('MooseX::Storage');
+}
+
+=pod
+
+This tests that the version and authority 
+checks are performed upon object expansion.
+
+=cut
+
+{
+    package Bar;
+    use Moose;
+    use MooseX::Storage;
+    
+    our $VERSION   = '0.01';
+    our $AUTHORITY = 'cpan:JRANDOM';
+
+    with Storage;
+    
+    has 'number' => (is => 'ro', isa => 'Int');
+    
+    package Foo;
+    use Moose;
+    use MooseX::Storage;
+
+    our $VERSION   = '0.01';
+    our $AUTHORITY = 'cpan:JRANDOM';    
+
+    with Storage;    
+
+    has 'bar' => ( 
+        is  => 'ro', 
+        isa => 'Bar' 
+    );    
+}
+
+{
+    my $foo = Foo->new(
+        bar => Bar->new(number => 1)
+    );
+    isa_ok( $foo, 'Foo' );
+    
+    is_deeply(
+        $foo->pack,
+        {
+            __CLASS__ => 'Foo-0.01-cpan:JRANDOM',
+            bar => {
+                __CLASS__ => 'Bar-0.01-cpan:JRANDOM',
+                number    => 1,
+            }         
+        },
+        '... got the right frozen class'
+    );
+}
+
+{
+    my $foo = Foo->unpack(
+        {
+            __CLASS__ => 'Foo-0.01-cpan:JRANDOM',
+            bar => {
+                __CLASS__ => 'Bar-0.01-cpan:JRANDOM',
+                number    => 1,
+            }         
+        },     
+    );
+    isa_ok( $foo, 'Foo' );
+    isa_ok( $foo->bar, 'Bar' );
+    is( $foo->bar->number, 1 , '... got the right number too' );
+    
+}
+
+Moose::Meta::Class->create('Bar', 
+    version   => '0.02',
+    authority => 'cpan:JRANDOM',
+);
+
+dies_ok {
+    Foo->unpack(
+        {
+            __CLASS__ => 'Foo-0.01-cpan:JRANDOM',
+            bar => {
+                __CLASS__ => 'Bar-0.01-cpan:JRANDOM',
+                number    => 1,
+            }         
+        }     
+    );
+} '... could not unpack, versions are different';
+
+Moose::Meta::Class->create('Bar', 
+    version   => '0.01',
+    authority => 'cpan:DSTATIC',
+);
+
+
+dies_ok {
+    Foo->unpack(
+        {
+            __CLASS__ => 'Foo-0.01-cpan:JRANDOM',
+            bar => {
+                __CLASS__ => 'Bar-0.01-cpan:JRANDOM',
+                number    => 1,
+            }         
+        }     
+    );
+} '... could not unpack, authorities are different';