File Coverage

blib/lib/HO/abstract.pm
Criterion Covered Total %
statement 32 34 94.1
branch 10 12 83.3
condition n/a
subroutine 9 9 100.0
pod 2 2 100.0
total 53 57 92.9


line stmt bran cond sub pod time code
1             package HO::abstract;
2             # *******************
3 3     3   61284 use strict; use warnings;
  3     3   13  
  3         76  
  3         13  
  3         5  
  3         98  
4             our $VERSION='0.02';
5             # ******************
6              
7             ; use Package::Subroutine ()
8 3     3   409 ; use Carp ()
  3         2829  
  3         38  
9              
10 3     3   14 ; our $METHOD_DIE = sub
  3         12  
  3         1227  
11             { my ($method) = @_
12             ; return sub
13 2     2   1053 { my $pkg = $_[0];
14 2 100       7 ; if(ref($_[0]))
15 1         2 { $pkg = ref($_[0])
16             }
17 2         18 ; Carp::croak("Class '$pkg' does not override ${method}()")
18             }
19             }
20              
21             ; our $CLASS_DIE = sub
22             { my ($class) = @_
23             ; return sub
24 5     5   9 { my $instanceof = ref($_[0])
25 5 50       25 ; if($instanceof eq $class)
26 5         55 { Carp::croak("Abstract class '$class' should not be instantiated.")
27             }
28             else
29 0           { Carp::croak("Class '$instanceof' should overwrite method init from abstract class '$class'.")
30             }
31             }
32             }
33              
34             ; { our $target
35              
36             ; sub abstract_method
37 1     1 1 2 { my @methods = @_
38 1 50       3 ; unless(defined($target))
39 0         0 { Carp::croak("No target class defined!")
40             }
41 1         1 ; foreach my $method (@methods)
42 1         10 { install Package::Subroutine::
43             $target => $method => $METHOD_DIE->($method)
44             }
45             }
46              
47             ; sub abstract_class
48 3 100   3 1 9 { my (@classes) = @_ ? @_ : ($target)
49 3         5 ; foreach my $class (@classes)
50 5         20 { install Package::Subroutine::
51             $class => 'init' => $CLASS_DIE->($class)
52             }
53             }
54              
55             ; sub import
56 6     6   1028 { my ($self,$action,@params) = @_
57 6 100       23 ; return unless defined $action
58 5         12 ; local $target = caller
59              
60             ; my $perform =
61             { 'method' => \&abstract_method
62             , 'class' => \&abstract_class
63 5         99 }->{$action}
64 5 100       23 ; die "Unknown action '$action' in use of HO::abstract." unless $perform
65              
66 4         9 ; $perform->(@params)
67             }
68             }
69              
70             ; 1
71              
72             __END__