Attaching hook_attach_errors.t test script, which tests for the three
main exceptions that it is possible for the new functionality to
correctly cause.
#!/usr/bin/perl -w
use Storable ();
use Test::More tests => 35;
#####################################################################
# Error 1
#
# Classes that implement STORABLE_thaw _cannot_ have references
# returned by their STORABLE_freeze method. When they do, Storable
# should throw an exception
# Good Case - should not die
{
my $goodfreeze = bless {}, 'My::GoodFreeze';
my $frozen = undef;
eval {
$frozen = Storable::freeze( $goodfreeze );
};
ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' );
ok( $frozen, 'Storable freezes to a string successfully' );
package My::GoodFreeze;
sub STORABLE_freeze {
my ($self, $clone) = @_;
# Illegally include a reference in this return
return ('');
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
return bless { }, 'My::GoodFreeze';
}
}
# Error Case - should die on freeze
{
my $badfreeze = bless {}, 'My::BadFreeze';
eval {
Storable::freeze( $badfreeze );
};
ok( $@, 'Storable dies correctly when STORABLE_freeze returns a referece' );
# Check for a unique substring of the error message
ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' );
package My::BadFreeze;
sub STORABLE_freeze {
my ($self, $clone) = @_;
# Illegally include a reference in this return
return ('', []);
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
return bless { }, 'My::BadFreeze';
}
}
#####################################################################
# Error 2
#
# If, for some reason, a STORABLE_attach object is accidentally stored
# with references, this should be checked and and error should be throw.
# Good Case - should not die
{
my $goodthaw = bless {}, 'My::GoodThaw';
my $frozen = undef;
eval {
$frozen = Storable::freeze( $goodthaw );
};
ok( $frozen, 'Storable freezes to a string as expected' );
my $thawed = eval {
Storable::thaw( $frozen );
};
isa_ok( $thawed, 'My::GoodThaw' );
is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' );
package My::GoodThaw;
sub STORABLE_freeze {
my ($self, $clone) = @_;
return ('');
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
return bless { 'foo' => 'bar' }, 'My::GoodThaw';
}
}
# Bad Case - should die on thaw
{
# Create the frozen string normally
my $badthaw = bless { }, 'My::BadThaw';
my $frozen = undef;
eval {
$frozen = Storable::freeze( $badthaw );
};
ok( $frozen, 'BadThaw was frozen with references correctly' );
# Set up the error condition by deleting the normal STORABLE_thaw,
# and creating a STORABLE_attach.
*My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw;
*My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning
delete ${'My::BadThaw::'}{STORABLE_thaw};
# Trigger the error condition
my $thawed = undef;
eval {
$thawed = Storable::thaw( $frozen );
};
ok( $@, 'My::BadThaw object dies when thawing as expected' );
# Check for a snippet from the error message
ok( $@ =~ /unexpected references/, 'Dies with the expected error message' );
package My::BadThaw;
sub STORABLE_freeze {
my ($self, $clone) = @_;
return ('', []);
}
# Start with no STORABLE_attach method so we can get a
# frozen object-containing-a-reference into the freeze string.
sub STORABLE_thaw {
my ($class, $clone, $string) = @_;
return bless { 'foo' => 'bar' }, 'My::BadThaw';
}
}
#####################################################################
# Error 3
#
# Die if what is returned by STORABLE_attach is not something of that class
# Good Case - should not die
{
my $goodattach = bless { }, 'My::GoodAttach';
my $frozen = Storable::freeze( $goodattach );
ok( $frozen, 'My::GoodAttach return as expected' );
my $thawed = eval {
Storable::thaw( $frozen );
};
isa_ok( $thawed, 'My::GoodAttach' );
is( ref($thawed), 'My::GoodAttach::Subclass',
'The slightly-tricky good "returns a subclass" case returns as expected' );
package My::GoodAttach;
sub STORABLE_freeze {
my ($self, $cloning) = @_;
return ('');
}
sub STORABLE_attach {
my ($class, $cloning, $string) = @_;
return bless { }, 'My::GoodAttach::Subclass';
}
package My::GoodAttach::Subclass;
BEGIN {
@ISA = 'My::GoodAttach';
}
}
# Bad Cases - die on thaw
{
my $returnvalue = undef;
# Create and freeze the object
my $badattach = bless { }, 'My::BadAttach';
my $frozen = Storable::freeze( $badattach );
ok( $frozen, 'BadAttach freezes as expected' );
# Try a number of different return values, all of which
# should cause Storable to die.
my @badthings = (
undef,
'',
1,
[],
{},
\"foo",
(bless { }, 'Foo'),
);
foreach ( @badthings ) {
$returnvalue = $_;
my $thawed = undef;
eval {
$thawed = Storable::thaw( $frozen );
};
ok( $@, 'BadAttach dies on thaw' );
ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/,
'BadAttach dies on thaw with the expected error message' );
is( $thawed, undef, 'Double checking $thawed was not set' );
}
package My::BadAttach;
sub STORABLE_freeze {
my ($self, $cloning) = @_;
return ('');
}
sub STORABLE_attach {
my ($class, $cloning, $string) = @_;
return $returnvalue;
}
}
