File Coverage

blib/lib/DBIx/DataModel/Meta/Utils.pm
Criterion Covered Total %
statement 89 92 96.7
branch 11 16 68.7
condition 5 12 41.6
subroutine 25 25 100.0
pod 3 4 75.0
total 133 149 89.2


line stmt bran cond sub pod time code
1             package DBIx::DataModel::Meta::Utils;
2 19     19   143 use strict;
  19         37  
  19         604  
3 19     19   98 use warnings;
  19         41  
  19         483  
4              
5 19     19   99 use strict;
  19         36  
  19         394  
6 19     19   107 use warnings;
  19         59  
  19         576  
7              
8 19     19   116 use Carp;
  19         38  
  19         1499  
9 19     19   9736 use Module::Load qw/load/;
  19         21743  
  19         132  
10 19         1741 use Params::Validate qw/validate_with SCALAR ARRAYREF CODEREF
11 19     19   9536 BOOLEAN OBJECT HASHREF/;
  19         143415  
12 19     19   11199 use List::MoreUtils qw/any/;
  19         265573  
  19         128  
13 19     19   20864 use mro qw/c3/;
  19         45  
  19         182  
14 19     19   12756 use SQL::Abstract::More 1.39;
  19         351944  
  19         160  
15 19     19   221056 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  19         60101  
  19         148  
16              
17             # utility function 'does' imported by hand because not really meant
18             # to be publicly exportable from SQL::Abstract::More
19 19     19   2509 BEGIN {no strict 'refs'; *does = \&SQL::Abstract::More::does;}
  19     19   49  
  19         623  
  19         432  
20              
21 19     19   110 use Exporter qw/import/;
  19         47  
  19         3853  
22             our @EXPORT = qw/define_class define_method
23             define_readonly_accessors define_abstract_methods
24             does/;
25              
26              
27              
28              
29              
30             my %seen_class_method;
31              
32             sub _check_call_as_class_method {
33 1021     1021   1688 my $first_arg = $_[0];
34              
35 1021 50 33     7977 if ($first_arg && !ref $first_arg && $first_arg->isa(__PACKAGE__) ) {
      33        
36 0         0 my $func = (caller(1))[3];
37             carp "calling $func() as class method is obsolete; import and call as a function"
38 0 0       0 unless $seen_class_method{$func}++;
39 0         0 shift @_;
40             }
41             }
42              
43              
44              
45             sub define_class {
46 102     102 1 3520 &_check_call_as_class_method;
47              
48             # check parameters
49 102         3278 my %params = validate_with(
50             params => \@_,
51             spec => {
52             name => {type => SCALAR },
53             isa => {type => ARRAYREF},
54             metadm => {isa => 'DBIx::DataModel::Meta'},
55             },
56             allow_extra => 0,
57             );
58              
59             # deactivate strict refs because we'll be playing with symbol tables
60 19     19   159 no strict 'refs';
  19         53  
  19         6618  
61              
62             # make sure that all parents are defined
63 102         679 foreach my $parent (@{$params{isa}}) {
  102         436  
64              
65             # heuristics to decide if a class is loaded (can't rely on %INC)
66 182     173   602 my $is_class_defined = any {! /::$/} keys %{$parent.'::'};
  173         558  
  182         1549  
67             # NOTE : we need to exclude symbols ending with '::' because
68             # "require Foo::Bar::Buz" will define ${Foo::Bar::}{'Buz::'} at
69             # compilation time, even if this statement is never executed.
70              
71             # try to load parent if needed
72 182 100       831 load $parent unless $is_class_defined;
73             };
74              
75             # inject parents into @ISA
76 102         494 my $class_isa = $params{name}."::ISA";
77 102 100       170 not @{$class_isa} or croak "won't overwrite \@$class_isa";
  102         769  
78 100         207 @{$class_isa} = @{$params{isa}};
  100         2345  
  100         289  
79              
80             # use mro 'c3' in that package
81 100         851 mro::set_mro($params{name}, 'c3');
82              
83             # install an accessor to the metaclass object within the package
84             define_method(class => $params{name},
85             name => 'metadm',
86 3092     3092   23057 body => sub {return $params{metadm}},
87 100         659 check_override => 0, );
88             }
89              
90              
91             sub define_method {
92 835     835 1 1955 &_check_call_as_class_method;
93              
94             # check parameters
95 835         21313 my %params = validate_with(
96             params => \@_,
97             spec => {
98             class => {type => SCALAR },
99             name => {type => SCALAR },
100             body => {type => CODEREF },
101             check_override => {type => BOOLEAN, default => 1},
102             },
103             allow_extra => 0,
104             );
105              
106             # fully qualified name
107 835         5872 my $full_method_name = $params{class}.'::'.$params{name};
108              
109             # deactiveate strict refs because we'll be playing with symbol tables
110 19     19   166 no strict 'refs';
  19         43  
  19         7471  
111              
112             # check if method is already there
113 835 50       1327 not defined(&{$full_method_name})
  835         4249  
114             or croak "method $full_method_name is already defined";
115              
116             # check if there is a conflict with an inherited method
117             !$params{check_override} or not $params{class}->can($params{name})
118 835 50 66     6052 or carp "method $params{name} in $params{class} will be overridden";
119              
120             # install the method
121 835         1433 *{$full_method_name} = $params{body};
  835         4073  
122             }
123              
124              
125             sub define_readonly_accessors {
126 84     84 1 317 &_check_call_as_class_method;
127              
128 84         392 my ($target_class, @accessors) = @_;
129              
130 84         257 foreach my $accessor (@accessors) {
131             define_method(
132             class => $target_class,
133             name => $accessor,
134 4520     4520   6962 body => sub { my $self = shift;
135 4520         8336 my $val = $self->{$accessor};
136 4520         8706 for (ref $val) {
137 4520 100       11156 /^ARRAY$/ and return @$val;
138 4051 100       7541 /^HASH$/ and return %$val;
139 3990         14409 return $val; # otherwise
140             }
141             },
142 599         2500 );
143             }
144             }
145              
146             sub define_abstract_methods {
147 25     25 0 113 my ($target_class, @methods) = @_;
148              
149 25         76 foreach my $method (@methods) {
150             define_method(
151             class => $target_class,
152             name => $method,
153 1     1   19 body => sub { my $self = shift;
154 1   33     5 my $subclass = ref $self || $self;
155 1         11 die "$subclass should implement a $method() method, as required by $target_class";
156             },
157 43         236 );
158             }
159             }
160              
161              
162              
163             1;
164              
165             __END__