File Coverage

blib/lib/Moo/Role.pm
Criterion Covered Total %
statement 206 209 98.5
branch 66 70 94.2
condition 86 105 81.9
subroutine 55 56 98.2
pod 3 5 60.0
total 416 445 93.4


line stmt bran cond sub pod time code
1             package Moo::Role;
2 126     158   7025994 use strict;
  126         304  
  126         4171  
3 126     150   782 use warnings;
  126         639  
  126         5480  
4              
5 126         11310 use Moo::_Utils qw(
6             _check_tracked
7             _getglob
8             _getstash
9             _install_coderef
10             _install_modifier
11             _install_tracked
12             _load_module
13             _name_coderef
14             _set_loaded
15             _unimport_coderefs
16 126     150   19735 );
  126         626  
17 126     134   871 use Carp qw(croak);
  126         248  
  126         5335  
18 126     126   69640 use Role::Tiny ();
  126         594101  
  126         4668  
19 126     126   7690 BEGIN { our @ISA = qw(Role::Tiny) }
20             BEGIN {
21 126     126   10739 our @CARP_NOT = qw(
22             Method::Generate::Accessor
23             Method::Generate::Constructor
24             Moo::sification
25             Moo::_Utils
26             Role::Tiny
27             );
28             }
29              
30             our $VERSION = '2.005004';
31             $VERSION =~ tr/_//d;
32              
33             require Moo::sification;
34             Moo::sification->import;
35              
36             BEGIN {
37 126     126   646 *INFO = \%Role::Tiny::INFO;
38 126         369 *APPLIED_TO = \%Role::Tiny::APPLIED_TO;
39 126         260 *COMPOSED = \%Role::Tiny::COMPOSED;
40 126         306664 *ON_ROLE_CREATE = \@Role::Tiny::ON_ROLE_CREATE;
41             }
42              
43             our %INFO;
44             our %APPLIED_TO;
45             our %APPLY_DEFAULTS;
46             our %COMPOSED;
47             our @ON_ROLE_CREATE;
48              
49             sub import {
50 192     192   1049080 my $target = caller;
51 192 100 100     818 if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) {
52 4         715 croak "Cannot import Moo::Role into a Moo class";
53             }
54 188         1009 _set_loaded(caller);
55 188         1028 goto &Role::Tiny::import;
56             }
57              
58             sub _accessor_maker_for {
59 98     98   282 my ($class, $target) = @_;
60 98   66     639 ($INFO{$target}{accessor_maker} ||= do {
61 82         19009 require Method::Generate::Accessor;
62 82         937 Method::Generate::Accessor->new
63             });
64             }
65              
66             sub _install_subs {
67 188     188   982 my ($me, $target) = @_;
68 188         595 my %install = $me->_gen_subs($target);
69             _install_tracked $target => $_ => $install{$_}
70 188         2015 for sort keys %install;
71 188         1507 *{_getglob("${target}::meta")} = $me->can('meta');
  188         737  
72 188         813 return;
73             }
74              
75             sub _require_module {
76 416     416   27645 _load_module($_[1]);
77             }
78              
79             sub _gen_subs {
80 188     188   448 my ($me, $target) = @_;
81             return (
82             has => sub {
83 100     100   320273 my $name_proto = shift;
        92      
        60      
        46      
84 100 100       571 my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
85 100 100       518 if (@_ % 2 != 0) {
86 4         838 croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
87             . " attribute(s): even number of arguments expected, got " . scalar @_)
88             }
89 96         437 my %spec = @_;
90 96         282 foreach my $name (@name_proto) {
91 98 100       382 my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
92 98         595 $me->_accessor_maker_for($target)
93             ->generate_method($target, $name, $spec_ref);
94 98   100     248 push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref;
  98         787  
95 98         511 $me->_maybe_reset_handlemoose($target);
96             }
97             },
98             (map {
99 564         987 my $type = $_;
100             (
101             $type => sub {
102 20   100 20   14014 push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
  20     20   168  
        20      
        10      
        30      
        30      
        20      
        40      
        40      
        30      
103 20         84 $me->_maybe_reset_handlemoose($target);
104             },
105             )
106 564         3916 } qw(before after around)),
107             requires => sub {
108 24   100 54   18193 push @{$INFO{$target}{requires}||=[]}, @_;
  24     44   205  
        42      
        38      
109 24         126 $me->_maybe_reset_handlemoose($target);
110             },
111             with => sub {
112 14     34   5799 $me->apply_roles_to_package($target, @_);
        28      
        26      
        12      
113 14         1449 $me->_maybe_reset_handlemoose($target);
114             },
115 188         1449 );
116             }
117              
118             push @ON_ROLE_CREATE, sub {
119             my $target = shift;
120             if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) {
121             Moo::HandleMoose::inject_fake_metaclass_for($target);
122             }
123             };
124              
125             # duplicate from Moo::Object
126             sub meta {
127 2     12 0 21 require Moo::HandleMoose::FakeMetaClass;
128 2   33     15 my $class = ref($_[0])||$_[0];
129 2         33 bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
130             }
131              
132             sub unimport {
133 10     18   836 my $target = caller;
134 10         36 _unimport_coderefs($target);
135             }
136              
137             sub _maybe_reset_handlemoose {
138 156     164   507 my ($class, $target) = @_;
139 156 100 100     1959 if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) {
140 62         378 Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
141             }
142             }
143              
144             sub _non_methods {
145 362     362   10959 my $self = shift;
146 362         811 my ($role) = @_;
147              
148 362         1900 my $non_methods = $self->SUPER::_non_methods(@_);
149              
150 362         6264 my $all_subs = $self->_all_subs($role);
151             $non_methods->{$_} = $all_subs->{$_}
152 362         17136 for _check_tracked($role, [ keys %$all_subs ]);
153              
154 362         1562 return $non_methods;
155             }
156              
157             sub is_role {
158 770     770 1 7586 my ($self, $role) = @_;
159 770         2165 $self->_inhale_if_moose($role);
160 770         13918 $self->SUPER::is_role($role);
161             }
162              
163             sub _inhale_if_moose {
164 770     770   1532 my ($self, $role) = @_;
165 770         1152 my $meta;
166 770 100 100     2319 if (!$self->SUPER::is_role($role)
      100        
      66        
      100        
      100        
      66        
      100        
167             and (
168             $INC{"Moose.pm"}
169             and $meta = Class::MOP::class_of($role)
170             and ref $meta ne 'Moo::HandleMoose::FakeMetaClass'
171             and $meta->isa('Moose::Meta::Role')
172             )
173             or (
174             Mouse::Util->can('find_meta')
175             and $meta = Mouse::Util::find_meta($role)
176             and $meta->isa('Mouse::Meta::Role')
177             )
178             ) {
179 28         1132 my $is_mouse = $meta->isa('Mouse::Meta::Role');
180             $INFO{$role}{methods} = {
181 28   100     293 map +($_ => $role->can($_)),
182             grep $role->can($_),
183             grep !($is_mouse && $_ eq 'meta'),
184             grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
185             $meta->get_method_list
186             };
187 28         27626 $APPLIED_TO{$role} = {
188             map +($_->name => 1), $meta->calculate_all_roles
189             };
190 28         2001 $INFO{$role}{requires} = [ $meta->get_required_method_list ];
191             $INFO{$role}{attributes} = [
192 28         1305 map +($_ => do {
193 22         257 my $attr = $meta->get_attribute($_);
194 22 100       159 my $spec = { %{ $is_mouse ? $attr : $attr->original_options } };
  22         710  
195              
196 22 100       243 if ($spec->{isa}) {
197 8         1209 require Sub::Quote;
198              
199 8         12732 my $get_constraint = do {
200 8 100       86 my $pkg = $is_mouse
201             ? 'Mouse::Util::TypeConstraints'
202             : 'Moose::Util::TypeConstraints';
203 8         151 _load_module($pkg);
204 8         106 $pkg->can('find_or_create_isa_type_constraint');
205             };
206              
207 8         39 my $tc = $get_constraint->($spec->{isa});
208 8         1008 my $check = $tc->_compiled_type_constraint;
209 8         366 my $tc_var = '$_check_for_'.Sub::Quote::sanitize_identifier($tc->name);
210              
211 8         204 $spec->{isa} = Sub::Quote::quote_sub(
212             qq{
213             &${tc_var} or Carp::croak "Type constraint failed for \$_[0]"
214             },
215             { $tc_var => \$check },
216             {
217             package => $role,
218             },
219             );
220              
221 8 100       910 if ($spec->{coerce}) {
222              
223             # Mouse has _compiled_type_coercion straight on the TC object
224 4         19 $spec->{coerce} = $tc->${\(
225 2     2   14 $tc->can('coercion')||sub { $_[0] }
226 4   100     126 )}->_compiled_type_coercion;
227             }
228             }
229 22         271 $spec;
230             }), $meta->get_attribute_list
231             ];
232 28         145 my $mods = $INFO{$role}{modifiers} = [];
233 28         83 foreach my $type (qw(before after around)) {
234             # Mouse pokes its own internals so we have to fall back to doing
235             # the same thing in the absence of the Moose API method
236 84         133 my $map = $meta->${\(
237             $meta->can("get_${type}_method_modifiers_map")
238 24     24   102 or sub { shift->{"${type}_method_modifiers"} }
239 84   100     2684 )};
240 84         684 foreach my $method (keys %$map) {
241 8         33 foreach my $mod (@{$map->{$method}}) {
  8         29  
242 8         36 push @$mods, [ $type => $method => $mod ];
243             }
244             }
245             }
246 28         81 $INFO{$role}{inhaled_from_moose} = 1;
247 28         82 $INFO{$role}{is_role} = 1;
248             }
249             }
250              
251             sub _maybe_make_accessors {
252 220     220   12169 my ($self, $target, $role) = @_;
253 220         361 my $m;
254 220 100 66     2716 if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}
      100        
      100        
      100        
