1 package Mouse::Meta::Role;
6 use Mouse::Util qw(version authority identifier);
11 # because Mouse doesn't introspect existing classes, we're forced to
12 # only pay attention to other Mouse classes
13 sub _metaclass_cache {
16 return $METACLASS_CACHE{$name};
22 $METACLASS_CACHE{$name} = $class->new(name => $name)
23 if !exists($METACLASS_CACHE{$name});
24 return $METACLASS_CACHE{$name};
32 $args{attributes} ||= {};
33 $args{required_methods} ||= [];
39 sub name { $_[0]->{name} }
41 sub add_required_methods {
44 push @{$self->{required_methods}}, @methods;
53 $self->{attributes}->{$name} = $spec;
56 sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
57 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
58 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
60 # copied from Class::Inspector
63 my $name = $self->name;
66 # Get all the CODE symbol table entries
68 grep !/^(?:has|with|around|before|after|augment|inner|override|super|blessed|extends|confess|excludes|requires)$/,
69 grep { defined &{"${name}::$_"} }
71 wantarray ? @functions : \@functions;
74 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
77 my $selfname = $self->name;
79 my $classname = $class->name;
82 if ($class->isa('Mouse::Object')) {
83 Carp::croak('Mouse does not support Application::ToInstance yet');
86 if ($class->isa('Mouse::Meta::Class')) {
87 for my $name (@{$self->{required_methods}}) {
88 unless ($classname->can($name)) {
89 confess "'$selfname' requires the method '$name' to be implemented by '$classname'";
96 for my $name ($self->get_method_list) {
97 next if $name eq 'meta';
99 my $class_function = "${classname}::${name}";
100 my $role_function = "${selfname}::${name}";
101 if (defined &$class_function) {
102 # XXX what's Moose's behavior?
105 *{$class_function} = \&{$role_function};
107 if ($args{alias} && $args{alias}->{$name}) {
108 my $dstname = $args{alias}->{$name};
109 unless ($classname->can($dstname)) {
110 *{"${classname}::${dstname}"} = \&$role_function;
116 if ($class->isa('Mouse::Meta::Class')) {
117 # apply role to class
118 for my $name ($self->get_attribute_list) {
119 next if $class->has_attribute($name);
120 my $spec = $self->get_attribute($name);
122 my $metaclass = 'Mouse::Meta::Attribute';
123 if ( my $metaclass_name = $spec->{metaclass} ) {
124 my $new_class = Mouse::Util::resolve_metaclass_alias(
128 if ( $metaclass ne $new_class ) {
129 $metaclass = $new_class;
133 $metaclass->create($class, $name, %$spec);
137 # XXX Room for speed improvement
138 for my $name ($self->get_attribute_list) {
139 next if $class->has_attribute($name);
140 my $spec = $self->get_attribute($name);
141 $class->add_attribute($name, $spec);
145 # XXX Room for speed improvement in role to role
146 for my $modifier_type (qw/before after around override/) {
147 my $add_method = "add_${modifier_type}_method_modifier";
148 my $modified = $self->{"${modifier_type}_method_modifiers"};
150 for my $method_name (keys %$modified) {
151 for my $code (@{ $modified->{$method_name} }) {
152 $class->$add_method($method_name => $code);
158 push @{ $class->roles }, $self, @{ $self->roles };
162 my(undef, $class, @roles) = @_;
163 my $classname = $class->name;
165 if ($class->isa('Mouse::Meta::Class')) {
166 for my $role_spec (@roles) {
167 my $self = $role_spec->[0]->meta;
168 for my $name (@{$self->{required_methods}}) {
169 unless ($classname->can($name)) {
170 my $method_required = 0;
171 for my $role (@roles) {
172 $method_required = 1 if $self->name ne $role->[0] && $role->[0]->can($name);
174 confess "'".$self->name."' requires the method '$name' to be implemented by '$classname'"
175 unless $method_required;
183 for my $role_spec (@roles) {
184 my $self = $role_spec->[0]->meta;
185 my $selfname = $self->name;
186 my %args = %{ $role_spec->[1] };
187 for my $name ($self->get_method_list) {
188 next if $name eq 'meta';
190 my $class_function = "${classname}::${name}";
191 my $role_function = "${selfname}::${name}";
192 if (defined &$class_function) {
193 # XXX what's Moose's behavior?
196 *$class_function = *$role_function;
198 if ($args{alias} && $args{alias}->{$name}) {
199 my $dstname = $args{alias}->{$name};
200 unless ($classname->can($dstname)) {
201 *{"${classname}::${dstname}"} = \&$role_function;
209 if ($class->isa('Mouse::Meta::Class')) {
210 # apply role to class
211 for my $role_spec (@roles) {
212 my $self = $role_spec->[0]->meta;
213 for my $name ($self->get_attribute_list) {
214 next if $class->has_attribute($name);
215 my $spec = $self->get_attribute($name);
217 my $metaclass = 'Mouse::Meta::Attribute';
218 if ( my $metaclass_name = $spec->{metaclass} ) {
219 my $new_class = Mouse::Util::resolve_metaclass_alias(
223 if ( $metaclass ne $new_class ) {
224 $metaclass = $new_class;
228 $metaclass->create($class, $name, %$spec);
233 # XXX Room for speed improvement
234 for my $role_spec (@roles) {
235 my $self = $role_spec->[0]->meta;
236 for my $name ($self->get_attribute_list) {
237 next if $class->has_attribute($name);
238 my $spec = $self->get_attribute($name);
239 $class->add_attribute($name, $spec);
244 # XXX Room for speed improvement in role to role
245 for my $modifier_type (qw/before after around override/) {
246 my $add_method = "add_${modifier_type}_method_modifier";
247 for my $role_spec (@roles) {
248 my $self = $role_spec->[0]->meta;
249 my $modified = $self->{"${modifier_type}_method_modifiers"};
251 for my $method_name (keys %$modified) {
252 for my $code (@{ $modified->{$method_name} }) {
253 $class->$add_method($method_name => $code);
260 my %role_apply_cache;
261 my $apply_roles = $class->roles;
262 for my $role_spec (@roles) {
263 my $self = $role_spec->[0]->meta;
264 push @$apply_roles, $self unless $role_apply_cache{$self}++;
265 for my $role (@{ $self->roles }) {
266 push @$apply_roles, $role unless $role_apply_cache{$role}++;
271 for my $modifier_type (qw/before after around override/) {
273 *{ __PACKAGE__ . '::' . "add_${modifier_type}_method_modifier" } = sub {
274 my ($self, $method_name, $method) = @_;
276 push @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} },
280 *{ __PACKAGE__ . '::' . "get_${modifier_type}_method_modifiers" } = sub {
281 my ($self, $method_name, $method) = @_;
282 @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} || [] }
286 sub roles { $_[0]->{roles} }
289 # This is currently not passing all the Moose tests.
291 my ($self, $role_name) = @_;
294 || confess "You must supply a role name to look for";
296 # if we are it,.. then return true
297 return 1 if $role_name eq $self->name;
299 for my $role (@{ $self->{roles} }) {
300 return 1 if $role->does_role($role_name);