1#!./perl -w 2# 3# Copyright 2005, Adam Kennedy. 4# 5# You may redistribute only under the same terms as Perl 5, as specified 6# in the README file that comes with the distribution. 7# 8 9# Man, blessed.t scared the hell out of me. For a second there I thought 10# I'd lose Test::More... 11 12# This file tests several known-error cases relating to STORABLE_attach, in 13# which Storable should (correctly) throw errors. 14 15sub BEGIN { 16 unshift @INC, 't'; 17 unshift @INC, 't/compat' if $] < 5.006002; 18 require Config; import Config; 19 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 20 print "1..0 # Skip: Storable was not built\n"; 21 exit 0; 22 } 23} 24 25use Test::More tests => 40; 26use Storable (); 27 28##################################################################### 29# Error 1 30# 31# Classes that implement STORABLE_thaw _cannot_ have references 32# returned by their STORABLE_freeze method. When they do, Storable 33# should throw an exception 34 35 36 37# Good Case - should not die 38{ 39 my $goodfreeze = bless {}, 'My::GoodFreeze'; 40 my $frozen = undef; 41 eval { 42 $frozen = Storable::freeze( $goodfreeze ); 43 }; 44 ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' ); 45 ok( $frozen, 'Storable freezes to a string successfully' ); 46 47 package My::GoodFreeze; 48 49 sub STORABLE_freeze { 50 my ($self, $clone) = @_; 51 52 # Illegally include a reference in this return 53 return (''); 54 } 55 56 sub STORABLE_attach { 57 my ($class, $clone, $string) = @_; 58 return bless { }, 'My::GoodFreeze'; 59 } 60} 61 62 63 64# Error Case - should die on freeze 65{ 66 my $badfreeze = bless {}, 'My::BadFreeze'; 67 eval { 68 Storable::freeze( $badfreeze ); 69 }; 70 ok( $@, 'Storable dies correctly when STORABLE_freeze returns a reference' ); 71 # Check for a unique substring of the error message 72 ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' ); 73 74 package My::BadFreeze; 75 76 sub STORABLE_freeze { 77 my ($self, $clone) = @_; 78 79 # Illegally include a reference in this return 80 return ('', []); 81 } 82 83 sub STORABLE_attach { 84 my ($class, $clone, $string) = @_; 85 return bless { }, 'My::BadFreeze'; 86 } 87} 88 89 90 91 92 93##################################################################### 94# Error 2 95# 96# If, for some reason, a STORABLE_attach object is accidentally stored 97# with references, this should be checked and an error should be thrown. 98 99 100 101# Good Case - should not die 102{ 103 my $goodthaw = bless {}, 'My::GoodThaw'; 104 my $frozen = undef; 105 eval { 106 $frozen = Storable::freeze( $goodthaw ); 107 }; 108 ok( $frozen, 'Storable freezes to a string as expected' ); 109 my $thawed = eval { 110 Storable::thaw( $frozen ); 111 }; 112 isa_ok( $thawed, 'My::GoodThaw' ); 113 is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' ); 114 115 package My::GoodThaw; 116 117 sub STORABLE_freeze { 118 my ($self, $clone) = @_; 119 120 return (''); 121 } 122 123 sub STORABLE_attach { 124 my ($class, $clone, $string) = @_; 125 return bless { 'foo' => 'bar' }, 'My::GoodThaw'; 126 } 127} 128 129 130 131# Bad Case - should die on thaw 132{ 133 # Create the frozen string normally 134 my $badthaw = bless { }, 'My::BadThaw'; 135 my $frozen = undef; 136 eval { 137 $frozen = Storable::freeze( $badthaw ); 138 }; 139 ok( $frozen, 'BadThaw was frozen with references correctly' ); 140 141 # Set up the error condition by deleting the normal STORABLE_thaw, 142 # and creating a STORABLE_attach. 143 *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; 144 *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning 145 delete ${'My::BadThaw::'}{STORABLE_thaw}; 146 147 # Trigger the error condition 148 my $thawed = undef; 149 eval { 150 $thawed = Storable::thaw( $frozen ); 151 }; 152 ok( $@, 'My::BadThaw object dies when thawing as expected' ); 153 # Check for a snippet from the error message 154 ok( $@ =~ /unexpected references/, 'Dies with the expected error message' ); 155 156 package My::BadThaw; 157 158 sub STORABLE_freeze { 159 my ($self, $clone) = @_; 160 161 return ('', []); 162 } 163 164 # Start with no STORABLE_attach method so we can get a 165 # frozen object-containing-a-reference into the freeze string. 166 sub STORABLE_thaw { 167 my ($class, $clone, $string) = @_; 168 return bless { 'foo' => 'bar' }, 'My::BadThaw'; 169 } 170} 171 172 173 174 175##################################################################### 176# Error 3 177# 178# Die if what is returned by STORABLE_attach is not something of that class 179 180 181 182# Good Case - should not die 183{ 184 my $goodattach = bless { }, 'My::GoodAttach'; 185 my $frozen = Storable::freeze( $goodattach ); 186 ok( $frozen, 'My::GoodAttach return as expected' ); 187 my $thawed = eval { 188 Storable::thaw( $frozen ); 189 }; 190 isa_ok( $thawed, 'My::GoodAttach' ); 191 is( ref($thawed), 'My::GoodAttach::Subclass', 192 'The slightly-tricky good "returns a subclass" case returns as expected' ); 193 194 package My::GoodAttach; 195 196 sub STORABLE_freeze { 197 my ($self, $cloning) = @_; 198 return (''); 199 } 200 201 sub STORABLE_attach { 202 my ($class, $cloning, $string) = @_; 203 204 return bless { }, 'My::GoodAttach::Subclass'; 205 } 206 207 package My::GoodAttach::Subclass; 208 209 BEGIN { 210 @ISA = 'My::GoodAttach'; 211 } 212} 213 214# Good case - multiple references to the same object should be attached properly 215{ 216 my $obj = bless { id => 111 }, 'My::GoodAttach::MultipleReferences'; 217 my $arr = [$obj]; 218 219 push @$arr, $obj; 220 221 my $frozen = Storable::freeze($arr); 222 223 ok( $frozen, 'My::GoodAttach return as expected' ); 224 225 my $thawed = eval { 226 Storable::thaw( $frozen ); 227 }; 228 229 isa_ok( $thawed->[0], 'My::GoodAttach::MultipleReferences' ); 230 isa_ok( $thawed->[1], 'My::GoodAttach::MultipleReferences' ); 231 232 is($thawed->[0], $thawed->[1], 'References to the same object are attached properly'); 233 is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attached properly'); 234 235 package My::GoodAttach::MultipleReferences; 236 237 sub STORABLE_freeze { 238 my ($obj) = @_; 239 $obj->{id} 240 } 241 242 sub STORABLE_attach { 243 my ($class, $cloning, $id) = @_; 244 bless { id => $id }, $class; 245 } 246 247} 248 249 250 251# Bad Cases - die on thaw 252{ 253 my $returnvalue = undef; 254 255 # Create and freeze the object 256 my $badattach = bless { }, 'My::BadAttach'; 257 my $frozen = Storable::freeze( $badattach ); 258 ok( $frozen, 'BadAttach freezes as expected' ); 259 260 # Try a number of different return values, all of which 261 # should cause Storable to die. 262 my @badthings = ( 263 undef, 264 '', 265 1, 266 [], 267 {}, 268 \"foo", 269 (bless { }, 'Foo'), 270 ); 271 foreach ( @badthings ) { 272 $returnvalue = $_; 273 274 my $thawed = undef; 275 eval { 276 $thawed = Storable::thaw( $frozen ); 277 }; 278 ok( $@, 'BadAttach dies on thaw' ); 279 ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/, 280 'BadAttach dies on thaw with the expected error message' ); 281 is( $thawed, undef, 'Double checking $thawed was not set' ); 282 } 283 284 package My::BadAttach; 285 286 sub STORABLE_freeze { 287 my ($self, $cloning) = @_; 288 return (''); 289 } 290 291 sub STORABLE_attach { 292 my ($class, $cloning, $string) = @_; 293 294 return $returnvalue; 295 } 296} 297