view release on metacpan or  search on metacpan

lib/Class/StrongSingleton.pm  view on Meta::CPAN

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;