lib/Mouse/Meta/Role.pm

   1 package Mouse::Meta::Role;
   2 use strict;
   3 use warnings;
   4 use Carp 'confess';
   5
   6 use base qw(Mouse::Meta::Module);
   7
   8 do {
   9     my %METACLASS_CACHE;
  10
  11     # because Mouse doesn't introspect existing classes, we're forced to
  12     # only pay attention to other Mouse classes
  13     sub _metaclass_cache {
  14         my $class = shift;
  15         my $name  = shift;
  16         return $METACLASS_CACHE{$name};
  17     }
  18
  19     sub initialize {
  20         my($class, $package_name, @args) = @_;
  21
  22         ($package_name && !ref($package_name))\r
  23             || confess("You must pass a package name and it cannot be blessed");\r
  24
  25         return $METACLASS_CACHE{$package_name}
  26             ||= $class->_new(package => $package_name, @args);
  27     }
  28 };
  29
  30 sub _new {
  31     my $class = shift;
  32     my %args  = @_;
  33
  34     $args{methods}          ||= {};
  35     $args{attributes}       ||= {};
  36     $args{required_methods} ||= [];
  37     $args{roles}            ||= [];
  38
  39     bless \%args, $class;
  40 }
  41
  42 sub add_required_methods {
  43     my $self = shift;
  44     my @methods = @_;
  45     push @{$self->{required_methods}}, @methods;
  46 }
  47
  48 sub add_attribute {
  49     my $self = shift;
  50     my $name = shift;
  51     my $spec = shift;
  52     $self->{attributes}->{$name} = $spec;
  53 }
  54
  55 sub has_attribute { exists $_[0]->{attributes}->{$_[1]}  }
  56 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
  57 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
  58
  59 sub _check_required_methods{
  60     my($role, $class, $args, @other_roles) = @_;
  61
  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;
  67                 my $has_method      = 0;
  68
  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)){
  72                         $has_method = 1;
  73                         last;
  74                     }
  75                 }
  76
  77                 confess "'$role_name' requires the method '$method_name' to be implemented by '$class_name'"
  78                     unless $has_method;
  79             }
  80         }
  81     }
  82
  83     return;
  84 }
  85
  86 sub _apply_methods{
  87     my($role, $class, $args) = @_;
  88
  89     my $role_name  = $role->name;
  90     my $class_name = $class->name;
  91     my $alias      = $args->{alias};
  92
  93     foreach my $method_name($role->get_method_list){
  94         next if $method_name eq 'meta';
  95
  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?
  99         }
 100         else{
 101             $class->add_method($method_name => $code);
 102         }
 103
 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?
 108             }
 109             else{
 110                 $class->add_method($dstname => $code);
 111             }
 112         }
 113     }
 114
 115     return;
 116 }
 117
 118 sub _apply_attributes{
 119     my($role, $class, $args) = @_;
 120
 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);
 125
 126             my $spec = $role->get_attribute($attr_name);
 127
 128             my $attr_metaclass = 'Mouse::Meta::Attribute';
 129             if ( my $metaclass_name = $spec->{metaclass} ) {
 130                 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
 131                     'Attribute',
 132                     $metaclass_name
 133                 );
 134             }
 135
 136             $attr_metaclass->create($class, $attr_name => %$spec);
 137         }
 138     } else {
 139         # apply role to role
 140         for my $attr_name ($role->get_attribute_list) {
 141             next if $class->has_attribute($attr_name);
 142
 143             my $spec = $role->get_attribute($attr_name);
 144             $class->add_attribute($attr_name => $spec);
 145         }
 146     }
 147
 148     return;
 149 }
 150
 151 sub _apply_modifiers{
 152     my($role, $class, $args) = @_;
 153
 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"};
 157
 158         while(my($method_name, $modifier_codes) = each %{$modifiers}){
 159             foreach my $code(@{$modifier_codes}){
 160                 $class->$add_modifier($method_name => $code);
 161             }
 162         }
 163     }
 164     return;
 165 }
 166
 167 sub _append_roles{
 168     my($role, $class, $args) = @_;
 169
 170     my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
 171
 172     foreach my $r($role, @{$role->get_roles}){
 173         if(!$class->does_role($r->name)){
 174             push @{$roles}, $r;
 175         }
 176     }
 177     return;
 178 }
 179
 180 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 181 sub apply {
 182     my($self, $class, %args) = @_;
 183
 184     if ($class->isa('Mouse::Object')) {
 185         Carp::croak('Mouse does not support Application::ToInstance yet');
 186     }
 187
 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);
 193     return;
 194 }
 195
 196 sub combine_apply {
 197     my(undef, $class, @roles) = @_;
 198
 199     foreach my $role_spec (@roles) {
 200         my($role_name, $args) = @{$role_spec};
 201
 202         my $role = $role_name->meta;
 203
 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);
 209     }
 210     return;
 211 }
 212
 213 for my $modifier_type (qw/before after around override/) {
 214
 215     my $modifier = "${modifier_type}_method_modifiers";
 216     my $add_method_modifier =  sub {
 217         my ($self, $method_name, $method) = @_;
 218
 219         push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
 220         return;
 221     };
 222     my $get_method_modifiers = sub {
 223         my ($self, $method_name) = @_;
 224         return @{ $self->{$modifier}->{$method_name} ||= [] }
 225     };
 226
 227     no strict 'refs';
 228     *{ 'add_' . $modifier_type . '_method_modifier'  } = $add_method_modifier;
 229     *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
 230 }
 231
 232 sub get_roles { $_[0]->{roles} }
 233
 234 # This is currently not passing all the Moose tests.
 235 sub does_role {
 236     my ($self, $role_name) = @_;
 237
 238     (defined $role_name)
 239         || confess "You must supply a role name to look for";
 240
 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);
 246     }
 247     return 0;
 248 }
 249
 250
 251 1;
 252