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