1 package Mouse::Meta::Role;
6 use base qw(Mouse::Meta::Module);
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};
20 my($class, $package_name, @args) = @_;
22 ($package_name && !ref($package_name))
\r
23 || confess("You must pass a package name and it cannot be blessed");
\r
25 return $METACLASS_CACHE{$package_name}
26 ||= $class->_new(package => $package_name, @args);
34 $args{methods} ||= {};
35 $args{attributes} ||= {};
36 $args{required_methods} ||= [];
42 sub get_roles { $_[0]->{roles} }
45 sub add_required_methods {
48 push @{$self->{required_methods}}, @methods;
55 $self->{attributes}->{$name} = $spec;
58 sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
59 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
60 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
62 sub _check_required_methods{
63 my($role, $class, $args, @other_roles) = @_;
65 if($class->isa('Mouse::Meta::Class')){
66 my $class_name = $class->name;
67 foreach my $method_name(@{$role->{required_methods}}){
68 unless($class_name->can($method_name)){
69 my $role_name = $role->name;
72 foreach my $another_role_spec(@other_roles){
73 my $another_role_name = $another_role_spec->[0];
74 if($role_name ne $another_role_name && $another_role_name->can($method_name)){
80 confess "'$role_name' requires the method '$method_name' to be implemented by '$class_name'"
90 my($role, $class, $args) = @_;
92 my $role_name = $role->name;
93 my $class_name = $class->name;
94 my $alias = $args->{alias};
96 foreach my $method_name($role->get_method_list){
97 next if $method_name eq 'meta';
99 my $code = $role_name->can($method_name);
100 if(do{ no strict 'refs'; defined &{$class_name . '::' . $method_name} }){
101 # XXX what's Moose's behavior?
104 $class->add_method($method_name => $code);
107 if($alias && $alias->{$method_name}){
108 my $dstname = $alias->{$method_name};
109 if(do{ no strict 'refs'; defined &{$class_name . '::' . $dstname} }){
110 # XXX wat's Moose's behavior?
113 $class->add_method($dstname => $code);
121 sub _apply_attributes{
122 my($role, $class, $args) = @_;
124 if ($class->isa('Mouse::Meta::Class')) {
125 # apply role to class
126 for my $attr_name ($role->get_attribute_list) {
127 next if $class->has_attribute($attr_name);
129 my $spec = $role->get_attribute($attr_name);
131 my $attr_metaclass = 'Mouse::Meta::Attribute';
132 if ( my $metaclass_name = $spec->{metaclass} ) {
133 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
139 $attr_metaclass->create($class, $attr_name => %$spec);
143 for my $attr_name ($role->get_attribute_list) {
144 next if $class->has_attribute($attr_name);
146 my $spec = $role->get_attribute($attr_name);
147 $class->add_attribute($attr_name => $spec);
154 sub _apply_modifiers{
155 my($role, $class, $args) = @_;
157 for my $modifier_type (qw/before after around override/) {
158 my $add_modifier = "add_${modifier_type}_method_modifier";
159 my $modifiers = $role->{"${modifier_type}_method_modifiers"};
161 while(my($method_name, $modifier_codes) = each %{$modifiers}){
162 foreach my $code(@{$modifier_codes}){
163 $class->$add_modifier($method_name => $code);
171 my($role, $class, $args) = @_;
173 my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
175 foreach my $r($role, @{$role->get_roles}){
176 if(!$class->does_role($r->name)){
183 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
185 my($self, $class, %args) = @_;
187 if ($class->isa('Mouse::Object')) {
188 Carp::croak('Mouse does not support Application::ToInstance yet');
191 $self->_check_required_methods($class, \%args);
192 $self->_apply_methods($class, \%args);
193 $self->_apply_attributes($class, \%args);
194 $self->_apply_modifiers($class, \%args);
195 $self->_append_roles($class, \%args);
200 my(undef, $class, @roles) = @_;
202 foreach my $role_spec (@roles) {
203 my($role_name, $args) = @{$role_spec};
205 my $role = $role_name->meta;
207 $role->_check_required_methods($class, $args, @roles);
208 $role->_apply_methods($class, $args);
209 $role->_apply_attributes($class, $args);
210 $role->_apply_modifiers($class, $args);
211 $role->_append_roles($class, $args);
216 for my $modifier_type (qw/before after around override/) {
218 my $modifier = "${modifier_type}_method_modifiers";
219 my $add_method_modifier = sub {
220 my ($self, $method_name, $method) = @_;
222 push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
225 my $get_method_modifiers = sub {
226 my ($self, $method_name) = @_;
227 return @{ $self->{$modifier}->{$method_name} ||= [] }
231 *{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier;
232 *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
235 # This is currently not passing all the Moose tests.
237 my ($self, $role_name) = @_;
240 || confess "You must supply a role name to look for";
242 # if we are it,.. then return true
243 return 1 if $role_name eq $self->name;
244 # otherwise.. check our children
245 for my $role (@{ $self->get_roles }) {
246 return 1 if $role->does_role($role_name);