1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
#!./perl -w
#
# Copyright 2005, Adam Kennedy.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# Tests freezing/thawing structures containing Singleton objects,
# which should see both structs pointing to the same object.
sub BEGIN {
unshift @INC, 't';
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Test::More tests => 11;
use Storable ();
# Get the singleton
my $object = My::Singleton->new;
isa_ok( $object, 'My::Singleton' );
# Confirm (for the record) that the class is actually a Singleton
my $object2 = My::Singleton->new;
isa_ok( $object2, 'My::Singleton' );
is( "$object", "$object2", 'Class is a singleton' );
############
# Main Tests
my $struct = [ 1, $object, 3 ];
# Freeze the struct
my $frozen = Storable::freeze( $struct );
ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' );
# Thaw the struct
my $thawed = Storable::thaw( $frozen );
# Now it should look exactly like the original
is_deeply( $struct, $thawed, 'Struct superficially looks like the original' );
# ... EXCEPT that the Singleton should be the same instance of the object
is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' );
# We can also test this empirically
$struct->[1]->{value} = 'Goodbye cruel world!';
is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
# End Tests
###########
package My::Singleton;
my $SINGLETON = undef;
sub new {
$SINGLETON or
$SINGLETON = bless { value => 'Hello World!' }, $_[0];
}
sub STORABLE_freeze {
my $self = shift;
# We don't actually need to return anything, but provide a null string
# to avoid the null-list-return behaviour.
return ('foo');
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' );
Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' );
Test::More::is( $clone, 0, 'We are not in a dclone' );
Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' );
# Get the Singleton object and return it
return $class->new;
}
|
