From: Yuval Kogman Date: Fri, 11 May 2007 00:40:09 +0000 (+0000) Subject: WithCheksum 2.0 X-Git-Tag: 0_02~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=98ae09f003486b7c70661507771598c6101f23be;p=gitmo%2FMooseX-Storage.git WithCheksum 2.0 --- diff --git a/lib/MooseX/Storage/Base/WithChecksum.pm b/lib/MooseX/Storage/Base/WithChecksum.pm index 2f32787..ffa34b2 100644 --- a/lib/MooseX/Storage/Base/WithChecksum.pm +++ b/lib/MooseX/Storage/Base/WithChecksum.pm @@ -2,55 +2,68 @@ package MooseX::Storage::Base::WithChecksum; use Moose::Role; -use Digest::MD5 ('md5_hex'); -use Data::Dumper (); +use Digest (); +use Storable (); use MooseX::Storage::Engine; our $VERSION = '0.01'; sub pack { - my ($self, $salt) = @_; + my ($self, @args ) = @_; + 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; + my $collapsed = $e->collapse_object; - $collapsed->{checksum} = md5_hex($dumped, $salt); + $collapsed->{__DIGEST__} = $self->_digest_packed($collapsed, @args); return $collapsed; } sub unpack { - my ($class, $data, $salt) = @_; + my ($class, $data, @args) = @_; # 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); + my $old_checksum = $data->{__DIGEST__}; + delete $data->{__DIGEST__}; + my $checksum = $class->_digest_packed($data, @args); + ($checksum eq $old_checksum) - || confess "Bad Checksum got=($checksum) expected=($data->{checksum})"; + || confess "Bad Checksum got=($checksum) expected=($old_checksum)"; my $e = MooseX::Storage::Engine->new(class => $class); $class->new($e->expand_object($data)); } + +sub _digest_packed { + my ( $self, $collapsed, @args ) = @_; + + my $d = shift @args; + + if ( ref $d ) { + if ( $d->can("clone") ) { + $d = $d->clone; + } elsif ( $d->can("reset") ) { + $d->reset; + } else { + die "Can't clone or reset digest object: $d"; + } + } else { + $d = Digest->new($d || "SHA1", @args); + } + + { + local $Storable::canonical = 1; + $d->add( Storable::nfreeze($collapsed) ); + } + + return $d->hexdigest; +} + + 1; __END__ diff --git a/lib/MooseX/Storage/Format/JSON.pm b/lib/MooseX/Storage/Format/JSON.pm index 938b5c7..7377c0e 100644 --- a/lib/MooseX/Storage/Format/JSON.pm +++ b/lib/MooseX/Storage/Format/JSON.pm @@ -4,19 +4,19 @@ use Moose::Role; use JSON::Any; -our $VERSION = '0.01'; +our $VERSION = '0.02'; requires 'pack'; requires 'unpack'; sub thaw { - my ( $class, $json ) = @_; - $class->unpack( JSON::Any->jsonToObj($json) ); + my ( $class, $json, @args ) = @_; + $class->unpack( JSON::Any->jsonToObj($json), @args ); } sub freeze { - my $self = shift; - JSON::Any->objToJson( $self->pack() ); + my ( $self, @args ) = @_; + JSON::Any->objToJson( $self->pack(@args) ); } 1; diff --git a/lib/MooseX/Storage/Format/YAML.pm b/lib/MooseX/Storage/Format/YAML.pm index dad4120..69033c4 100644 --- a/lib/MooseX/Storage/Format/YAML.pm +++ b/lib/MooseX/Storage/Format/YAML.pm @@ -7,19 +7,19 @@ use Best [ [ qw[Load Dump] ] ]; -our $VERSION = '0.01'; +our $VERSION = '0.02'; requires 'pack'; requires 'unpack'; sub thaw { - my ( $class, $json ) = @_; - $class->unpack( Load($json) ); + my ( $class, $json, @args ) = @_; + $class->unpack( Load($json), @args ); } sub freeze { - my $self = shift; - Dump( $self->pack() ); + my ( $self, @args ) = @_; + Dump( $self->pack(@args) ); } 1; diff --git a/t/030_with_checksum.t b/t/030_with_checksum.t index 1c72b95..720a633 100644 --- a/t/030_with_checksum.t +++ b/t/030_with_checksum.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 6; +use Test::More tests => 25; use Test::Exception; use Test::Deep; @@ -17,7 +17,7 @@ BEGIN { use Moose; use MooseX::Storage; - with Storage(base => 'WithChecksum'); + with Storage(base => 'WithChecksum', format => "JSON"); has 'number' => ( is => 'ro', isa => 'Int' ); has 'string' => ( is => 'ro', isa => 'Str' ); @@ -44,7 +44,7 @@ BEGIN { $packed, { __CLASS__ => 'Foo', - checksum => re('[0-9a-f]+'), + __DIGEST__ => re('[0-9a-f]+'), number => 10, string => 'foo', float => 10.5, @@ -52,7 +52,7 @@ BEGIN { hash => { map { $_ => undef } ( 1 .. 10 ) }, object => { __CLASS__ => 'Foo', - checksum => re('[0-9a-f]+'), + __DIGEST__ => re('[0-9a-f]+'), number => 2 }, }, @@ -69,7 +69,7 @@ BEGIN { $foo2->pack, { __CLASS__ => 'Foo', - checksum => re('[0-9a-f]+'), + __DIGEST__ => re('[0-9a-f]+'), number => 10, string => 'foo', float => 10.5, @@ -77,12 +77,88 @@ BEGIN { hash => { map { $_ => undef } ( 1 .. 10 ) }, object => { __CLASS__ => 'Foo', - checksum => re('[0-9a-f]+'), + __DIGEST__ => re('[0-9a-f]+'), number => 2 }, }, '... got the right frozen class' ); - } +{ + 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 $frozen = $foo->freeze; + + ok( length($frozen), "got frozen data" ); + + $frozen =~ s/foo/bar/; + + my $foo2 = eval { Foo->thaw( $frozen ) }; + my $e = $@; + + ok( !$foo2, "not thawed" ); + ok( $e, "has error" ); + like( $e, qr/bad checksum/i, "bad checksum error" ); +} + +SKIP: { + eval { require Digest::HMAC_SHA1 }; + skip join( " ", "no Digest::HMAC", ( $@ =~ /\@INC/ ? () : do { chomp(my $e = $@); "($e)" } ) ), 14 if $@; + + 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 $frozen1 = $foo->freeze( "HMAC_SHA1", "secret" ); + ok( length($frozen1), "got frozen data" ); + + my $d2 = Digest::HMAC_SHA1->new("s3cr3t"); + + my $frozen2 = $foo->freeze( $d2 ); + ok( length($frozen2), "got frozen data" ); + + cmp_ok( $frozen1, "ne", $frozen2, "versions are different" ); + + my $foo1 = eval { Foo->thaw( $frozen1, "HMAC_SHA1", "secret" ) }; + my $e = $@; + + ok( $foo1, "thawed" ); + ok( !$e, "no error" ) || diag $e; + + my $foo2 = eval { Foo->thaw( $frozen2, $d2 ) }; + $e = $@; + + ok( $foo2, "thawed" ); + ok( !$e, "no error" ) || diag $e; + + $foo1 = eval { Foo->thaw( $frozen1, $d2 ) }; + $e = $@; + + ok( !$foo1, "not thawed" ); + ok( $e, "has error" ); + like( $e, qr/bad checksum/i, "bad checksum error" ); + + $frozen1 =~ s/foo/bar/; + + $foo1 = eval { Foo->thaw( $frozen1, "HMAC_SHA1", "secret" ) }; + $e = $@; + + ok( !$foo1, "not thawed" ); + ok( $e, "has error" ); + like( $e, qr/bad checksum/i, "bad checksum error" ); +}