use strict; local $^W = 1; use Test::More; use Scalar::Util qw( refaddr ); use Class::InsideOut (); $|++; # keep stdout and stderr in order on Win32 (maybe) my %constructors_for = ( 't::Object::Singleton::Simple' => 'new', 't::Object::Singleton::Hooked' => 'get_instance', ); # Need Storable 2.14 ( STORABLE_attach support ) eval { require Storable and Storable->VERSION( 2.14 ) }; if ( $@ ) { plan skip_all => "Storable >= 2.14 needed for singleton support", } else { plan tests => 12 * scalar keys %constructors_for; } #--------------------------------------------------------------------------# my $name = "Neo"; my $name2 = "Mr. Smith"; #--------------------------------------------------------------------------# for my $class ( keys %constructors_for ) { require_ok( $class ); my $o; # create the object my $new = $class->can( $constructors_for{$class} ); ok( $o = $new->($class), "... Creating $class object" ); # set a name $o->name( $name ); is( $o->name(), $name, "... Setting 'name' to '$name'" ); # freeze object my ( $frozen, $thawed ); ok( $frozen = Storable::freeze( $o ), "... Freezing $class object" ); # set a name $o->name( $name2); is( $o->name(), $name2, "... Setting 'name' to '$name2'" ); # thaw object ok( $thawed = Storable::thaw( $frozen ), "... Thawing $class object" ); is( refaddr $o, refaddr $thawed, "... Thawed $class object is the singleton" ); # check it is( $thawed->name(), $name2, "... Thawed $class object 'name' is '$name2'" ); # destroy the singleton { no strict 'refs'; Class::InsideOut::_deregister( $o ) if $] < 5.006; ${"$class\::self"} = $thawed = $o = undef; is( ${"$class\::self"}, undef, "... Destroying $class singleton manually" ); my @leaks = Class::InsideOut::_leaking_memory; is( scalar @leaks, 0, "... $class is not leaking memory" ) or diag "Leaks detected in:\n" . join( "\n", map { q{ } . $_ } @leaks ); } # recreate it ok( $thawed = Storable::thaw( $frozen ), "... Re-thawing $class object again (recreating)" ); # check it if ( $class eq "t::Object::Singleton::Hooked" ) { is( $thawed->name(), $name, "... Re-thawed $class object 'name' is '$name'" ); } else { # regular singleton doesn't reinitialize is( $thawed->name(), undef, "... Re-thawed $class object 'name' is undef" ); } }