* move Base::WithChecksum to build upon Basic.pm, avoid code duplication
[gitmo/MooseX-Storage.git] / lib / MooseX / Storage / Base / WithChecksum.pm
1 package MooseX::Storage::Base::WithChecksum;
2 use Moose::Role;
3
4 with 'MooseX::Storage::Basic';
5
6 use Digest       ();
7 use Data::Dumper ();
8
9 our $VERSION   = '0.18';
10 our $AUTHORITY = 'cpan:STEVAN';
11
12 our $DIGEST_MARKER = '__DIGEST__';
13
14 around pack => sub {
15     my $orig = shift;
16     my $self = shift;
17     my @args = @_;
18
19     my $collapsed = $self->$orig( @args );
20
21     $collapsed->{$DIGEST_MARKER} = $self->_digest_packed($collapsed, @args);
22     
23     return $collapsed;
24 };
25
26 around unpack  => sub {
27     my ($orig, $class, $data, @args) = @_;
28
29     # check checksum on data
30     my $old_checksum = delete $data->{$DIGEST_MARKER};
31     
32     my $checksum = $class->_digest_packed($data, @args);
33
34     ($checksum eq $old_checksum)
35         || confess "Bad Checksum got=($checksum) expected=($old_checksum)";    
36
37     $class->$orig( $data, @args );
38 };
39
40
41 sub _digest_packed {
42     my ( $self, $collapsed, @args ) = @_;
43
44     my $d = $self->_digest_object(@args);
45
46     {
47         local $Data::Dumper::Indent   = 0;
48         local $Data::Dumper::Sortkeys = 1;
49         local $Data::Dumper::Terse    = 1;
50         local $Data::Dumper::Useqq    = 0;
51         local $Data::Dumper::Deparse  = 0; # FIXME?
52         my $str = Data::Dumper::Dumper($collapsed);
53         # NOTE:
54         # Canonicalize numbers to strings even if it 
55         # mangles numbers inside strings. It really 
56         # does not matter since its just the checksum
57         # anyway.
58         # - YK/SL
59         $str =~ s/(?<! ['"] ) \b (\d+) \b (?! ['"] )/'$1'/gx; 
60         $d->add( $str );
61     }
62
63     return $d->hexdigest;
64 }
65
66 sub _digest_object {
67     my ( $self, %options ) = @_;
68     my $digest_opts = $options{digest};
69     
70     $digest_opts = [ $digest_opts ] 
71         if !ref($digest_opts) or ref($digest_opts) ne 'ARRAY';
72         
73     my ( $d, @args ) = @$digest_opts;
74
75     if ( ref $d ) {
76         if ( $d->can("clone") ) {
77             return $d->clone;
78         } 
79         elsif ( $d->can("reset") ) {
80             $d->reset;
81             return $d;
82         } 
83         else {
84             die "Can't clone or reset digest object: $d";
85         }
86     } 
87     else {
88         return Digest->new($d || "SHA1", @args);
89     }
90 }
91
92 1;
93
94 __END__
95
96 =pod
97
98 =head1 NAME
99
100 MooseX::Storage::Base::WithChecksum - A more secure serialization role
101
102 =head1 DESCRIPTION
103
104 This is an early implementation of a more secure Storage role, 
105 which does integrity checks on the data. It is still being 
106 developed so I recommend using it with caution. 
107
108 Any thoughts, ideas or suggestions on improving our technique 
109 are very welcome.
110
111 =head1 METHODS
112
113 =over 4
114
115 =item B<pack (?$salt)>
116
117 =item B<unpack ($data, ?$salt)>
118
119 =back
120
121 =head2 Introspection
122
123 =over 4
124
125 =item B<meta>
126
127 =back
128
129 =head1 BUGS
130
131 All complex software has bugs lurking in it, and this module is no 
132 exception. If you find a bug please either email me, or add the bug
133 to cpan-RT.
134
135 =head1 AUTHOR
136
137 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
138
139 Yuval Kogman
140
141 =head1 COPYRIGHT AND LICENSE
142
143 Copyright 2007-2008 by Infinity Interactive, Inc.
144
145 L<http://www.iinteractive.com>
146
147 This library is free software; you can redistribute it and/or modify
148 it under the same terms as Perl itself.
149
150 =cut