1 package Mouse::Meta::Role;
5 use Mouse::Util qw(not_supported);
6 use base qw(Mouse::Meta::Module);
12 $args{methods} ||= {};
13 $args{attributes} ||= {};
14 $args{required_methods} ||= [];
20 sub get_roles { $_[0]->{roles} }
23 sub add_required_methods {
26 push @{$self->{required_methods}}, @methods;
33 $self->{attributes}->{$name} = $spec;
36 sub _check_required_methods{
37 my($role, $class, $args, @other_roles) = @_;
39 if($class->isa('Mouse::Meta::Class')){
40 my $class_name = $class->name;
41 foreach my $method_name(@{$role->{required_methods}}){
42 unless($class_name->can($method_name)){
43 my $role_name = $role->name;
46 foreach my $another_role_spec(@other_roles){
47 my $another_role_name = $another_role_spec->[0];
48 if($role_name ne $another_role_name && $another_role_name->can($method_name)){
54 $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'")
64 my($role, $class, $args) = @_;
66 my $role_name = $role->name;
67 my $class_name = $class->name;
68 my $alias = $args->{alias};
70 foreach my $method_name($role->get_method_list){
71 next if $method_name eq 'meta';
73 my $code = $role_name->can($method_name);
74 if(do{ no strict 'refs'; defined &{$class_name . '::' . $method_name} }){
75 # XXX what's Moose's behavior?
78 $class->add_method($method_name => $code);
81 if($alias && $alias->{$method_name}){
82 my $dstname = $alias->{$method_name};
83 if(do{ no strict 'refs'; defined &{$class_name . '::' . $dstname} }){
84 # XXX wat's Moose's behavior?
87 $class->add_method($dstname => $code);
95 sub _apply_attributes{
96 my($role, $class, $args) = @_;
98 if ($class->isa('Mouse::Meta::Class')) {
100 for my $attr_name ($role->get_attribute_list) {
101 next if $class->has_attribute($attr_name);
103 my $spec = $role->get_attribute($attr_name);
105 my $attr_metaclass = 'Mouse::Meta::Attribute';
106 if ( my $metaclass_name = $spec->{metaclass} ) {
107 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
113 $attr_metaclass->create($class, $attr_name => %$spec);
117 for my $attr_name ($role->get_attribute_list) {
118 next if $class->has_attribute($attr_name);
120 my $spec = $role->get_attribute($attr_name);
121 $class->add_attribute($attr_name => $spec);
128 sub _apply_modifiers{
129 my($role, $class, $args) = @_;
131 for my $modifier_type (qw/before after around override/) {
132 my $add_modifier = "add_${modifier_type}_method_modifier";
133 my $modifiers = $role->{"${modifier_type}_method_modifiers"};
135 while(my($method_name, $modifier_codes) = each %{$modifiers}){
136 foreach my $code(@{$modifier_codes}){
137 $class->$add_modifier($method_name => $code);
145 my($role, $class, $args) = @_;
147 my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
149 foreach my $r($role, @{$role->get_roles}){
150 if(!$class->does_role($r->name)){
157 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
159 my($self, $class, %args) = @_;
161 if ($class->isa('Mouse::Object')) {
162 not_supported 'Application::ToInstance';
165 $self->_check_required_methods($class, \%args);
166 $self->_apply_methods($class, \%args);
167 $self->_apply_attributes($class, \%args);
168 $self->_apply_modifiers($class, \%args);
169 $self->_append_roles($class, \%args);
174 my(undef, $class, @roles) = @_;
176 foreach my $role_spec (@roles) {
177 my($role_name, $args) = @{$role_spec};
179 my $role = $role_name->meta;
181 $role->_check_required_methods($class, $args, @roles);
182 $role->_apply_methods($class, $args);
183 $role->_apply_attributes($class, $args);
184 $role->_apply_modifiers($class, $args);
185 $role->_append_roles($class, $args);
190 for my $modifier_type (qw/before after around override/) {
192 my $modifier = "${modifier_type}_method_modifiers";
193 my $add_method_modifier = sub {
194 my ($self, $method_name, $method) = @_;
196 push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
199 my $has_method_modifiers = sub{
200 my($self, $method_name) = @_;
201 my $m = $self->{$modifier}->{$method_name};
202 return $m && @{$m} != 0;
204 my $get_method_modifiers = sub {
205 my ($self, $method_name) = @_;
206 return @{ $self->{$modifier}->{$method_name} ||= [] }
210 *{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier;
211 *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
212 *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
215 # This is currently not passing all the Moose tests.
217 my ($self, $role_name) = @_;
220 || $self->throw_error("You must supply a role name to look for");
222 # if we are it,.. then return true
223 return 1 if $role_name eq $self->name;
224 # otherwise.. check our children
225 for my $role (@{ $self->get_roles }) {
226 return 1 if $role->does_role($role_name);