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