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 # Tests freezing/thawing structures containing Singleton objects,
10 # which should see both structs pointing to the same object.
15 @INC = ('.', '../lib');
19 require Config; import Config;
20 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
21 print "1..0 # Skip: Storable was not built\n";
26 use Test::More tests => 11;
30 my $object = My::Singleton->new;
31 isa_ok( $object, 'My::Singleton' );
33 # Confirm (for the record) that the class is actually a Singleton
34 my $object2 = My::Singleton->new;
35 isa_ok( $object2, 'My::Singleton' );
36 is( "$object", "$object2", 'Class is a singleton' );
41 my $struct = [ 1, $object, 3 ];
44 my $frozen = Storable::freeze( $struct );
45 ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' );
48 my $thawed = Storable::thaw( $frozen );
50 # Now it should look exactly like the original
51 is_deeply( $struct, $thawed, 'Struct superficially looks like the original' );
53 # ... EXCEPT that the Singleton should be the same instance of the object
54 is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' );
56 # We can also test this empirically
57 $struct->[1]->{value} = 'Goodbye cruel world!';
58 is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
63 package My::Singleton;
65 my $SINGLETON = undef;
69 $SINGLETON = bless { value => 'Hello World!' }, $_[0];
75 # We don't actually need to return anything, but provide a null string
76 # to avoid the null-list-return behaviour.
81 my ($class, $clone, $string) = @_;
82 Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' );
83 Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' );
84 Test::More::is( $clone, 0, 'We are not in a dclone' );
85 Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' );
87 # Get the Singleton object and return it