The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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"
        );
    }

}