File Coverage

lib/Badger/Prototype.pm
Criterion Covered Total %
statement 31 31 100.0
branch 6 6 100.0
condition 5 9 55.5
subroutine 7 7 100.0
pod 2 2 100.0
total 51 55 92.7


line stmt bran cond sub pod time code
1             #========================================================================
2             #
3             # Badger::Prototype
4             #
5             # DESCRIPTION
6             # Base class module for a protoype class that has a default instance
7             # that can be created on demand.
8             #
9             # AUTHOR
10             # Andy Wardley
11             #
12             #========================================================================
13              
14             package Badger::Prototype;
15              
16             use Badger::Class
17 70         857 base => 'Badger::Base',
18             version => 0.01,
19             debug => 0,
20             constants => 'PKG REFS ONCE',
21 70     70   454 words => 'PROTOTYPE';
  70         119  
22              
23             sub prototype {
24 6316     6316 1 7600 my $class = shift;
25 6316 100       13160 return $class if ref $class;
26 70     70   468 no strict REFS;
  70         140  
  70         2175  
27 70     70   357 no warnings ONCE;
  70         135  
  70         10574  
28            
29 2034 100 66     5669 if (@_ == 1 && ! defined $_[0]) {
    100          
30             # if only a single undef argument is provided, then clear any
31             # prototype from $PROTOTYPE and return a reference to it.
32 1         2 my $proto = ${$class.PKG.PROTOTYPE};
  1         4  
33 1         1 undef ${$class.PKG.PROTOTYPE};
  1         3  
34 1         3 return $proto;
35             }
36             elsif (@_) {
37             # if any other arguments are provided then it forces us to create
38             # a new prototype with the fresh configuration options.
39 1         1 undef ${$class.PKG.PROTOTYPE};
  1         5  
40             }
41            
42             # return the cached value (assuming we didn't just clear it) or create
43             # a new one (if we did, or if there wasn't a previous value)
44 2033   66     2268 return ${$class.PKG.PROTOTYPE} ||= $class->new(@_);
  2033         9524  
45             }
46              
47             sub has_prototype {
48 2     2 1 8 my $self = shift;
49 2   33     9 my $class = ref $self || $self;
50 70     70   442 no strict REFS;
  70         132  
  70         2289  
51 70     70   462 no warnings ONCE;
  70         165  
  70         4930  
52 2         2 defined ${$class.PKG.PROTOTYPE};
  2         14  
53             }
54            
55              
56             1;
57              
58             __END__