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