lib/Mouse/Meta/Role.pm

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