File Coverage

blib/lib/Class/StrongSingleton.pm

Criterion	Covered	Total	%
statement	40	40	100.0
branch	12	12	100.0
condition	4	6	66.6
subroutine	10	10	100.0
pod	1	1	100.0
total	67	69	97.1

package Class::StrongSingleton;

use strict;
use warnings;

our $VERSION = '0.02';

my %instances;
my %constructors;

## protected initializer
sub _init_StrongSingleton {
	# do not let us be called by anything which
	# is not derived from Class::StrongSingleton
    (UNIVERSAL::isa((caller)[0], 'Class::StrongSingleton'))
        || die "Illegal Operation : _init_StrongSingleton can only be called by a subclass of Class::StrongSingleton";
	my ($self) = @_;
	(ref($self))
		|| die "Illegal Operation : _init_StrongSingleton can only be called as an instance method";
	# get the class name
	my $class = ref($self);
	(!exists($instances{$class}))
		|| die "Illegal Operation : cannot call _init_StrongSingleton with a valid Singleton instance";
	# assuming new was the name of our
	# constructor, otherwise ...
	my $constructor = $self->can("new");
	(defined($constructor))
		|| die "Illegal Operation : Singleton objects must have a 'new' method";
	# store the constructor for later
	$constructors{$class} = $constructor;
	# put the instance in the instances table
	$instances{$class} = $self;
	no strict 'refs';
	no warnings 'redefine';
	# then override the new method to return the
	# single instance.
	*{"${class}::new"} = sub { return $_[0]->instance() };
}

# for backwards compatability we retain the old _init
*_init = \&_init_StrongSingleton;

### destructor
sub DESTROY {
	my ($self) = @_;
	# get the class name
	my $class = ref($self) || $self;
	# if there is no valid singleton, then
	# we can just return
	return unless exists($instances{$class});
	# otherwise ...
	no strict 'refs';
	no warnings 'redefine';
	# return the contructor to its original state
	*{"${class}::new"} = $constructors{$class};
	# delete completely the unique instance
	delete $instances{$class};
	# at this point all should be back to normal
}

### methods

sub instance {
	my $self = shift;
	# get the class name or
	# if it is being called from
	# the class, then use that string
	my $class = ref($self) || $self;
	# return single instance of self, assuming there is one
	return $instances{$class} if exists $instances{$class};
	# otherwise we call new for you
	return $class->new(@_);
}

1;

__END__