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 add_required_methods {
45 push @{$self->{required_methods}}, @methods;
52 $self->{attributes}->{$name} = $spec;
55 sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
56 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
57 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
59 sub _check_required_methods{
60 my($role, $class, $args, @other_roles) = @_;
62 if($class->isa('Mouse::Meta::Class')){
63 my $class_name = $class->name;
64 foreach my $method_name(@{$role->{required_methods}}){
65 unless($class_name->can($method_name)){
66 my $role_name = $role->name;
69 foreach my $another_role_spec(@other_roles){
70 my $another_role_name = $another_role_spec->[0];
71 if($role_name ne $another_role_name && $another_role_name->can($method_name)){
77 confess "'$role_name' requires the method '$method_name' to be implemented by '$class_name'"
87 my($role, $class, $args) = @_;
89 my $role_name = $role->name;
90 my $class_name = $class->name;
91 my $alias = $args->{alias};
93 foreach my $method_name($role->get_method_list){
94 next if $method_name eq 'meta';
96 my $code = $role_name->can($method_name);
97 if(do{ no strict 'refs'; defined &{$class_name . '::' . $method_name} }){
98 # XXX what's Moose's behavior?
101 $class->add_method($method_name => $code);
104 if($alias && $alias->{$method_name}){
105 my $dstname = $alias->{$method_name};
106 if(do{ no strict 'refs'; defined &{$class_name . '::' . $dstname} }){
107 # XXX wat's Moose's behavior?
110 $class->add_method($dstname => $code);
118 sub _apply_attributes{
119 my($role, $class, $args) = @_;
121 if ($class->isa('Mouse::Meta::Class')) {
122 # apply role to class
123 for my $attr_name ($role->get_attribute_list) {
124 next if $class->has_attribute($attr_name);
126 my $spec = $role->get_attribute($attr_name);
128 my $attr_metaclass = 'Mouse::Meta::Attribute';
129 if ( my $metaclass_name = $spec->{metaclass} ) {
130 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
136 $attr_metaclass->create($class, $attr_name => %$spec);
140 for my $attr_name ($role->get_attribute_list) {
141 next if $class->has_attribute($attr_name);
143 my $spec = $role->get_attribute($attr_name);
144 $class->add_attribute($attr_name => $spec);
151 sub _apply_modifiers{
152 my($role, $class, $args) = @_;
154 for my $modifier_type (qw/before after around override/) {
155 my $add_modifier = "add_${modifier_type}_method_modifier";
156 my $modifiers = $role->{"${modifier_type}_method_modifiers"};
158 while(my($method_name, $modifier_codes) = each %{$modifiers}){
159 foreach my $code(@{$modifier_codes}){
160 $class->$add_modifier($method_name => $code);
168 my($role, $class, $args) = @_;
170 my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
172 foreach my $r($role, @{$role->get_roles}){
173 if(!$class->does_role($r->name)){
180 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
182 my($self, $class, %args) = @_;
184 if ($class->isa('Mouse::Object')) {
185 Carp::croak('Mouse does not support Application::ToInstance yet');
188 $self->_check_required_methods($class, \%args);
189 $self->_apply_methods($class, \%args);
190 $self->_apply_attributes($class, \%args);
191 $self->_apply_modifiers($class, \%args);
192 $self->_append_roles($class, \%args);
197 my(undef, $class, @roles) = @_;
199 foreach my $role_spec (@roles) {
200 my($role_name, $args) = @{$role_spec};
202 my $role = $role_name->meta;
204 $role->_check_required_methods($class, $args, @roles);
205 $role->_apply_methods($class, $args);
206 $role->_apply_attributes($class, $args);
207 $role->_apply_modifiers($class, $args);
208 $role->_append_roles($class, $args);
213 for my $modifier_type (qw/before after around override/) {
215 my $modifier = "${modifier_type}_method_modifiers";
216 my $add_method_modifier = sub {
217 my ($self, $method_name, $method) = @_;
219 push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
222 my $get_method_modifiers = sub {
223 my ($self, $method_name) = @_;
224 return @{ $self->{$modifier}->{$method_name} ||= [] }
228 *{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier;
229 *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
232 sub get_roles { $_[0]->{roles} }
234 # This is currently not passing all the Moose tests.
236 my ($self, $role_name) = @_;
239 || confess "You must supply a role name to look for";
241 # if we are it,.. then return true
242 return 1 if $role_name eq $self->name;
243 # otherwise.. check our children
244 for my $role (@{ $self->get_roles }) {
245 return 1 if $role->does_role($role_name);