Commit | Line | Data |
---|---|---|
2f796f32 AMS |
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 | ||
15 | sub BEGIN { | |
48c887dd | 16 | unshift @INC, 't'; |
1afdebce | 17 | unshift @INC, 't/compat' if $] < 5.006002; |
2f796f32 AMS |
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 | ||
ecc6a8ca | 25 | use Test::More tests => 40; |
2f796f32 AMS |
26 | use 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 | }; | |
1c2e8cca | 74 | ok( $@, 'Storable dies correctly when STORABLE_freeze returns a reference' ); |
2f796f32 AMS |
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 | ||
ecc6a8ca IZ |
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'); | |
a9ccbcd7 | 237 | is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attached properly'); |
ecc6a8ca IZ |
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 | ||
2f796f32 AMS |
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 | } |