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'; |
2f796f32 AMS |
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 | } |