File Coverage

blib/lib/MOP/Internal/Util.pm
Criterion Covered Total %
statement 181 194 93.3
branch 59 110 53.6
condition 25 56 44.6
subroutine 35 35 100.0
pod 0 19 0.0
total 300 414 72.4


line stmt bran cond sub pod time code
1             package MOP::Internal::Util;
2             # ABSTRACT: For MOP Internal Use Only
3              
4 35     35   197 use strict;
  35         52  
  35         794  
5 35     35   129 use warnings;
  35         65  
  35         671  
6              
7 35     35   133 use B (); # nasty stuff, all nasty stuff
  35         52  
  35         346  
8 35     35   173 use Carp (); # errors and stuff
  35         57  
  35         393  
9 35     35   3808 use Sub::Util (); # handling some sub stuff
  35         2861  
  35         465  
10 35     35   12487 use Sub::Metadata (); # handling other sub stuff
  35         16116  
  35         625  
11 35     35   12354 use Symbol (); # creating the occasional symbol
  35         21659  
  35         650  
12 35     35   172 use Scalar::Util (); # I think I use blessed somewhere in here ...
  35         167  
  35         391  
13 35     35   12740 use Devel::OverloadInfo (); # Sometimes I need to know about overloading
  35         356125  
  35         647  
14 35     35   11552 use Devel::Hook (); # for scheduling UNITCHECK blocks ...
  35         25605  
  35         14022  
