lib/Mouse/Meta/Role.pm

   1 package Mouse::Meta::Role;
   2 use strict;
   3 use warnings;
   4 use Carp 'confess';
   5
   6 do {
   7     my %METACLASS_CACHE;
   8
   9     # because Mouse doesn't introspect existing classes, we're forced to
  10     # only pay attention to other Mouse classes
  11     sub _metaclass_cache {
  12         my $class = shift;
  13         my $name  = shift;
  14         return $METACLASS_CACHE{$name};
  15     }
  16
  17     sub initialize {
  18         my $class = shift;
  19         my $name  = shift;
  20         $METACLASS_CACHE{$name} = $class->new(name => $name)
  21             if !exists($METACLASS_CACHE{$name});
  22         return $METACLASS_CACHE{$name};
  23     }
  24 };
  25
  26 sub new {
  27     my $class = shift;
  28     my %args  = @_;
  29
  30     $args{attributes}       ||= {};
  31     $args{required_methods} ||= [];
  32     $args{roles}            ||= [];
  33
  34     bless \%args, $class;
  35 }
  36
  37 sub name { $_[0]->{name} }
  38
  39 sub add_required_methods {
  40     my $self = shift;
  41     my @methods = @_;
  42     push @{$self->{required_methods}}, @methods;
  43 }
  44
  45 sub add_attribute {
  46     my $self = shift;
  47     my $name = shift;
  48     my $spec = shift;
  49     $self->{attributes}->{$name} = $spec;
  50 }
  51
  52 sub has_attribute { exists $_[0]->{attributes}->{$_[1]}  }
  53 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
  54 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
  55
  56 # copied from Class::Inspector
  57 sub get_method_list {
  58     my $self = shift;
  59     my $name = $self->name;
  60
  61     no strict 'refs';
  62     # Get all the CODE symbol table entries
  63     my @functions =
  64       grep !/(?:has|with|around|before|after|blessed|extends|confess|excludes|meta|requires)/,
  65       grep { defined &{"${name}::$_"} }
  66       keys %{"${name}::"};
  67     wantarray ? @functions : \@functions;
  68 }
  69
  70 sub apply {
  71     my $self  = shift;
  72     my $selfname = $self->name;
  73     my $class = shift;
  74     my $classname = $class->name;
  75     my %args  = @_;
  76
  77     if ($class->isa('Mouse::Meta::Class')) {
  78         for my $name (@{$self->{required_methods}}) {
  79             unless ($classname->can($name)) {
  80                 confess "'$selfname' requires the method '$name' to be implemented by '$classname'";
  81             }
  82         }
  83     }
  84
  85     {
  86         no strict 'refs';
  87         for my $name ($self->get_method_list) {
  88             next if $name eq 'meta';
  89
  90             if ($classname->can($name)) {
  91                 # XXX what's Moose's behavior?
  92                 #next;
  93             } else {
  94                 *{"${classname}::${name}"} = *{"${selfname}::${name}"};
  95             }
  96             if ($args{alias} && $args{alias}->{$name}) {
  97                 my $dstname = $args{alias}->{$name};
  98                 unless ($classname->can($dstname)) {
  99                     *{"${classname}::${dstname}"} = *{"${selfname}::${name}"};
 100                 }
 101             }
 102         }
 103     }
 104
 105     if ($class->isa('Mouse::Meta::Class')) {
 106         # apply role to class
 107         for my $name ($self->get_attribute_list) {
 108             next if $class->has_attribute($name);
 109             my $spec = $self->get_attribute($name);
 110             Mouse::Meta::Attribute->create($class, $name, %$spec);
 111         }
 112     } else {
 113         # apply role to role
 114         # XXX Room for speed improvement
 115         for my $name ($self->get_attribute_list) {
 116             next if $class->has_attribute($name);
 117             my $spec = $self->get_attribute($name);
 118             $class->add_attribute($name, $spec);
 119         }
 120     }
 121
 122     # XXX Room for speed improvement in role to role
 123     for my $modifier_type (qw/before after around/) {
 124         my $add_method = "add_${modifier_type}_method_modifier";
 125         my $modified = $self->{"${modifier_type}_method_modifiers"};
 126
 127         for my $method_name (keys %$modified) {
 128             for my $code (@{ $modified->{$method_name} }) {
 129                 $class->$add_method($method_name => $code);
 130             }
 131         }
 132     }
 133
 134     # append roles
 135     push @{ $class->roles }, $self, @{ $self->roles };
 136 }
 137
 138 sub combine_apply {
 139     my(undef, $class, @roles) = @_;
 140     my $classname = $class->name;
 141
 142     if ($class->isa('Mouse::Meta::Class')) {
 143         for my $role_spec (@roles) {
 144             my $self = $role_spec->[0]->meta;
 145             for my $name (@{$self->{required_methods}}) {
 146                 unless ($classname->can($name)) {
 147                     my $method_required = 0;
 148                     for my $role (@roles) {
 149                         $method_required = 1 if $self->name ne $role->[0] && $role->[0]->can($name);
 150                     }
 151                     confess "'".$self->name."' requires the method '$name' to be implemented by '$classname'"
 152                         unless $method_required;
 153                 }
 154             }
 155         }
 156     }
 157
 158     {
 159         no strict 'refs';
 160         for my $role_spec (@roles) {
 161             my $self = $role_spec->[0]->meta;
 162             my $selfname = $self->name;
 163             my %args = %{ $role_spec->[1] };
 164             for my $name ($self->get_method_list) {
 165                 next if $name eq 'meta';
 166
 167                 if ($classname->can($name)) {
 168                     # XXX what's Moose's behavior?
 169                     #next;
 170                 } else {
 171                     *{"${classname}::${name}"} = *{"${selfname}::${name}"};
 172                 }
 173                 if ($args{alias} && $args{alias}->{$name}) {
 174                     my $dstname = $args{alias}->{$name};
 175                     unless ($classname->can($dstname)) {
 176                         *{"${classname}::${dstname}"} = *{"${selfname}::${name}"};
 177                     }
 178                 }
 179             }
 180         }
 181     }
 182
 183
 184     if ($class->isa('Mouse::Meta::Class')) {
 185         # apply role to class
 186         for my $role_spec (@roles) {
 187             my $self = $role_spec->[0]->meta;
 188             for my $name ($self->get_attribute_list) {
 189                 next if $class->has_attribute($name);
 190                 my $spec = $self->get_attribute($name);
 191                 Mouse::Meta::Attribute->create($class, $name, %$spec);
 192             }
 193         }
 194     } else {
 195         # apply role to role
 196         # XXX Room for speed improvement
 197         for my $role_spec (@roles) {
 198             my $self = $role_spec->[0]->meta;
 199             for my $name ($self->get_attribute_list) {
 200                 next if $class->has_attribute($name);
 201                 my $spec = $self->get_attribute($name);
 202                 $class->add_attribute($name, $spec);
 203             }
 204         }
 205     }
 206
 207     # XXX Room for speed improvement in role to role
 208     for my $modifier_type (qw/before after around/) {
 209         my $add_method = "add_${modifier_type}_method_modifier";
 210         for my $role_spec (@roles) {
 211             my $self = $role_spec->[0]->meta;
 212             my $modified = $self->{"${modifier_type}_method_modifiers"};
 213
 214             for my $method_name (keys %$modified) {
 215                 for my $code (@{ $modified->{$method_name} }) {
 216                     $class->$add_method($method_name => $code);
 217                 }
 218             }
 219         }
 220     }
 221
 222     # append roles
 223     my %role_apply_cache;
 224     my @apply_roles;
 225     for my $role_spec (@roles) {
 226         my $self = $role_spec->[0]->meta;
 227         push @apply_roles, $self unless $role_apply_cache{$self}++;
 228         for my $role ($self->roles) {
 229             push @apply_roles, $role unless $role_apply_cache{$role}++;
 230         }
 231     }
 232 }
 233
 234 for my $modifier_type (qw/before after around/) {
 235     no strict 'refs';
 236     *{ __PACKAGE__ . '::' . "add_${modifier_type}_method_modifier" } = sub {
 237         my ($self, $method_name, $method) = @_;
 238
 239         push @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} },
 240             $method;
 241     };
 242
 243     *{ __PACKAGE__ . '::' . "get_${modifier_type}_method_modifiers" } = sub {
 244         my ($self, $method_name, $method) = @_;
 245         @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} || [] }
 246     };
 247 }
 248
 249 sub roles { $_[0]->{roles} }
 250
 251 1;
 252