adding simple checksum role

diff --git a/Build.PL b/Build.PL
index 4468bfc..9c850ec 100644 (file)
--- a/Build.PL
+++ b/Build.PL
@@ -13,7 +13,10 @@ my $build = Module::Build->new(
         'Best'         => '0', # << this if for loading YAML
         # and the ability to save the 
         # file to disk        
-        'IO::File'     => '0',        
+        'IO::File'     => '0',    
+        # this if for the basic role with checksum
+        'Digest::MD5'  => '0',    
+        'Data::Dumper' => '0',
     },
     optional => {
         'IO::AtomicFile'    => '0',  

diff --git a/Changes b/Changes
index 421374d..b791ff2 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,6 +1,12 @@
 Revision history for MooseX-Storage
 
 0.02 
+    * MooseX::Storage::Base::WithChecksum
+      - added a simple base role which makes a checksum of 
+        the data structure before packing, and checks the
+        checksum before unpacking.
+        - added tests for this
+
     * MooseX::Storage::Engine
       - better error reporting when cycles are found
       - class names are now stored as the full identifier

diff --git a/MANIFEST b/MANIFEST
index a268d68..d8a7447 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -7,6 +7,7 @@ MANIFEST.SKIP
 README
 lib/MooseX/Storage.pm
 lib/MooseX/Storage/Basic.pm
+lib/MooseX/Storage/Base/WithChecksum.pm
 lib/MooseX/Storage/Engine.pm
 lib/MooseX/Storage/Engine/IO/AtomicFile.pm
 lib/MooseX/Storage/Engine/IO/File.pm
@@ -23,6 +24,7 @@ t/004_w_cycles.t
 t/005_w_versions_and_authority_check.t
 t/010_basic_json.t
 t/020_basic_yaml.t
+t/030_with_checksum.t
 t/100_io.t
 t/101_io_atomic.t
 t/pod-coverage.t

diff --git a/lib/MooseX/Storage.pm b/lib/MooseX/Storage.pm
index 57a3347..c543fc8 100644 (file)
--- a/lib/MooseX/Storage.pm
+++ b/lib/MooseX/Storage.pm
@@ -17,7 +17,12 @@ sub import {
     $pkg->meta->alias_method('Storage' => sub {
         my %params = @_;
         
-        $params{'base'} ||= 'Basic';
+        if (exists $params{'base'}) {
+            $params{'base'} = ('Base::' . $params{'base'});        
+        }
+        else {
+            $params{'base'} = 'Basic';        
+        }
         
         my @roles = (
             ('MooseX::Storage::' . $params{'base'}),

diff --git a/lib/MooseX/Storage/Base/WithChecksum.pm b/lib/MooseX/Storage/Base/WithChecksum.pm
new file mode 100644 (file)
index 0000000..2f32787
--- /dev/null
+++ b/lib/MooseX/Storage/Base/WithChecksum.pm
@@ -0,0 +1,105 @@
+
+package MooseX::Storage::Base::WithChecksum;
+use Moose::Role;
+
+use Digest::MD5  ('md5_hex');
+use Data::Dumper ();
+use MooseX::Storage::Engine;
+
+our $VERSION = '0.01';
+
+sub pack {
+    my ($self, $salt) = @_;
+    my $e = MooseX::Storage::Engine->new( object => $self );
+    my $collapsed = $e->collapse_object;
+    
+    # create checksum
+    
+    local $Data::Dumper::Sortkeys = 1;
+    my $dumped = Data::Dumper::Dumper($collapsed);
+
+    #warn $dumped;
+    
+    $salt ||= $dumped;
+    
+    $collapsed->{checksum} = md5_hex($dumped, $salt);
+    
+    return $collapsed;
+}
+
+sub unpack {
+    my ($class, $data, $salt) = @_;
+
+    # check checksum on data
+    
+    my $old_checksum = $data->{checksum};
+    delete $data->{checksum};
+    
+    local $Data::Dumper::Sortkeys = 1;
+    my $dumped = Data::Dumper::Dumper($data);
+    
+    #warn $dumped;
+    
+    $salt ||= $dumped;
+    
+    my $checksum = md5_hex($dumped, $salt);
+    
+    ($checksum eq $old_checksum)
+        || confess "Bad Checksum got=($checksum) expected=($data->{checksum})";    
+
+    my $e = MooseX::Storage::Engine->new(class => $class);
+    $class->new($e->expand_object($data));
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Storage::Base::WithChecksum
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<pack (?$salt)>
+
+=item B<unpack ($data, ?$salt)>
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no 
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut

diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm
index 9953dd9..430634a 100644 (file)
--- a/lib/MooseX/Storage/Engine.pm
+++ b/lib/MooseX/Storage/Engine.pm
@@ -189,8 +189,8 @@ my %OBJECT_HANDLERS = (
     },
     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();
     },
 );

diff --git a/t/030_with_checksum.t b/t/030_with_checksum.t
new file mode 100644 (file)
index 0000000..1c72b95
--- /dev/null
+++ b/t/030_with_checksum.t
@@ -0,0 +1,88 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+use Test::Exception;
+use Test::Deep;
+
+BEGIN {
+    use_ok('MooseX::Storage');
+}
+
+{
+
+    package Foo;
+    use Moose;
+    use MooseX::Storage;
+
+    with Storage(base => 'WithChecksum');
+
+    has 'number' => ( is => 'ro', isa => 'Int' );
+    has 'string' => ( is => 'ro', isa => 'Str' );
+    has 'float'  => ( is => 'ro', isa => 'Num' );
+    has 'array'  => ( is => 'ro', isa => 'ArrayRef' );
+    has 'hash'   => ( is => 'ro', isa => 'HashRef' );
+    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' );
+    
+    my $packed = $foo->pack;
+    
+    cmp_deeply(
+        $packed,
+        {
+            __CLASS__ => 'Foo',
+            checksum  => re('[0-9a-f]+'),
+            number    => 10,
+            string    => 'foo',
+            float     => 10.5,
+            array     => [ 1 .. 10 ],
+            hash      => { map { $_ => undef } ( 1 .. 10 ) },
+            object    => { 
+                            __CLASS__ => 'Foo', 
+                            checksum  => re('[0-9a-f]+'),               
+                            number    => 2 
+                         },            
+        },
+        '... got the right frozen class'
+    );
+
+    my $foo2;
+    lives_ok {
+        $foo2 = Foo->unpack($packed);
+    } '... unpacked okay';
+    isa_ok($foo2, 'Foo');
+    
+    cmp_deeply(
+        $foo2->pack,
+        {
+            __CLASS__ => 'Foo',
+            checksum  => re('[0-9a-f]+'),
+            number    => 10,
+            string    => 'foo',
+            float     => 10.5,
+            array     => [ 1 .. 10 ],
+            hash      => { map { $_ => undef } ( 1 .. 10 ) },
+            object    => { 
+                            __CLASS__ => 'Foo', 
+                            checksum  => re('[0-9a-f]+'),               
+                            number    => 2 
+                         },            
+        },
+        '... got the right frozen class'
+    );    
+    
+}
+