The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it hsould work as `perl test.pl'

#########################

# change 'tests => 1' to 'tests => last_test_to_print';

use Test;
BEGIN { plan tests => 17 };
use Class::WeakSingleton;
ok(1); # If we made it this far, we're ok.

#########################

#========================================================================
#                         -- CLASS DEFINTIONS --
#========================================================================

#------------------------------------------------------------------------
# define 'DerivedSingleton', a class derived from Class::WeakSingleton 
#------------------------------------------------------------------------

package DerivedSingleton;
use base 'Class::WeakSingleton';

#------------------------------------------------------------------------
# define 'AnotherSingleton', a class derived from DerivedSingleton 
#------------------------------------------------------------------------

package AnotherSingleton;
use base 'DerivedSingleton';


#------------------------------------------------------------------------
# define 'ArraySingleton', which uses an array reference as its type
#------------------------------------------------------------------------

package ArraySingleton;
use base 'Class::WeakSingleton';

sub _new_instance { bless [], shift }


#------------------------------------------------------------------------
# define 'ConfigSingleton', which has specific configuration needs.
#------------------------------------------------------------------------

package ConfigSingleton;
use base 'Class::WeakSingleton';

sub _new_instance {
    my $class  = shift;
    my $config = shift || { };
    my $self = {
	'one' => 'This is the first parameter',
	'two' => 'This is the second parameter',
	%$config,
    };
    bless $self, $class;
}



#========================================================================
#                                -- TESTS --
#========================================================================

package main;

use warnings FATAL => 'all';

{
    my %h;
    {
        # call Class::WeakSingleton->instance() twice and expect to get the same 
        # reference returned on both occasions.
        my $s1 = Class::WeakSingleton->instance();
        my $s2 = Class::WeakSingleton->instance();
	
        ok( $s1 == $s2 ); # Test 4
	ok( $s1 == Class::WeakSingleton->instance );
        ok( $Class::WeakSingleton::_instance == $s1 ); # Test 5

        $h{test} = $s1;
    }

    ok( $Class::WeakSingleton::_instance ); # Test 6
}
ok( not defined $Class::WeakSingleton::_instance ); # Test 7

{
    {
        # call MySingleton->instance() twice and expect to get the same 
        # reference returned on both occasions.

        my $s3 = DerivedSingleton->instance();
        my $s4 = DerivedSingleton->instance();
        $s5 = DerivedSingleton->instance;

        ok( $s3 == $s4 );
        ok( $s4 == $s5 );
    }

    ok( $s5 == DerivedSingleton->instance );
    undef $s5;
    
    ok( not $DerivedSingleton::_instance );
}

{
    # call MyOtherSingleton->instance() twice and expect to get the same 
    # reference returned on both occasions.

    my $s5 = AnotherSingleton->instance();
    my $s6 = AnotherSingleton->instance();

    ok( $s5 == $s6 );
}

#------------------------------------------------------------------------
# having checked that each instance of the same class is the same, we now
# check that the instances of the separate classes are actually different 
# from each other 
#------------------------------------------------------------------------

ok( Class::WeakSingleton->instance != DerivedSingleton->instance and
    DerivedSingleton->instance     != AnotherSingleton->instance );


#------------------------------------------------------------------------
# test ArraySingleton
#------------------------------------------------------------------------

{
    my $as1 = ArraySingleton->instance();
    my $as2 = ArraySingleton->instance();
    
    ok( $as1 == $as2 );
    ok( UNIVERSAL::isa( $as1, 'ARRAY' ) );
}


#------------------------------------------------------------------------
# test ConfigSingleton
#------------------------------------------------------------------------

# create a ConfigSingleton
{
    my $config = { 'foo' => 'This is foo' };
    my $cs1 = ConfigSingleton->instance($config);
    
    # add another parameter to the config
    $config->{'bar'} = 'This is bar';

    # shouldn't call new() so changes to $config shouldn't matter
    my $cs2 = ConfigSingleton->instance($config);

    ok( $cs1 == $cs2 );
    ok( 3 == scalar keys %$cs1 );
    ok( 3 == scalar keys %$cs2 );
}