15              
16             our $VERSION = '0.14';
17             our $AUTHORITY = 'cpan:STEVAN';
18              
19             ## ------------------------------------------------------------------
20             ## Basic Glob access
21             ## ------------------------------------------------------------------
22              
23             sub IS_VALID_MODULE_NAME {
24 117     117 0 198 my ($name) = @_;
25 117         667 $name =~ /[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/
26             }
27              
28             sub IS_STASH_REF {
29 4     4 0 7 my ($stash) = @_;
30 4 50       8 Carp::confess('[ARGS] You must specify a stash')
31             unless defined $stash;
32 4 100       19 if ( my $name = B::svref_2object( $stash )->NAME ) {
33 2         5 return IS_VALID_MODULE_NAME( $name );
34             }
35 2         6 return;
36             }
37              
38             sub GET_NAME {
39 1135     1135 0 1395 my ($stash) = @_;
40 1135 50       1709 Carp::confess('[ARGS] You must specify a stash')
41             unless defined $stash;
42 1135         3799 B::svref_2object( $stash )->NAME
43             }
44              
45             sub GET_STASH_NAME {
46 91     91 0 163 my ($stash) = @_;
47 91 50       160 Carp::confess('[ARGS] You must specify a stash')
48             unless defined $stash;
49 91         1178 B::svref_2object( $stash )->STASH->NAME
50             }
51              
52             sub GET_GLOB_NAME {
53 546     546 0 686 my ($stash) = @_;
54 546 50       765 Carp::confess('[ARGS] You must specify a stash')
55             unless defined $stash;
56 546         1807 B::svref_2object( $stash )->GV->NAME
57             }
58              
59             sub GET_GLOB_STASH_NAME {
60 611     611 0 731 my ($stash) = @_;
61 611 50       872 Carp::confess('[ARGS] You must specify a stash')
62             unless defined $stash;
63 611         3013 B::svref_2object( $stash )->GV->STASH->NAME
64             }
65              
66             sub GET_GLOB_SLOT {
67 1627     1627 0 2273 my ($stash, $name, $slot) = @_;
68              
69 1627 50       2360 Carp::confess('[ARGS] You must specify a stash')
70             unless defined $stash;
71 1627 50       2036 Carp::confess('[ARGS] You must specify a name')
72             unless defined $name;
73 1627 50       2037 Carp::confess('[ARGS] You must specify a slot')
74             unless defined $slot;
75              
76             # do my best to not autovivify, and
77             # return undef if not
78 1627 100       2495 return unless exists $stash->{ $name };
79             # occasionally we need to auto-inflate
80             # the optimized version of a required
81             # method, its annoying, but the XS side
82             # should not have to care about this so
83             # it can be removed eventually.
84 1471 50 100     6449 if (( $slot eq 'CODE' && $stash->{ $name } eq "-1" ) || ref $stash->{ $name } ne 'GLOB') {
      66        
85 1471         5729 B::svref_2object( $stash )->NAME->can( $name );
86             }
87              
88              
89             # return the reference stored in the glob
90             # which might be undef, but that can be
91             # handled by the caller
92 1471         2428 return *{ $stash->{ $name } }{ $slot };
  1471         4796  
93             }
94              
95             sub SET_GLOB_SLOT {
96 4     4 0 11 my ($stash, $name, $value_ref) = @_;
97              
98 4 50       12 Carp::confess('[ARGS] You must specify a stash')
99             unless defined $stash;
100 4 50       9 Carp::confess('[ARGS] You must specify a name')
101             unless defined $name;
102 4 50       17 Carp::confess('[ARGS] You must specify a value REF')
103             unless defined $value_ref;
104              
105             {
106 35     35   235 no strict 'refs';
  35         72  
  35         1161  
  4         7  
107 35     35   191 no warnings 'once';
  35         68  
  35         18395  
108             # get the name of the stash, we could have
109             # passed this in, but it is easy to get in
110             # XS, and so we can punt that down the road
111             # for the time being
112 4         23 my $pkg = B::svref_2object( $stash )->NAME;
113 4         8 *{ $pkg . '::' . $name } = $value_ref;
  4         26  
114             }
115 4         10 return;
116             }
117              
118             ## ------------------------------------------------------------------
119             ## UNITCHECK hook
120             ## ------------------------------------------------------------------
121              
122             sub ADD_UNITCHECK_HOOK {
123 5     5 0 8 my ($cv) = @_;
124 5 50       24 Carp::confess('[ARGS] You must specify a CODE reference')
125             unless $cv;
126 5 50 33     26 Carp::confess('[ARGS] You must specify a CODE reference')
127             unless $cv && ref $cv eq 'CODE';
128 5         23 Devel::Hook->push_UNITCHECK_hook( $cv );
129             }
130              
131             ## ------------------------------------------------------------------
132             ## CV/Glob introspection
133             ## ------------------------------------------------------------------
134              
135             sub CAN_COERCE_TO_CODE_REF {
136 119     119 0 192 my ($object) = @_;
137 119 100 66     842 return 0 unless $object && Scalar::Util::blessed( $object );
138             # might be just a blessed CODE ref ...
139 26 50       112 return 1 if Scalar::Util::reftype( $object ) eq 'CODE';
140             # or might be overloaded object ...
141 0 0       0 return 0 unless Devel::OverloadInfo::is_overloaded( $object );
142 0         0 return exists Devel::OverloadInfo::overload_info( $object )->{'&{}'};
143             }
144              
145             sub IS_CV_NULL {
146 929     929 0 1067 my ($cv) = @_;
147 929 50       1240 Carp::confess('[ARGS] You must specify a CODE reference')
148             unless $cv;
149 929 50 33     2311 Carp::confess('[ARGS] You must specify a CODE reference')
      33        
150             unless $cv && ref $cv eq 'CODE'
151             || CAN_COERCE_TO_CODE_REF( $cv );
152 929         2257 return Sub::Metadata::sub_body_type( $cv ) eq 'UNDEF';
153             }
154              
155             sub DOES_GLOB_HAVE_NULL_CV {
156 166     166 0 462 my ($glob) = @_;
157 166 50       309 Carp::confess('[ARGS] You must specify a GLOB')
158             unless $glob;
159              
160             # The glob may be -1 or a string, which is perl’s way
161             # of optimizing null sub declarations like ‘sub foo;’
162             # and ‘sub bar($);’.
163 166 100 66     419 return 1 if ref \$glob eq 'SCALAR' && defined $glob;
164             # We may have a reference to a scalar or array, which
165             # represents a constant, so is not a null sub.
166 165 50 33     355 return 0 if ref $glob and ref $glob ne 'CODE';
167             # next lets see if we have a CODE slot (or a code
168             # reference instead of a glob) ...
169 165 50       258 if ( my $code = ref $glob ? $glob : *{ $glob }{CODE} ) {
  165 100       514  
170 141         792 return Sub::Metadata::sub_body_type( $code ) eq 'UNDEF';
171             }
172              
173             # if we had no CODE slot, it can't be a NULL CV ...
174 24         70 return 0;
175             }
176              
177             sub CREATE_NULL_CV {
178 3     3 0 6 my ($in_pkg, $name) = @_;
179 3 50       6 Carp::confess('[ARGS] You must specify a package name')
180             unless defined $in_pkg;
181 3 50       5 Carp::confess('[ARGS] You must specify a name')
182             unless defined $name;
183             # this just tries to eval the NULL CV into
184             # place, it is ugly, but works for now
185 3 100       140 eval "sub ${in_pkg}::${name}; 1;" or do { Carp::confess($@) };
  1         146  
186 2         6 return;
187             }
188              
189             sub SET_COMP_STASH_FOR_CV {
190 3     3 0 8 my ($cv, $in_pkg) = @_;
191 3 50       9 Carp::confess('[ARGS] You must specify a CODE reference')
192             unless $cv;
193 3 50       8 Carp::confess('[ARGS] You must specify a package name')
194             unless defined $in_pkg;
195 3 50 66     20 Carp::confess('[ARGS] You must specify a CODE reference')
      66        
196             unless $cv && ref $cv eq 'CODE'
197             || CAN_COERCE_TO_CODE_REF( $cv );
198 3         14 Sub::Metadata::mutate_sub_package( $cv, $in_pkg );
199             }
200              
201             sub INSTALL_CV {
202 422     422 0 678 my ($in_pkg, $name, $cv, %opts) = @_;
203              
204 422 50       619 Carp::confess('[ARGS] You must specify a package name')
205             unless defined $in_pkg;
206 422 50       514 Carp::confess('[ARGS] You must specify a name')
207             unless defined $name;
208 422 50 33     1061 Carp::confess('[ARGS] You must specify a CODE reference')
      33        
209             unless $cv && ref $cv eq 'CODE'
210             || CAN_COERCE_TO_CODE_REF( $cv );
211             Carp::confess("[ARGS] You must specify a boolean value for `set_subname` option")
212 422 50       559 if not exists $opts{set_subname};
213              
214             {
215 35     35   224 no strict 'refs';
  35         63  
  35         1052  
  422         408  
216 35     35   171 no warnings 'once', 'redefine';
  35         62  
  35         5885  
217              
218 422         590 my $fullname = $in_pkg.'::'.$name;
219 422 100       559 *{$fullname} = $opts{set_subname} ? Sub::Util::set_subname($fullname, $cv) : $cv;
  422         1374  
220             }
221 422         760 return;
222             }
223              
224             sub REMOVE_CV_FROM_GLOB {
225 4     4 0 9 my ($stash, $name) = @_;
226              
227 4 50 33     27 Carp::confess('[ARGS] You must specify a stash')
228             unless $stash && ref $stash eq 'HASH';
229 4 50       14 Carp::confess('[ARGS] You must specify a name')
230             unless defined $name;
231              
232             # find the glob we are looking for
233             # which might not exist, in which
234             # case we do nothing ....
235 4 50       15 if ( my $glob = $stash->{ $name } ) {
236             # once we find it, extract all the
237             # slots we need, note the missing
238             # CODE slot since we don't need
239             # that in our new glob ...
240 4         16 my %to_save;
241 4         11 foreach my $slot (qw[ SCALAR ARRAY HASH FORMAT IO ]) {
242 20 100       22 if ( my $val = *{ $glob }{ $slot } ) {
  20         67  
243 4         16 $to_save{ $slot } = $val;
244             }
245             }
246             # replace the old glob with a new one ...
247 4         16 $stash->{ $name } = Symbol::gensym();
248             # now go about constructing our new
249             # glob by restoring the other slots
250             {
251 35     35   203 no strict 'refs';
  35         62  
  35         1049  
  4         61  
252 35     35   195 no warnings 'once';
  35         60  
  35         26057  
253             # get the name of the stash, we could have
254             # passed this in, but it is easy to get in
255             # XS, and so we can punt that down the road
256             # for the time being
257 4         16 my $pkg = B::svref_2object( $stash )->NAME;
258 4         15 foreach my $type ( keys %to_save ) {
259 4         6 *{ $pkg . '::' . $name } = $to_save{ $type };
  4         15  
260             }
261             }
262             }
263             # ... the end
264 4         13 return;
265             }
266              
267             ## ------------------------------------------------------------------
268             ## Role application and composition
269             ## ------------------------------------------------------------------
270              
271             sub APPLY_ROLES {
272 16     16 0 291 my ($meta, $roles) = @_;
273              
274 16 50       59 Carp::confess('[ARGS] You must specify a metaclass to apply roles to')
275             unless Scalar::Util::blessed( $meta );
276 16 50 33     296 Carp::confess('[ARGS] You must specify a least one roles to apply as an ARRAY ref')
      33        
277             unless $roles && ref $roles eq 'ARRAY' && scalar( @$roles ) != 0;
278              
279 16         57 foreach my $r ( $meta->roles ) {
280             Carp::confess("[ERROR] Could not find role ($_) in the set of roles in $meta (" . $meta->name . ")")
281 18 50       31 unless scalar grep { $r eq $_ } @$roles;
  22         76  
282             }
283              
284 16         29 my @meta_roles = map { MOP::Role->new( name => $_ ) } @$roles;
  18         108  
285              
286             my (
287 16         234 $slots,
288             $slot_conflicts
289             ) = COMPOSE_ALL_ROLE_SLOTS( @meta_roles );
290              
291 16 50       55 Carp::confess("[CONFLICT] There should be no conflicting slots when composing (" . (join ', ' => @$roles) . ") into (" . $meta->name . ")")
292             if scalar keys %$slot_conflicts;
293              
294 16         37 foreach my $name ( keys %$slots ) {
295             # if we have a slot already by that name ...
296 0 0       0 Carp::confess("[CONFLICT] Role Conflict, cannot compose slot ($name) into (" . $meta->name . ") because ($name) already exists")
297             if $meta->has_slot( $name );
298             # otherwise alias it ...
299 0         0 $meta->alias_slot( $name, $slots->{ $name } );
300             }
301              
302             my (
303 16         32 $methods,
304             $method_conflicts,
305             $required_methods
306             ) = COMPOSE_ALL_ROLE_METHODS( @meta_roles );
307              
308             Carp::confess("[CONFLICT] There should be no conflicting methods when composing (" . (join ', ' => @$roles) . ") into (" . $meta->name . ") but instead we found (" . (join ', ' => keys %$method_conflicts) . ")")
309             if (scalar keys %$method_conflicts) # do we have any conflicts ...
310             # and the conflicts are not satisfied by the composing item ...
311 16 0 50     67 && (scalar grep { !$meta->has_method( $_ ) } keys %$method_conflicts);
  0         0  
312              
313             # check the required method set and
314             # see if what we are composing into
315             # happens to fulfill them
316 16         37 foreach my $name ( keys %$required_methods ) {
317 3 50       7 delete $required_methods->{ $name }
318             if $meta->name->can( $name );
319             }
320              
321 16 50       39 Carp::confess("[CONFLICT] There should be no required methods when composing (" . (join ', ' => @$roles) . ") into (" . $meta->name . ") but instead we found (" . (join ', ' => keys %$required_methods) . ")")
322             if scalar keys %$required_methods; # do we have required methods ...
323              
324 16         71 foreach my $name ( keys %$methods ) {
325             # if we have a method already by that name ...
326 419 50       646 next if $meta->has_method( $name );
327             # otherwise, alias it ...
328 419         663 $meta->alias_method( $name, $methods->{ $name } );
329             }
330              
331             # if we still have keys in $required, it is
332             # because we are a role (class would have
333             # died above), so we can just stuff in the
334             # required methods ...
335 16         61 $meta->add_required_method( $_ ) for keys %$required_methods;
336              
337 16         106 return;
338             }
339              
340             sub COMPOSE_ALL_ROLE_SLOTS {
341 16     16 0 38 my @roles = @_;
342              
343 16 50       41 Carp::confess('[ARGS] You must specify a least one role to compose slots in')
344             if scalar( @roles ) == 0;
345              
346 16         31 my (%slots, %conflicts);
347              
348 16         26 foreach my $role ( @roles ) {
349 18         43 foreach my $slot ( $role->slots ) {
350 0         0 my $name = $slot->name;
351             # if we have one already, but
352             # it is not the same refaddr ...
353 0 0 0     0 if ( exists $slots{ $name } && $slots{ $name } != $slot->initializer ) {
354             # mark it as a conflict ...
355 0         0 $conflicts{ $name } = undef;
356             # and remove it from our slot set ...
357 0         0 delete $slots{ $name };
358             }
359             # if we don't have it already ...
360             else {
361             # make a note of it
362 0         0 $slots{ $name } = $slot->initializer;
363             }
364             }
365             }
366              
367 16         40 return \%slots, \%conflicts;
368             }
369              
370              
371             # TODO:
372             # We should track the name of the role
373             # where the required method was composed
374             # from, as well as the two classes in
375             # which a method conflicted.
376             # - SL
377             sub COMPOSE_ALL_ROLE_METHODS {
378 16     16 0 26 my @roles = @_;
379              
380 16 50       44 Carp::confess('[ARGS] You must specify a least one role to compose methods in')
381             if scalar( @roles ) == 0;
382              
383 16         25 my (%methods, %conflicts, %required);
384              
385             # flatten the set of required methods ...
386 16         25 foreach my $r ( @roles ) {
387 18         72 foreach my $m ( $r->required_methods ) {
388 3         7 $required{ $m->name } = undef;
389             }
390             }
391              
392             # for every role ...
393 16         1301 foreach my $r ( @roles ) {
394             # and every method in that role ...
395 18         64 foreach my $m ( $r->methods ) {
396 419         617 my $name = $m->name;
397             # if we have already seen the method,
398             # but it is not the same refaddr
399             # it is a conflict, which means:
400 419 50 33     766 if ( exists $methods{ $name } && $methods{ $name } != $m->body ) {
401             # we need to add it to our required-method map
402 0         0 $required{ $name } = undef;
403             # and note that it is also a conflict ...
404 0         0 $conflicts{ $name } = undef;
405             # and remove it from our method map
406 0         0 delete $methods{ $name };
407             }
408             # if we haven't seen the method ...
409             else {
410             # add it to the method map
411 419         589 $methods{ $name } = $m->body;
412             # and remove it from the required-method map
413             delete $required{ $name }
414             # if it actually exists in it, and ...
415             if exists $required{ $name }
416             # is not also a conflict ...
417 419 50 33     765 && !exists $conflicts{ $name };
418             }
419             }
420             }
421              
422             #use Data::Dumper;
423             #warn Dumper [ [ map { $_->name } @roles ], \%methods, \%conflicts, \%required ];
424              
425 16         1307 return \%methods, \%conflicts, \%required;
426             }
427              
428             1;
429              
430             __END__