File Coverage

blib/lib/Class/SingletonMethod.pm
Criterion Covered Total %
statement 18 18 100.0
branch 2 2 100.0
condition n/a
subroutine 4 4 100.0
pod 0 1 0.0
total 24 25 96.0


line stmt bran cond sub pod time code
1             package Class::SingletonMethod;
2              
3 1     1   1007 use 5.006;
  1         3  
  1         71  
4              
5             our $VERSION = '1.0';
6              
7             1;
8              
9             package UNIVERSAL;
10            
11 1     1   5 no warnings; no strict; # no guarantee
  1     1   3  
  1         43  
  1         14  
  1         2  
  1         172  
12              
13             sub singleton_method {
14 2     2 0 1657 my ($object, $method, $subref) = @_;
15            
16 2         3 my $parent_class = ref $object;
17 2         9 my $new_class = "_Singletons::".(0+$object);
18 2         3 *{$new_class."::".$method} = $subref;
  2         17  
19 2 100       9 if ($new_class ne $parent_class) {
20 1         2 @{$new_class."::ISA"} = ($parent_class);
  1         19  
21 1         5 bless $object, $new_class;
22             }
23             }
24              
25             __END__