2 package Moose::Meta::Role;
9 use Scalar::Util 'blessed';
11 use Moose::Meta::Class;
13 our $VERSION = '0.02';
17 ## the meta for the role package
19 __PACKAGE__->meta->add_attribute('_role_meta' => (
20 reader => '_role_meta',
21 init_arg => ':role_meta'
26 __PACKAGE__->meta->add_attribute('roles' => (
27 reader => 'get_roles',
33 __PACKAGE__->meta->add_attribute('attribute_map' => (
34 reader => 'get_attribute_map',
40 __PACKAGE__->meta->add_attribute('required_methods' => (
41 reader => 'get_required_methods_map',
47 __PACKAGE__->meta->add_attribute('before_method_modifiers' => (
48 reader => 'get_before_method_modifiers_map',
49 default => sub { {} } # (<name> => [ (CODE) ])
52 __PACKAGE__->meta->add_attribute('after_method_modifiers' => (
53 reader => 'get_after_method_modifiers_map',
54 default => sub { {} } # (<name> => [ (CODE) ])
57 __PACKAGE__->meta->add_attribute('around_method_modifiers' => (
58 reader => 'get_around_method_modifiers_map',
59 default => sub { {} } # (<name> => [ (CODE) ])
62 __PACKAGE__->meta->add_attribute('override_method_modifiers' => (
63 reader => 'get_override_method_modifiers_map',
64 default => sub { {} } # (<name> => CODE)
72 $options{':role_meta'} = Moose::Meta::Class->initialize(
74 ':method_metaclass' => 'Moose::Meta::Role::Method'
76 my $self = $class->meta->new_object(%options);
83 my ($self, $role) = @_;
84 (blessed($role) && $role->isa('Moose::Meta::Role'))
85 || confess "Roles must be instances of Moose::Meta::Role";
86 push @{$self->get_roles} => $role;
90 my ($self, $role_name) = @_;
92 || confess "You must supply a role name to look for";
93 # if we are it,.. then return true
94 return 1 if $role_name eq $self->name;
95 # otherwise.. check our children
96 foreach my $role (@{$self->get_roles}) {
97 return 1 if $role->does_role($role_name);
104 sub add_required_methods {
105 my ($self, @methods) = @_;
106 $self->get_required_methods_map->{$_} = undef foreach @methods;
109 sub get_required_method_list {
111 keys %{$self->get_required_methods_map};
114 sub requires_method {
115 my ($self, $method_name) = @_;
116 exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
122 # we delegate to some role_meta methods for convience here
123 # the Moose::Meta::Role is meant to be a read-only interface
124 # to the underlying role package, if you want to manipulate
125 # that, just use ->role_meta
127 sub name { (shift)->_role_meta->name }
128 sub version { (shift)->_role_meta->version }
130 sub get_method { (shift)->_role_meta->get_method(@_) }
131 sub has_method { (shift)->_role_meta->has_method(@_) }
132 sub alias_method { (shift)->_role_meta->alias_method(@_) }
133 sub get_method_list {
137 # this is a kludge for now,... these functions
138 # should not be showing up in the list at all,
139 # but they do, so we need to switch Moose::Role
140 # and Moose to use Sub::Exporter to prevent this
141 !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/
142 } $self->_role_meta->get_method_list;
145 # ... however the items in statis (attributes & method modifiers)
146 # can be removed and added to through this API
151 my ($self, $name, %attr_desc) = @_;
152 $self->get_attribute_map->{$name} = \%attr_desc;
156 my ($self, $name) = @_;
157 exists $self->get_attribute_map->{$name} ? 1 : 0;
161 my ($self, $name) = @_;
162 $self->get_attribute_map->{$name}
165 sub remove_attribute {
166 my ($self, $name) = @_;
167 delete $self->get_attribute_map->{$name}
170 sub get_attribute_list {
172 keys %{$self->get_attribute_map};
177 # mimic the metaclass API
178 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
179 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
180 sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) }
182 sub _add_method_modifier {
183 my ($self, $modifier_type, $method_name, $method) = @_;
184 my $accessor = "get_${modifier_type}_method_modifiers_map";
185 $self->$accessor->{$method_name} = []
186 unless exists $self->$accessor->{$method_name};
187 push @{$self->$accessor->{$method_name}} => $method;
190 sub add_override_method_modifier {
191 my ($self, $method_name, $method) = @_;
192 $self->get_override_method_modifiers_map->{$method_name} = $method;
195 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
196 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
197 sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) }
199 # override just checks for one,..
200 # but we can still re-use stuff
201 sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) }
203 sub _has_method_modifiers {
204 my ($self, $modifier_type, $method_name) = @_;
205 my $accessor = "get_${modifier_type}_method_modifiers_map";
207 # for now we assume that if it exists,..
208 # it has at least one modifier in it
209 (exists $self->$accessor->{$method_name}) ? 1 : 0;
212 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
213 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
214 sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) }
216 sub _get_method_modifiers {
217 my ($self, $modifier_type, $method_name) = @_;
218 my $accessor = "get_${modifier_type}_method_modifiers_map";
219 @{$self->$accessor->{$method_name}};
222 sub get_override_method_modifier {
223 my ($self, $method_name) = @_;
224 $self->get_override_method_modifiers_map->{$method_name};
227 sub get_method_modifier_list {
228 my ($self, $modifier_type) = @_;
229 my $accessor = "get_${modifier_type}_method_modifiers_map";
230 keys %{$self->$accessor};
233 ## applying a role to a class ...
236 my ($self, $other) = @_;
239 # we might need to move this down below the
240 # the attributes so that we can require any
241 # attribute accessors. However I am thinking
242 # that maybe those are somehow exempt from
243 # the require methods stuff.
244 foreach my $required_method_name ($self->get_required_method_list) {
245 unless ($other->has_method($required_method_name)) {
246 if ($other->isa('Moose::Meta::Role')) {
247 $other->add_required_methods($required_method_name);
250 confess "'" . $self->name . "' requires the method '$required_method_name' " .
251 "to be implemented by '" . $other->name . "'";
256 foreach my $attribute_name ($self->get_attribute_list) {
257 # skip it if it has one already
258 next if $other->has_attribute($attribute_name);
259 # add it, although it could be overriden
260 $other->add_attribute(
262 %{$self->get_attribute($attribute_name)}
266 foreach my $method_name ($self->get_method_list) {
267 # skip it if it has one already
268 next if $other->has_method($method_name);
269 # add it, although it could be overriden
270 $other->alias_method(
272 $self->get_method($method_name)
276 foreach my $method_name ($self->get_method_modifier_list('override')) {
277 # skip it if it has one already
278 next if $other->has_method($method_name);
279 # add it, although it could be overriden
280 $other->add_override_method_modifier(
282 $self->get_override_method_modifier($method_name),
287 foreach my $method_name ($self->get_method_modifier_list('before')) {
288 $other->add_before_method_modifier(
291 ) foreach $self->get_before_method_modifiers($method_name);
294 foreach my $method_name ($self->get_method_modifier_list('after')) {
295 $other->add_after_method_modifier(
298 ) foreach $self->get_after_method_modifiers($method_name);
301 foreach my $method_name ($self->get_method_modifier_list('around')) {
302 $other->add_around_method_modifier(
305 ) foreach $self->get_around_method_modifiers($method_name);
308 $other->add_role($self);
311 package Moose::Meta::Role::Method;
316 our $VERSION = '0.01';
318 use base 'Class::MOP::Method';
328 Moose::Meta::Role - The Moose Role metaclass
332 Moose's Roles are being actively developed, please see L<Moose::Role>
333 for more information. For the most part, this has no user-serviceable
334 parts inside. It's API is still subject to some change (although
335 probably not that much really).
375 =item B<alias_method>
377 =item B<get_method_list>
383 =item B<add_attribute>
385 =item B<has_attribute>
387 =item B<get_attribute>
389 =item B<get_attribute_list>
391 =item B<get_attribute_map>
393 =item B<remove_attribute>
399 =item B<add_required_methods>
401 =item B<get_required_method_list>
403 =item B<get_required_methods_map>
405 =item B<requires_method>
411 =item B<add_after_method_modifier>
413 =item B<add_around_method_modifier>
415 =item B<add_before_method_modifier>
417 =item B<add_override_method_modifier>
423 =item B<has_after_method_modifiers>
425 =item B<has_around_method_modifiers>
427 =item B<has_before_method_modifiers>
429 =item B<has_override_method_modifier>
435 =item B<get_after_method_modifiers>
437 =item B<get_around_method_modifiers>
439 =item B<get_before_method_modifiers>
441 =item B<get_method_modifier_list>
447 =item B<get_override_method_modifier>
449 =item B<get_after_method_modifiers_map>
451 =item B<get_around_method_modifiers_map>
453 =item B<get_before_method_modifiers_map>
455 =item B<get_override_method_modifiers_map>
461 All complex software has bugs lurking in it, and this module is no
462 exception. If you find a bug please either email me, or add the bug
467 Stevan Little E<lt>stevan@iinteractive.comE<gt>
469 =head1 COPYRIGHT AND LICENSE
471 Copyright 2006 by Infinity Interactive, Inc.
473 L<http://www.iinteractive.com>
475 This library is free software; you can redistribute it and/or modify
476 it under the same terms as Perl itself.