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