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


line stmt bran cond sub pod time code
1             package Dancer::Object::Singleton;
2             our $AUTHORITY = 'cpan:SUKRIA';
3             #ABSTRACT: Singleton base class for Dancer
4             $Dancer::Object::Singleton::VERSION = '1.3521';
5             # This class is a root class for singleton objects in Dancer.
6             # It provides basic OO singleton tools for Perl5 without being... MooseX::Singleton ;-)
7              
8 195     195   68472 use strict;
  195         494  
  195         7071  
9 195     195   1085 use warnings;
  195         436  
  195         4510  
10 195     195   1075 use Carp;
  195         390  
  195         12293  
11 195     195   3580 use Dancer::Exception qw(:all);
  195         483  
  195         27401  
12              
13 195     195   1413 use base qw(Dancer::Object);
  195         461  
  195         82701  
14              
15             # pool of instances (only one per package name)
16             my %instances;
17              
18             # constructor
19             sub new {
20 1     1 1 10 my ($class) = @_;
21 1         7 raise core => "you can't call 'new' on $class, as it's a singleton. Try to call 'instance'";
22             }
23              
24             sub clone {
25 1     1 1 583 my ($class) = @_;
26 1         10 raise core => "you can't call 'clone' on $class, as it's a singleton. Try to call 'instance'";
27             }
28              
29             sub instance {
30 4217     4217 1 8181785 my ($class) = @_;
31 4217         7983 my $instance = $instances{$class};
32              
33             # if exists already
34 4217 100       18792 defined $instance
35             and return $instance;
36              
37             # create the instance
38 213         728 $instance = bless {}, $class;
39 213         1299 $class->init($instance);
40              
41             # save and return it
42 213         588 $instances{$class} = $instance;
43 213         990 return $instance;
44             }
45              
46             # accessor code for singleton objects
47             # (overloaded from Dancer::Object)
48             sub _setter_code {
49 767     767   1954 my ($class, $attr) = @_;
50             sub {
51 10895     10895   21434 my ($class_or_instance, $value) = @_;
52 10895 100       22405 my $instance = ref $class_or_instance ?
53             $class_or_instance : $class_or_instance->instance;
54 10895 100       19982 if (@_ == 1) {
55 10469         41503 return $instance->{$attr};
56             }
57             else {
58 426         2646 return $instance->{$attr} = $value;
59             }
60 767         4113 };
61             }
62              
63             1;
64              
65             __END__