File Coverage

blib/lib/Dancer/Object/Singleton.pm

Criterion	Covered	Total	%
statement	33	33	100.0
branch	6	6	100.0
condition			n/a
subroutine	10	10	100.0
pod	3	3	100.0
total	52	52	100.0

package Dancer::Object::Singleton;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: Singleton base class for Dancer
$Dancer::Object::Singleton::VERSION = '1.3521';
# This class is a root class for singleton objects in Dancer.
# It provides basic OO singleton tools for Perl5 without being... MooseX::Singleton ;-)

use strict;
use warnings;
use Carp;
use Dancer::Exception qw(:all);

use base qw(Dancer::Object);

# pool of instances (only one per package name)
my %instances;

# constructor
sub new {
    my ($class) = @_;
    raise core => "you can't call 'new' on $class, as it's a singleton. Try to call 'instance'";
}

sub clone {
    my ($class) = @_;
    raise core => "you can't call 'clone' on $class, as it's a singleton. Try to call 'instance'";
}

sub instance {
    my ($class) = @_;
    my $instance = $instances{$class};

    # if exists already
    defined $instance
      and return $instance;

    # create the instance
    $instance = bless {}, $class;
    $class->init($instance);

    # save and return it
    $instances{$class} = $instance;
    return $instance;
}

# accessor code for singleton objects
# (overloaded from Dancer::Object)
sub _setter_code {
    my ($class, $attr) = @_;
    sub {
        my ($class_or_instance, $value) = @_;
        my $instance = ref $class_or_instance ?
          $class_or_instance : $class_or_instance->instance;
        if (@_ == 1) {
            return $instance->{$attr};
        }
        else {
            return $instance->{$attr} = $value;
        }
    };
}

1;

__END__