3 # Copyright 2005, Adam Kennedy.
5 # You may redistribute only under the same terms as Perl 5, as specified
6 # in the README file that comes with the distribution.
9 # Man, blessed.t scared the hell out of me. For a second there I thought
10 # I'd lose Test::More...
12 # This file tests several known-error cases relating to STORABLE_attach, in
13 # which Storable should (correctly) throw errors.
18 @INC = ('.', '../lib');
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";
29 use Test::More tests => 35;
36 #####################################################################
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
45 # Good Case - should not die
47 my $goodfreeze = bless {}, 'My::GoodFreeze';
50 $frozen = Storable::freeze( $goodfreeze );
52 ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' );
53 ok( $frozen, 'Storable freezes to a string successfully' );
55 package My::GoodFreeze;
58 my ($self, $clone) = @_;
60 # Illegally include a reference in this return
65 my ($class, $clone, $string) = @_;
66 return bless { }, 'My::GoodFreeze';
72 # Error Case - should die on freeze
74 my $badfreeze = bless {}, 'My::BadFreeze';
76 Storable::freeze( $badfreeze );
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' );
82 package My::BadFreeze;
85 my ($self, $clone) = @_;
87 # Illegally include a reference in this return
92 my ($class, $clone, $string) = @_;
93 return bless { }, 'My::BadFreeze';
101 #####################################################################
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.
109 # Good Case - should not die
111 my $goodthaw = bless {}, 'My::GoodThaw';
114 $frozen = Storable::freeze( $goodthaw );
116 ok( $frozen, 'Storable freezes to a string as expected' );
118 Storable::thaw( $frozen );
120 isa_ok( $thawed, 'My::GoodThaw' );
121 is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' );
123 package My::GoodThaw;
125 sub STORABLE_freeze {
126 my ($self, $clone) = @_;
131 sub STORABLE_attach {
132 my ($class, $clone, $string) = @_;
133 return bless { 'foo' => 'bar' }, 'My::GoodThaw';
139 # Bad Case - should die on thaw
141 # Create the frozen string normally
142 my $badthaw = bless { }, 'My::BadThaw';
145 $frozen = Storable::freeze( $badthaw );
147 ok( $frozen, 'BadThaw was frozen with references correctly' );
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};
155 # Trigger the error condition
158 $thawed = Storable::thaw( $frozen );
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' );
166 sub STORABLE_freeze {
167 my ($self, $clone) = @_;
172 # Start with no STORABLE_attach method so we can get a
173 # frozen object-containing-a-reference into the freeze string.
175 my ($class, $clone, $string) = @_;
176 return bless { 'foo' => 'bar' }, 'My::BadThaw';
183 #####################################################################
186 # Die if what is returned by STORABLE_attach is not something of that class
190 # Good Case - should not die
192 my $goodattach = bless { }, 'My::GoodAttach';
193 my $frozen = Storable::freeze( $goodattach );
194 ok( $frozen, 'My::GoodAttach return as expected' );
196 Storable::thaw( $frozen );
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' );
202 package My::GoodAttach;
204 sub STORABLE_freeze {
205 my ($self, $cloning) = @_;
209 sub STORABLE_attach {
210 my ($class, $cloning, $string) = @_;
212 return bless { }, 'My::GoodAttach::Subclass';
215 package My::GoodAttach::Subclass;
218 @ISA = 'My::GoodAttach';
224 # Bad Cases - die on thaw
226 my $returnvalue = undef;
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' );
233 # Try a number of different return values, all of which
234 # should cause Storable to die.
244 foreach ( @badthings ) {
249 $thawed = Storable::thaw( $frozen );
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' );
257 package My::BadAttach;
259 sub STORABLE_freeze {
260 my ($self, $cloning) = @_;
264 sub STORABLE_attach {
265 my ($class, $cloning, $string) = @_;