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 get_roles { $_[0]->{roles} }
  43
  44
  45 sub add_required_methods {
  46     my $self = shift;
  47     my @methods = @_;
  48     push @{$self->{required_methods}}, @methods;
  49 }
  50
  51 sub add_attribute {
  52     my $self = shift;
  53     my $name = shift;
  54     my $spec = shift;
  55     $self->{attributes}->{$name} = $spec;
  56 }
  57
  58 sub has_attribute { exists $_[0]->{attributes}->{$_[1]}  }
  59 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
  60 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
  61
  62 sub _check_required_methods{
  63     my($role, $class, $args, @other_roles) = @_;
  64
  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;
  70                 my $has_method      = 0;
  71
  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)){
  75                         $has_method = 1;
  76                         last;
  77                     }
  78                 }
  79
  80                 confess "'$role_name' requires the method '$method_name' to be implemented by '$class_name'"
  81                     unless $has_method;
  82             }
  83         }
  84     }
  85
  86     return;
  87 }
  88
  89 sub _apply_methods{
  90     my($role, $class, $args) = @_;
  91
  92     my $role_name  = $role->name;
  93     my $class_name = $class->name;
  94     my $alias      = $args->{alias};
  95
  96     foreach my $method_name($role->get_method_list){
  97         next if $method_name eq 'meta';
  98
  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?
 102         }
 103         else{
 104             $class->add_method($method_name => $code);
 105         }
 106
 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?
 111             }
 112             else{
 113                 $class->add_method($dstname => $code);
 114             }
 115         }
 116     }
 117
 118     return;
 119 }
 120
 121 sub _apply_attributes{
 122     my($role, $class, $args) = @_;
 123
 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);
 128
 129             my $spec = $role->get_attribute($attr_name);
 130
 131             my $attr_metaclass = 'Mouse::Meta::Attribute';
 132             if ( my $metaclass_name = $spec->{metaclass} ) {
 133                 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
 134                     'Attribute',
 135                     $metaclass_name
 136                 );
 137             }
 138
 139             $attr_metaclass->create($class, $attr_name => %$spec);
 140         }
 141     } else {
 142         # apply role to role
 143         for my $attr_name ($role->get_attribute_list) {
 144             next if $class->has_attribute($attr_name);
 145
 146             my $spec = $role->get_attribute($attr_name);
 147             $class->add_attribute($attr_name => $spec);
 148         }
 149     }
 150
 151     return;
 152 }
 153
 154 sub _apply_modifiers{
 155     my($role, $class, $args) = @_;
 156
 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"};
 160
 161         while(my($method_name, $modifier_codes) = each %{$modifiers}){
 162             foreach my $code(@{$modifier_codes}){
 163                 $class->$add_modifier($method_name => $code);
 164             }
 165         }
 166     }
 167     return;
 168 }
 169
 170 sub _append_roles{
 171     my($role, $class, $args) = @_;
 172
 173     my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
 174
 175     foreach my $r($role, @{$role->get_roles}){
 176         if(!$class->does_role($r->name)){
 177             push @{$roles}, $r;
 178         }
 179     }
 180     return;
 181 }
 182
 183 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 184 sub apply {
 185     my($self, $class, %args) = @_;
 186
 187     if ($class->isa('Mouse::Object')) {
 188         Carp::croak('Mouse does not support Application::ToInstance yet');
 189     }
 190
 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);
 196     return;
 197 }
 198
 199 sub combine_apply {
 200     my(undef, $class, @roles) = @_;
 201
 202     foreach my $role_spec (@roles) {
 203         my($role_name, $args) = @{$role_spec};
 204
 205         my $role = $role_name->meta;
 206
 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);
 212     }
 213     return;
 214 }
 215
 216 for my $modifier_type (qw/before after around override/) {
 217
 218     my $modifier = "${modifier_type}_method_modifiers";
 219     my $add_method_modifier =  sub {
 220         my ($self, $method_name, $method) = @_;
 221
 222         push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
 223         return;
 224     };
 225     my $has_method_modifiers = sub{
 226         my($self, $method_name) = @_;
 227         my $m = $self->{$modifier}->{$method_name};
 228         return $m && @{$m} != 0;
 229     };
 230     my $get_method_modifiers = sub {
 231         my ($self, $method_name) = @_;
 232         return @{ $self->{$modifier}->{$method_name} ||= [] }
 233     };
 234
 235     no strict 'refs';
 236     *{ 'add_' . $modifier_type . '_method_modifier'  } = $add_method_modifier;
 237     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
 238     *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
 239 }
 240
 241 # This is currently not passing all the Moose tests.
 242 sub does_role {
 243     my ($self, $role_name) = @_;
 244
 245     (defined $role_name)
 246         || confess "You must supply a role name to look for";
 247
 248     # if we are it,.. then return true
 249     return 1 if $role_name eq $self->name;
 250     # otherwise.. check our children
 251     for my $role (@{ $self->get_roles }) {
 252         return 1 if $role->does_role($role_name);
 253     }
 254     return 0;
 255 }
 256
 257
 258 1;
 259