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