File Coverage

blib/lib/Evo/Class/Meta.pm
Criterion Covered Total %
statement 289 289 100.0
branch 111 174 63.7
condition 26 28 92.8
subroutine 41 41 100.0
pod 7 25 28.0
total 474 557 85.1


line stmt bran cond sub pod time code
1             package Evo::Class::Meta;
2 41     41   17167 use Evo 'Carp croak; Scalar::Util reftype; -Internal::Util; Module::Load ()';
  41         89  
  41         219  
3 41     41   248 use Evo '/::Attrs *; /::Syntax *';
  41         82  
  41         149  
4              
5             our @CARP_NOT = qw(Evo::Class);
6              
7 203 50   203 1 1326 sub register ($me, $package) {
  203 50       560  
  203         385  
  203         322  
  203         321  
8 41     41   289 no strict 'refs'; ## no critic
  41         85  
  41         1194  
9 41     41   228 no warnings 'once';
  41         103  
  41         5617  
10              
11 203   66     306 ${"${package}::EVO_CLASS_ATTRS"} ||= Evo::Class::Attrs->new;
  203         2092  
12              
13 203   100     338 ${"${package}::EVO_CLASS_META"}
  203         1965  
14             ||= bless {package => $package, private => {}, methods => {}, reqs => {}, overridden => {}},
15             $me;
16             }
17              
18 516 50   516 0 1301 sub find_or_croak ($self, $package) {
  516 50       1201  
  516         835  
  516         767  
  516         760  
19 41     41   247 no strict 'refs'; ## no critic
  41         84  
  41         5754  
20 516 100       751 ${"${package}::EVO_CLASS_META"}
  516         3061  
21             or croak qq#$package isn't Evo::Class; "use parent '$package';" for external classes#;
22             }
23              
24 4322 50   4322 0 8502 sub package($self) { $self->{package} }
  4322 50       8162  
  4322         5684  
  4322         5396  
  4322         7341  
25              
26 1862 50   1862 1 6861 sub attrs($self) {
  1862 50       3753  
  1862         2538  
  1862         2423  
27 41     41   234 no strict 'refs'; ## no critic
  41         80  
  41         18423  
28 1862         2812 my $package = $self->{package};
29 1862         2551 ${"${package}::EVO_CLASS_ATTRS"};
  1862         11986  
30             }
31              
32 2767 50   2767 0 5317 sub methods($self) { $self->{methods} }
  2767 50       5188  
  2767         3639  
  2767         3471  
  2767         6484  
33 89 50   89 0 304 sub reqs($self) { $self->{reqs} }
  89 50       323  
  89         280  
  89         258  
  89         367  
34              
35 331 50   331 1 691 sub overridden($self) { $self->{overridden} }
  331 50       658  
  331         463  
  331         457  
  331         840  
36 1840 50   1840 1 3520 sub private($self) { $self->{private} }
  1840 50       3382  
  1840         2369  
  1840         2316  
  1840         5187  
