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