ext/Storable/t/attach_singleton.t

   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
  12 sub BEGIN {
  13     if ($ENV{PERL_CORE}){
  14         chdir('t') if -d 't';
  15         @INC = ('.', '../lib');
  16     } else {
  17         unshift @INC, 't';
  18     }
  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";
  22         exit 0;
  23     }
  24 }
  25
  26 use Test::More tests => 11;
  27 use Storable ();
  28
  29 # Get the singleton
  30 my $object = My::Singleton->new;
  31 isa_ok( $object, 'My::Singleton' );
  32
  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' );
  37
  38 ############
  39 # Main Tests
  40
  41 my $struct = [ 1, $object, 3 ];
  42
  43 # Freeze the struct
  44 my $frozen = Storable::freeze( $struct );
  45 ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' );
  46
  47 # Thaw the struct
  48 my $thawed = Storable::thaw( $frozen );
  49
  50 # Now it should look exactly like the original
  51 is_deeply( $struct, $thawed, 'Struct superficially looks like the original' );
  52
  53 # ... EXCEPT that the Singleton should be the same instance of the object
  54 is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' );
  55
  56 # We can also test this empirically
  57 $struct->[1]->{value} = 'Goodbye cruel world!';
  58 is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
  59
  60 # End Tests
  61 ###########
  62
  63 package My::Singleton;
  64
  65 my $SINGLETON = undef;
  66
  67 sub new {
  68         $SINGLETON or
  69         $SINGLETON = bless { value => 'Hello World!' }, $_[0];
  70 }
  71
  72 sub STORABLE_freeze {
  73         my $self = shift;
  74
  75         # We don't actually need to return anything, but provide a null string
  76         # to avoid the null-list-return behaviour.
  77         return ('foo');
  78 }
  79
  80 sub STORABLE_attach {
  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' );
  86
  87         # Get the Singleton object and return it
  88         return $class->new;
  89 }