37              
38 16 50   16 0 1369 sub mark_as_overridden ($self, $name) {
  16 50       46  
  16         30  
  16         34  
  16         28  
39 16         122 $self->overridden->{$name} = 1;
40 16         37 $self;
41             }
42              
43 314 50   314 0 710 sub is_overridden ($self, $name) {
  314 50       630  
  314         422  
  314         454  
  314         414  
44 314         586 $self->overridden->{$name};
45             }
46              
47 15 50   15 1 889 sub mark_as_private ($self, $name) {
  15 50       49  
  15         31  
  15         27  
  15         25  
48 15         44 $self->private->{$name} = 1;
49             }
50              
51 1824 50   1824 0 3650 sub is_private ($self, $name) {
  1824 50       3396  
  1824         2425  
  1824         2405  
  1824         2236  
52 1824         3008 $self->private->{$name};
53             }
54              
55             # first check methods (marked as method or inherited), if doesn't exists, try to determine if there is a sub in package
56             # if a sub is compiled in the same package, it's a public, if not(imported or xsub), and not exported function - it's private
57              
58 2551 50   2551 0 6782 sub is_method ($self, $name) {
  2551 50       4898  
  2551         3419  
  2551         3400  
  2551         3186  
59 2551 100       4364 return 1 if $self->methods->{$name};
60 2525         4440 my $pkg = $self->package;
61              
62             {
63 41     41   266 no strict 'refs'; ## no critic
  41         83  
  41         1074  
  2525         3511  
64 41     41   208 no warnings 'once';
  41         77  
  41         48943  
65 2525         3311 my $meta = ${"${pkg}::EVO_EXPORT_META"};
  2525         5559  
66 2525 100 66     5207 return if $meta && $meta->symbols->{$name};
67             }
68              
69 2523 100       5537 my $code = Evo::Internal::Util::names2code($pkg, $name) or return;
70 1469         3177 my ($realpkg, $realname, $xsub) = Evo::Internal::Util::code2names($code);
71 1469   100     7577 return !$xsub && $realpkg eq $pkg;
72             }
73              
74 1234 50   1234 0 4690 sub is_attr ($self, $name) {
  1234 50       2473  
  1234         1689  
  1234         1680  
  1234         1571  
75 1234         2252 $self->attrs->exists($name);
76             }
77              
78 722 50   722   1542 sub _check_valid_name ($self, $name) {
  722 50       1491  
  722         1005  
  722         1097  
  722         959  
79 722 100       1749 croak(qq{"$name" is invalid name}) unless Evo::Internal::Util::check_subname($name);
80             }
81              
82 920 50   920   1984 sub _check_exists ($self, $name) {
  920 50       1888  
  920         1311  
  920         1275  
  920         1202  
83 920         1749 my $pkg = $self->package;
84 920 100       1879 croak qq{$pkg already has attribute "$name"} if $self->is_attr($name);
85 915 100       2117 croak qq{$pkg already has method "$name"} if $self->is_method($name);
86             }
87              
88 714 50   714   1598 sub _check_exists_valid_name ($self, $name) {
  714 50       1545  
  714         1019  
  714         1007  
  714         946  
89 714         1593 _check_valid_name($self, $name);
90 712         1619 _check_exists($self, $name);
91             }
92              
93 493 50   493   1193 sub _reg_parsed_attr ($self, %opts) {
  493 50       1134  
  493         728  
  493         1816  
  493         875  
94 493         810 my $name = $opts{name};
95 493         1184 _check_exists_valid_name($self, $name);
96 487         1081 my $pkg = $self->package;
97 487 100       1140 croak qq{$pkg already has subroutine "$name"} if Evo::Internal::Util::names2code($pkg, $name);
98              
99 484         1026 my $sub = $self->attrs->gen_attr(%opts); # register
100 484 100       2187 Evo::Internal::Util::monkey_patch $pkg, $name, $sub if $opts{method};
101             }
102              
103 8 50   8   29 sub _reg_parsed_attr_over ($self, %opts) {
  8 50       32  
  8         12  
  8         35  
  8         16  
104 8         17 my $name = $opts{name};
105 8         21 _check_valid_name($self, $name);
106 8         33 $self->mark_as_overridden($name);
107 8         19 my $sub = $self->attrs->gen_attr(%opts); # register
108 8         42 my $pkg = $self->package;
109 8 100       39 Evo::Internal::Util::monkey_patch_silent $pkg, $name, $sub if $opts{method};
110             }
111              
112 403 50   403 0 1324 sub reg_attr ($self, $name, @attr) {
  403         621  
  403         651  
  403         897  
  403         642  
113 403         981 my %opts = $self->parse_attr($name, @attr);
114 403         1464 $self->_reg_parsed_attr(%opts);
115             }
116              
117 8 50   8 0 28 sub reg_attr_over ($self, $name, @attr) {
  8         14  
  8         16  
  8         21  
  8         15  
118 8         24 my %opts = $self->parse_attr($name, @attr);
119 8         40 $self->_reg_parsed_attr_over(%opts);
120             }
121              
122             # means register external sub as method. Because every sub in the current package
123             # is public by default
124 221 50   221 1 640 sub reg_method ($self, $name) {
  221 50       471  
  221         313  
  221         327  
  221         290  
125 221         485 _check_exists_valid_name($self, $name);
126 217         466 my $pkg = $self->package;
127 217 100       483 my $code = Evo::Internal::Util::names2code($pkg, $name) or croak "$pkg::$name doesn't exist";
128 215         462 $self->methods->{$name}++;
129             }
130              
131 57 50   57   220 sub _public_attrs_slots($self) {
  57 50       136  
  57         108  
  57         149  
132 57         140 grep { !$self->is_private($_->{name}) } $self->attrs->slots;
  188         396  
133             }
134              
135             # not marked as private
136             # was compiled in the same package, not constant, not exported lib
137 61 50   61   170 sub _public_methods_map($self) {
  61 50       160  
  61         105  
  61         92  
138 61         126 my $pkg = $self->package;
139 435         883 map { ($_, Evo::Internal::Util::names2code($pkg, $_)) }
140 61 100       290 grep { !$self->is_private($_) && $self->is_method($_) }
  1634         3045  
141             Evo::Internal::Util::list_symbols($pkg);
142             }
143              
144 26 50   26 0 1090 sub public_attrs($self) {
  26 50       85  
  26         75  
  26         53  
145 26         67 map { $_->{name} } $self->_public_attrs_slots;
  92         216  
146             }
147              
148 27 50   27 0 94 sub public_methods($self) {
  27 50       97  
  27         69  
  27         51  
149 27         82 my %map = $self->_public_methods_map;
150 27         392 keys %map;
151             }
152              
153              
154 32 50   32 0 152 sub extend_with ($self, $source_p) {
  32 50       98  
  32         64  
  32         62  
  32         58  
155 32         99 $source_p = Evo::Internal::Util::resolve_package($self->package, $source_p);
156 32         170 Module::Load::load($source_p);
157 32         543 my $source = $self->find_or_croak($source_p);
158 31         86 my $dest_p = $self->package;
159 31         84 my %reqs = $source->reqs()->%*;
160 31         108 my %methods = $source->_public_methods_map();
161              
162 31         137 my @new_attrs;
163 31         160 foreach my $name (keys %reqs) { $self->reg_requirement($name); }
  14         199  
164              
165 31         110 foreach my $slot ($source->_public_attrs_slots) {
166 93 100       233 next if $self->is_overridden($slot->{name});
167 90         353 $self->_reg_parsed_attr(%$slot);
168 87         244 push @new_attrs, $slot->{name};
169             }
170              
171 28         209 foreach my $name (keys %methods) {
172 215 100       449 next if $self->is_overridden($name);
173 211 100       481 croak qq/$dest_p already has a subroutine with name "$name"/
174             if Evo::Internal::Util::names2code($dest_p, $name);
175 208         540 _check_exists($self, $name); # prevent patching before check
176 208         594 Evo::Internal::Util::monkey_patch $dest_p, $name, $methods{$name};
177 208         468 $self->reg_method($name);
178             }
179              
180 41     41   302 no strict 'refs'; ## no critic
  41         87  
  41         27110  
181 25         63 push @{"${dest_p}::ISA"}, $source_p;
  25         340  
182 25         132 @new_attrs;
183             }
184              
185              
186 33 50   33 0 386 sub reg_requirement ($self, $name) {
  33 50       95  
  33         63  
  33         59  
  33         53  
187 33         93 $self->reqs->{$name}++;
188             }
189              
190 23 50   23 0 139 sub requirements($self) {
  23 50       70  
  23         45  
  23         117  
191 23         63 (keys($self->reqs->%*), $self->public_attrs, $self->public_methods);
192             }
193              
194 20 50   20 1 93 sub check_implementation ($self, $inter_class) {
  20 50       71  
  20         43  
  20         37  
  20         33  
195 20         54 $inter_class = Evo::Internal::Util::resolve_package($self->package, $inter_class);
196 20         143 Module::Load::load($inter_class);
197 20         1219 my $class = $self->package;
198 20         59 my $inter = $self->find_or_croak($inter_class);
199 19         85 my @reqs = sort $inter->requirements;
200              
201 19   100     66 my @not_exists = grep { !($self->is_attr($_) || $class->can($_)); } @reqs;
  305         614  
202 19 100       163 return $self if !@not_exists;
203              
204 3         269 croak qq/Bad implementation of "$inter_class", missing in "$class": /, join ';', @not_exists;
205             }
206              
207             # -- class methods for usage from other modules too
208              
209              
210             # rtype: default, default_code, required, lazy, relaxed
211             # rvalue is used as meta for required(di), default and lazy
212             # check?
213             # is_ro?
214              
215 449 50   449 0 1726 sub parse_attr ($me, $name, @attr) {
  449         685  
  449         704  
  449         917  
  449         659  
216 449         807 my @scalars = grep { $_ ne SYNTAX_STATE } @attr;
  339         1170  
217 449 100       1318 croak "expected 1 scalar, got: " . join ',', @scalars if @scalars > 1;
218 448         1211 my %state = syntax_reset;
219              
220             croak qq#"optional" flag makes no sense with default("$scalars[0]")#
221 448 100 100     1763 if $state{optional} && @scalars;
222             croak qq#"lazy" requires code reference#
223 447 100 100     1568 if $state{lazy} && (reftype($scalars[0]) // '') ne 'CODE';
      100        
224 444 100 100     1792 croak qq#default("$scalars[0]") should be either a scalar or a code reference#
      100        
225             if @scalars && ref($scalars[0]) && reftype($scalars[0]) ne 'CODE';
226              
227              
228 443         713 my $type;
229 443 50       1316 if ($state{optional}) { $type = ECA_OPTIONAL if $state{optional}; }
  141 100       359  
    100          
    100          
230 14 50       40 elsif ($state{lazy}) { $type = ECA_LAZY if $state{lazy}; }
231 66 100       205 elsif (@scalars) { $type = ref($scalars[0]) ? ECA_DEFAULT_CODE : ECA_DEFAULT; }
232 222         389 else { $type = ECA_REQUIRED; }
233              
234             return (
235             name => $name,
236             type => $type,
237             value => $scalars[0],
238             check => $state{check},
239             ro => !!$state{ro},
240             inject => $state{inject},
241             method => !$state{no_method},
242 443         2862 );
243             }
244              
245 1 50   1 0 7 sub info($self) {
  1 50       4  
  1         2  
  1         1  
246 1         4 my %info = (
247             public => {
248             methods => [sort $self->public_methods],
249             attrs => [sort $self->public_attrs],
250             reqs => [sort keys($self->reqs->%*)],
251             },
252             overridden => [sort keys($self->overridden->%*)],
253             private => [sort keys($self->private->%*)],
254             );
255 1         16 \%info;
256             }
257              
258              
259             1;
260              
261             __END__