255             or $INC{"Moo.pm"}
256             and $m = Moo->_accessor_maker_for($target)
257             and ref($m) ne 'Method::Generate::Accessor') {
258 42         168 $self->_make_accessors($target, $role);
259             }
260             }
261              
262             sub _make_accessors_if_moose {
263 0     0   0 my ($self, $target, $role) = @_;
264 0 0 0     0 if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}) {
265 0         0 $self->_make_accessors($target, $role);
266             }
267             }
268              
269             sub _make_accessors {
270 42     42   212 my ($self, $target, $role) = @_;
271 42   66     195 my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do {
272 6         2537 require Method::Generate::Accessor;
273 6         83 Method::Generate::Accessor->new
274             });
275 42         112 my $con_gen = $Moo::MAKERS{$target}{constructor};
276 42 100       88 my @attrs = @{$INFO{$role}{attributes}||[]};
  42         182  
277 42         200 while (my ($name, $spec) = splice @attrs, 0, 2) {
278             # needed to ensure we got an index for an arrayref based generator
279 36 100       104 if ($con_gen) {
280 32         102 $spec = $con_gen->all_attribute_specs->{$name};
281             }
282 36         201 $acc_gen->generate_method($target, $name, $spec);
283             }
284             }
285              
286             sub _undefer_subs {
287 220     220   5056 my ($self, $target, $role) = @_;
288 220 100       740 if ($INC{'Sub/Defer.pm'}) {
289 198         728 Sub::Defer::undefer_package($role);
290             }
291             }
292              
293             sub role_application_steps {
294 164     164 0 8477 qw(_handle_constructor _undefer_subs _maybe_make_accessors),
295             $_[0]->SUPER::role_application_steps;
296             }
297              
298             sub _build_class_with_roles {
299 42     42   1177 my ($me, $new_name, $superclass, @roles) = @_;
300 42         174 $Moo::MAKERS{$new_name} = {is_class => 1};
301 42         236 $me->SUPER::_build_class_with_roles($new_name, $superclass, @roles);
302              
303 40 100 100     3141 if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) {
304 4         22 Moo::HandleMoose::inject_fake_metaclass_for($new_name);
305             }
306              
307 40         9138 my $lvl = 0;
308 40         73 my $file;
309 40         410 while ((my $pack, $file) = caller($lvl++)) {
310 112 100 100     1243 if ($pack ne __PACKAGE__ && $pack ne 'Role::Tiny' && !$pack->isa($me)) {
      66        
311 40         122 last;
312             }
313             }
314 40   33     261 _set_loaded($new_name, $file || (caller)[1]);
315              
316 40         204 return $new_name;
317             }
318              
319             sub _gen_apply_defaults_for {
320 22     22   73 my ($me, $class, @roles) = @_;
321              
322 22 100       51 my @attrs = map @{$INFO{$_}{attributes}||[]}, @roles;
  36         165  
323              
324 22         46 my $con_gen;
325             my $m;
326              
327             return undef
328 22 50 66     260 unless $INC{'Moo.pm'}
      66        
      66        
329             and @attrs
330             and $con_gen = Moo->_constructor_maker_for($class)
331             and $m = Moo->_accessor_maker_for($class);
332              
333 12         83 my $specs = $con_gen->all_attribute_specs;
334              
335 12         39 my %seen;
336             my %captures;
337 12         0 my @set;
338 12         69 while (my ($name, $spec) = splice @attrs, 0, 2) {
339             next
340 18 50       80 if $seen{$name}++;
341              
342             next
343 18 100       86 unless $m->has_eager_default($name, $spec);
344              
345 14         68 my ($has, $has_cap)
346             = $m->generate_simple_has('$_[0]', $name, $spec);
347 14         56 my ($set, $pop_cap)
348             = $m->generate_use_default('$_[0]', $name, $spec, $has);
349              
350 14         66 @captures{keys %$has_cap, keys %$pop_cap}
351             = (values %$has_cap, values %$pop_cap);
352              
353 14         77 push @set, $set;
354             }
355              
356             return undef
357 12 100       56 if !@set;
358              
359 10         76 my $code = join '', map "($_),", @set;
360 126     126   1621 no warnings 'void';
  126         309  
  126         89748  
361 10         71 require Sub::Quote;
362 10         109 return Sub::Quote::quote_sub(
363             "${class}::_apply_defaults",
364             $code,
365             \%captures,
366             {
367             package => $class,
368             no_install => 1,
369             no_defer => 1,
370             }
371             );
372             }
373              
374             sub apply_roles_to_object {
375 24     24 1 7541 my ($me, $object, @roles) = @_;
376 24         160 my $new = $me->SUPER::apply_roles_to_object($object, @roles);
377 24         222 my $class = ref $new;
378 24         118 _set_loaded($class, (caller)[1]);
379              
380 24 100       98 if (!exists $APPLY_DEFAULTS{$class}) {
381 22         80 $APPLY_DEFAULTS{$class} = $me->_gen_apply_defaults_for($class, @roles);
382             }
383 24 100       6536 if (my $apply_defaults = $APPLY_DEFAULTS{$class}) {
384 10         33 local $Carp::Internal{+__PACKAGE__} = 1;
385 10         23 local $Carp::Internal{$class} = 1;
386 10         258 $new->$apply_defaults;
387             }
388 22         731 return $new;
389             }
390              
391             sub _install_single_modifier {
392 38     38   2758 my ($me, @args) = @_;
393 38         120 _install_modifier(@args);
394             }
395              
396             sub _install_does {
397 220     220   27593 my ($me, $to) = @_;
398              
399             # If Role::Tiny actually installed the DOES, give it a name
400 220 100       1019 my $new = $me->SUPER::_install_does($to) or return;
401 134         6880 return _name_coderef("${to}::DOES", $new);
402             }
403              
404             sub does_role {
405 24     24 1 8098 my ($proto, $role) = @_;
406 24 100       99 return 1
407             if Role::Tiny::does_role($proto, $role);
408 10         186 my $meta;
409 10 100 66     79 if ($INC{'Moose.pm'}
      100        
      66        
410             and $meta = Class::MOP::class_of($proto)
411             and ref $meta ne 'Moo::HandleMoose::FakeMetaClass'
412             and $meta->can('does_role')
413             ) {
414 4         195 return $meta->does_role($role);
415             }
416 6         61 return 0;
417             }
418              
419             sub _handle_constructor {
420 222     222   2933 my ($me, $to, $role) = @_;
421 222   66     1190 my $attr_info = $INFO{$role} && $INFO{$role}{attributes};
422 222 100 100     1100 return unless $attr_info && @$attr_info;
423 130         404 my $info = $INFO{$to};
424 130   100     853 my $con = $INC{"Moo.pm"} && Moo->_constructor_maker_for($to);
425             my %existing
426 10 100       85 = $info ? @{$info->{attributes} || []}
427 128 100       553 : $con ? %{$con->all_attribute_specs || {}}
  116 100       400  
    100          
428             : ();
429              
430             my @attr_info =
431 128         281 map { @{$attr_info}[$_, $_+1] }
  128         491  
432 138         537 grep { ! $existing{$attr_info->[$_]} }
433 128         711 map { 2 * $_ } 0..@$attr_info/2-1;
  138         595  
434              
435 128 100       564 if ($info) {
    100          
436 10   100     21 push @{$info->{attributes}||=[]}, @attr_info;
  10         99  
437             }
438             elsif ($con) {
439             # shallow copy of the specs since the constructor will assign an index
440 116 100       1047 $con->register_attribute_specs(map ref() ? { %$_ } : $_, @attr_info);
441             }
442             }
443              
444             1;
445             __END__
446              
447             =head1 NAME
448              
449             Moo::Role - Minimal Object Orientation support for Roles
450              
451             =head1 SYNOPSIS
452              
453             package My::Role;
454              
455             use Moo::Role;
456             use strictures 2;
457              
458             sub foo { ... }
459              
460             sub bar { ... }
461              
462             has baz => (
463             is => 'ro',
464             );
465              
466             1;
467              
468             And elsewhere:
469              
470             package Some::Class;
471              
472             use Moo;
473             use strictures 2;
474              
475             # bar gets imported, but not foo
476             with 'My::Role';
477              
478             sub foo { ... }
479              
480             1;
481              
482             =head1 DESCRIPTION
483              
484             C<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
485             documentation on how this works (in particular, using C<Moo::Role> also
486             enables L<strict> and L<warnings>). The main addition here is extra bits to
487             make the roles more "Moosey;" which is to say, it adds L</has>.
488              
489             =head1 IMPORTED SUBROUTINES
490              
491             See L<Role::Tiny/IMPORTED SUBROUTINES> for all the other subroutines that are
492             imported by this module.
493              
494             =head2 has
495              
496             has attr => (
497             is => 'ro',
498             );
499              
500             Declares an attribute for the class to be composed into. See
501             L<Moo/has> for all options.
502              
503             =head1 CLEANING UP IMPORTS
504              
505             L<Moo::Role> cleans up its own imported methods and any imports
506             declared before the C<use Moo::Role> statement automatically.
507             Anything imported after C<use Moo::Role> will be composed into
508             consuming packages. A package that consumes this role:
509              
510             package My::Role::ID;
511              
512             use Digest::MD5 qw(md5_hex);
513             use Moo::Role;
514             use Digest::SHA qw(sha1_hex);
515              
516             requires 'name';
517              
518             sub as_md5 { my ($self) = @_; return md5_hex($self->name); }
519             sub as_sha1 { my ($self) = @_; return sha1_hex($self->name); }
520              
521             1;
522              
523             ..will now have a C<< $self->sha1_hex() >> method available to it
524             that probably does not do what you expect. On the other hand, a call
525             to C<< $self->md5_hex() >> will die with the helpful error message:
526             C<Can't locate object method "md5_hex">.
527              
528             See L<Moo/"CLEANING UP IMPORTS"> for more details.
529              
530             =head1 SUPPORT
531              
532             See L<Moo> for support and contact information.
533              
534             =head1 AUTHORS
535              
536             See L<Moo> for authors.
537              
538             =head1 COPYRIGHT AND LICENSE
539              
540             See L<Moo> for the copyright and license.
541              
542             =cut