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