whitespace/style cleanups
[gitmo/Moo.git] / lib / Moo / Role.pm
1 package Moo::Role;
2
3 use strictures 1;
4 use Moo::_Utils;
5 use Role::Tiny ();
6 use base qw(Role::Tiny);
7
8 our $VERSION = '1.003001';
9 $VERSION = eval $VERSION;
10
11 require Moo::sification;
12
13 BEGIN { *INFO = \%Role::Tiny::INFO }
14
15 our %INFO;
16 our %APPLY_DEFAULTS;
17
18 sub _install_tracked {
19   my ($target, $name, $code) = @_;
20   $INFO{$target}{exports}{$name} = $code;
21   _install_coderef "${target}::${name}" => "Moo::Role::${name}" => $code;
22 }
23
24 sub import {
25   my $target = caller;
26   my ($me) = @_;
27   strictures->import;
28   if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) {
29     die "Cannot import Moo::Role into a Moo class";
30   }
31   $INFO{$target} ||= {};
32   # get symbol table reference
33   my $stash = _getstash($target);
34   _install_tracked $target => has => sub {
35     my $name_proto = shift;
36     my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
37     if (@_ % 2 != 0) {
38       require Carp;
39       Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
40         . " attribute(s): even number of arguments expected, got " . scalar @_)
41     }
42     my %spec = @_;
43     foreach my $name (@name_proto) {
44       my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
45       ($INFO{$target}{accessor_maker} ||= do {
46         require Method::Generate::Accessor;
47         Method::Generate::Accessor->new
48       })->generate_method($target, $name, $spec_ref);
49       push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref;
50       $me->_maybe_reset_handlemoose($target);
51     }
52   };
53   # install before/after/around subs
54   foreach my $type (qw(before after around)) {
55     _install_tracked $target => $type => sub {
56       require Class::Method::Modifiers;
57       push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
58       $me->_maybe_reset_handlemoose($target);
59     };
60   }
61   _install_tracked $target => requires => sub {
62     push @{$INFO{$target}{requires}||=[]}, @_;
63     $me->_maybe_reset_handlemoose($target);
64   };
65   _install_tracked $target => with => sub {
66     $me->apply_roles_to_package($target, @_);
67     $me->_maybe_reset_handlemoose($target);
68   };
69   return if $INFO{$target}{is_role}; # already exported into this package
70   $INFO{$target}{is_role} = 1;
71   *{_getglob("${target}::meta")} = $me->can('meta');
72   # grab all *non-constant* (stash slot is not a scalarref) subs present
73   # in the symbol table and store their refaddrs (no need to forcibly
74   # inflate constant subs into real subs) - also add '' to here (this
75   # is used later) with a map to the coderefs in case of copying or re-use
76   my @not_methods = ('', map { *$_{CODE}||() } grep !ref($_), values %$stash);
77   @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods;
78   # a role does itself
79   $Role::Tiny::APPLIED_TO{$target} = { $target => undef };
80
81   if ($INC{'Moo/HandleMoose.pm'}) {
82     Moo::HandleMoose::inject_fake_metaclass_for($target);
83   }
84 }
85
86 # duplicate from Moo::Object
87 sub meta {
88   require Moo::HandleMoose::FakeMetaClass;
89   my $class = ref($_[0])||$_[0];
90   bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
91 }
92
93 sub unimport {
94   my $target = caller;
95   _unimport_coderefs($target, $INFO{$target});
96 }
97
98 sub _maybe_reset_handlemoose {
99   my ($class, $target) = @_;
100   if ($INC{"Moo/HandleMoose.pm"}) {
101     Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
102   }
103 }
104
105 sub _inhale_if_moose {
106   my ($self, $role) = @_;
107   _load_module($role);
108   my $meta;
109   if (!$INFO{$role}
110       and (
111         $INC{"Moose.pm"}
112         and $meta = Class::MOP::class_of($role)
113         and $meta->isa('Moose::Meta::Role')
114       )
115       or (
116         Mouse::Util->can('find_meta')
117         and $meta = Mouse::Util::find_meta($role)
118         and $meta->isa('Mouse::Meta::Role')
119      )
120   ) {
121     $INFO{$role}{methods} = {
122       map +($_ => $role->can($_)),
123         grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
124           $meta->get_method_list
125     };
126     $Role::Tiny::APPLIED_TO{$role} = {
127       map +($_->name => 1), $meta->calculate_all_roles
128     };
129     $INFO{$role}{requires} = [ $meta->get_required_method_list ];
130     $INFO{$role}{attributes} = [
131       map +($_ => do {
132         my $attr = $meta->get_attribute($_);
133         my $is_mouse = $meta->isa('Mouse::Meta::Role');
134         my $spec = { %{ $is_mouse ? $attr : $attr->original_options } };
135
136         if ($spec->{isa}) {
137
138           my $get_constraint = do {
139             my $pkg = $is_mouse
140                         ? 'Mouse::Util::TypeConstraints'
141                         : 'Moose::Util::TypeConstraints';
142             _load_module($pkg);
143             $pkg->can('find_or_create_isa_type_constraint');
144           };
145
146           my $tc = $get_constraint->($spec->{isa});
147           my $check = $tc->_compiled_type_constraint;
148
149           $spec->{isa} = sub {
150             &$check or die "Type constraint failed for $_[0]"
151           };
152
153           if ($spec->{coerce}) {
154
155              # Mouse has _compiled_type_coercion straight on the TC object
156              $spec->{coerce} = $tc->${\(
157                $tc->can('coercion')||sub { $_[0] }
158              )}->_compiled_type_coercion;
159           }
160         }
161         $spec;
162       }), $meta->get_attribute_list
163     ];
164     my $mods = $INFO{$role}{modifiers} = [];
165     foreach my $type (qw(before after around)) {
166       # Mouse pokes its own internals so we have to fall back to doing
167       # the same thing in the absence of the Moose API method
168       my $map = $meta->${\(
169         $meta->can("get_${type}_method_modifiers_map")
170         or sub { shift->{"${type}_method_modifiers"} }
171       )};
172       foreach my $method (keys %$map) {
173         foreach my $mod (@{$map->{$method}}) {
174           push @$mods, [ $type => $method => $mod ];
175         }
176       }
177     }
178     require Class::Method::Modifiers if @$mods;
179     $INFO{$role}{inhaled_from_moose} = 1;
180     $INFO{$role}{is_role} = 1;
181   }
182 }
183
184 sub _maybe_make_accessors {
185   my ($self, $target, $role) = @_;
186   my $m;
187   if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}
188       or $INC{"Moo.pm"}
189       and $m = Moo->_accessor_maker_for($target)
190       and ref($m) ne 'Method::Generate::Accessor') {
191     $self->_make_accessors($target, $role);
192   }
193 }
194
195 sub _make_accessors_if_moose {
196   my ($self, $target, $role) = @_;
197   if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}) {
198     $self->_make_accessors($target, $role);
199   }
200 }
201
202 sub _make_accessors {
203   my ($self, $target, $role) = @_;
204   my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do {
205     require Method::Generate::Accessor;
206     Method::Generate::Accessor->new
207   });
208   my $con_gen = $Moo::MAKERS{$target}{constructor};
209   my @attrs = @{$INFO{$role}{attributes}||[]};
210   while (my ($name, $spec) = splice @attrs, 0, 2) {
211     # needed to ensure we got an index for an arrayref based generator
212     if ($con_gen) {
213       $spec = $con_gen->all_attribute_specs->{$name};
214     }
215     $acc_gen->generate_method($target, $name, $spec);
216   }
217 }
218
219 sub role_application_steps {
220   qw(_handle_constructor _maybe_make_accessors),
221     $_[0]->SUPER::role_application_steps;
222 }
223
224 sub apply_roles_to_package {
225   my ($me, $to, @roles) = @_;
226   foreach my $role (@roles) {
227     $me->_inhale_if_moose($role);
228     die "${role} is not a Moo::Role" unless $INFO{$role};
229   }
230   $me->SUPER::apply_roles_to_package($to, @roles);
231 }
232
233 sub apply_single_role_to_package {
234   my ($me, $to, $role) = @_;
235   $me->_inhale_if_moose($role);
236   die "${role} is not a Moo::Role" unless $INFO{$role};
237   $me->SUPER::apply_single_role_to_package($to, $role);
238 }
239
240 sub create_class_with_roles {
241   my ($me, $superclass, @roles) = @_;
242
243   my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles);
244
245   return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
246
247   foreach my $role (@roles) {
248       $me->_inhale_if_moose($role);
249   }
250
251   my $m;
252   if ($INC{"Moo.pm"}
253       and $m = Moo->_accessor_maker_for($superclass)
254       and ref($m) ne 'Method::Generate::Accessor') {
255     # old fashioned way time.
256     *{_getglob("${new_name}::ISA")} = [ $superclass ];
257     $me->apply_roles_to_package($new_name, @roles);
258     return $new_name;
259   }
260
261   require Sub::Quote;
262
263   $me->SUPER::create_class_with_roles($superclass, @roles);
264
265   foreach my $role (@roles) {
266     die "${role} is not a Role::Tiny" unless $INFO{$role};
267   }
268
269   $Moo::MAKERS{$new_name} = {is_class => 1};
270
271   $me->_handle_constructor($new_name, $_) for @roles;
272
273   return $new_name;
274 }
275
276 sub apply_roles_to_object {
277   my ($me, $object, @roles) = @_;
278   my $new = $me->SUPER::apply_roles_to_object($object, @roles);
279
280   my $apply_defaults = $APPLY_DEFAULTS{ref $new} ||= do {
281     my %attrs = map { @{$INFO{$_}{attributes}||[]} } @roles;
282
283     if ($INC{'Moo.pm'}
284         and keys %attrs
285         and my $con_gen = Moo->_constructor_maker_for(ref $new)
286         and my $m = Moo->_accessor_maker_for(ref $new)) {
287       require Sub::Quote;
288
289       my $specs = $con_gen->all_attribute_specs;
290
291       my $assign = '';
292       my %captures;
293       foreach my $name ( keys %attrs ) {
294         my $spec = $specs->{$name};
295         if ($m->has_eager_default($name, $spec)) {
296           my ($has, $has_cap)
297             = $m->generate_simple_has('$_[0]', $name, $spec);
298           my ($code, $pop_cap)
299             = $m->generate_use_default('$_[0]', $name, $spec, $has);
300
301           $assign .= $code;
302           @captures{keys %$has_cap, keys %$pop_cap}
303             = (values %$has_cap, values %$pop_cap);
304         }
305       }
306       Sub::Quote::quote_sub($assign, \%captures);
307     }
308     else {
309       sub {};
310     }
311   };
312   $new->$apply_defaults;
313   return $new;
314 }
315
316 sub _composable_package_for {
317   my ($self, $role) = @_;
318   my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
319   return $composed_name if $Role::Tiny::COMPOSED{role}{$composed_name};
320   $self->_make_accessors_if_moose($composed_name, $role);
321   $self->SUPER::_composable_package_for($role);
322 }
323
324 sub _install_single_modifier {
325   my ($me, @args) = @_;
326   _install_modifier(@args);
327 }
328
329 sub _handle_constructor {
330   my ($me, $to, $role) = @_;
331   my $attr_info = $INFO{$role} && $INFO{$role}{attributes};
332   return unless $attr_info && @$attr_info;
333   if ($INFO{$to}) {
334     push @{$INFO{$to}{attributes}||=[]}, @$attr_info;
335   } else {
336     # only fiddle with the constructor if the target is a Moo class
337     if ($INC{"Moo.pm"}
338         and my $con = Moo->_constructor_maker_for($to)) {
339       # shallow copy of the specs since the constructor will assign an index
340       $con->register_attribute_specs(map ref() ? { %$_ } : $_, @$attr_info);
341     }
342   }
343 }
344
345 1;
346
347 =head1 NAME
348
349 Moo::Role - Minimal Object Orientation support for Roles
350
351 =head1 SYNOPSIS
352
353  package My::Role;
354
355  use Moo::Role;
356
357  sub foo { ... }
358
359  sub bar { ... }
360
361  has baz => (
362    is => 'ro',
363  );
364
365  1;
366
367 And elsewhere:
368
369  package Some::Class;
370
371  use Moo;
372
373  # bar gets imported, but not foo
374  with('My::Role');
375
376  sub foo { ... }
377
378  1;
379
380 =head1 DESCRIPTION
381
382 C<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
383 documentation on how this works.  The main addition here is extra bits to make
384 the roles more "Moosey;" which is to say, it adds L</has>.
385
386 =head1 IMPORTED SUBROUTINES
387
388 See L<Role::Tiny/IMPORTED SUBROUTINES> for all the other subroutines that are
389 imported by this module.
390
391 =head2 has
392
393  has attr => (
394    is => 'ro',
395  );
396
397 Declares an attribute for the class to be composed into.  See
398 L<Moo/has> for all options.
399
400 =head1 SUPPORT
401
402 See L<Moo> for support and contact information.
403
404 =head1 AUTHORS
405
406 See L<Moo> for authors.
407
408 =head1 COPYRIGHT AND LICENSE
409
410 See L<Moo> for the copyright and license.