lib/Mouse/Meta/Role.pm

   1 package Mouse::Meta::Role;
   2 use strict;
   3 use warnings;
   4 use Carp 'confess';
   5 use Mouse::Util qw(version authority identifier);
   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
  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 # copied from Class::Inspector
  60 sub get_method_list {
  61     my $self = shift;
  62     my $name = $self->name;
  63
  64     no strict 'refs';
  65     # Get all the CODE symbol table entries
  66     my @functions =
  67       grep !/^(?:has|with|around|before|after|blessed|extends|confess|excludes|meta|requires)$/,
  68       grep { defined &{"${name}::$_"} }
  69       keys %{"${name}::"};
  70     wantarray ? @functions : \@functions;
  71 }
  72
  73 sub apply {
  74     my $self  = shift;
  75     my $selfname = $self->name;
  76     my $class = shift;
  77     my $classname = $class->name;
  78     my %args  = @_;
  79
  80     if ($class->isa('Mouse::Meta::Class')) {
  81         for my $name (@{$self->{required_methods}}) {
  82             unless ($classname->can($name)) {
  83                 confess "'$selfname' requires the method '$name' to be implemented by '$classname'";
  84             }
  85         }
  86     }
  87
  88     {
  89         no strict 'refs';
  90         for my $name ($self->get_method_list) {
  91             next if $name eq 'meta';
  92
  93             my $class_function = "${classname}::${name}";
  94             my $role_function = "${selfname}::${name}";
  95             if (defined &$class_function) {
  96                 # XXX what's Moose's behavior?
  97                 #next;
  98             } else {
  99                 *$class_function = *$role_function;
 100             }
 101             if ($args{alias} && $args{alias}->{$name}) {
 102                 my $dstname = $args{alias}->{$name};
 103                 unless ($classname->can($dstname)) {
 104                     *{"${classname}::${dstname}"} = \&$role_function;
 105                 }
 106             }
 107         }
 108     }
 109
 110     if ($class->isa('Mouse::Meta::Class')) {
 111         # apply role to class
 112         for my $name ($self->get_attribute_list) {
 113             next if $class->has_attribute($name);
 114             my $spec = $self->get_attribute($name);
 115
 116             my $metaclass = 'Mouse::Meta::Attribute';
 117             if ( my $metaclass_name = $spec->{metaclass} ) {
 118                 my $new_class = Mouse::Util::resolve_metaclass_alias(
 119                     'Attribute',
 120                     $metaclass_name
 121                 );
 122                 if ( $metaclass ne $new_class ) {
 123                     $metaclass = $new_class;
 124                 }
 125             }
 126
 127             $metaclass->create($class, $name, %$spec);
 128         }
 129     } else {
 130         # apply role to role
 131         # XXX Room for speed improvement
 132         for my $name ($self->get_attribute_list) {
 133             next if $class->has_attribute($name);
 134             my $spec = $self->get_attribute($name);
 135             $class->add_attribute($name, $spec);
 136         }
 137     }
 138
 139     # XXX Room for speed improvement in role to role
 140     for my $modifier_type (qw/before after around override/) {
 141         my $add_method = "add_${modifier_type}_method_modifier";
 142         my $modified = $self->{"${modifier_type}_method_modifiers"};
 143
 144         for my $method_name (keys %$modified) {
 145             for my $code (@{ $modified->{$method_name} }) {
 146                 $class->$add_method($method_name => $code);
 147             }
 148         }
 149     }
 150
 151     # append roles
 152     push @{ $class->roles }, $self, @{ $self->roles };
 153 }
 154
 155 sub combine_apply {
 156     my(undef, $class, @roles) = @_;
 157     my $classname = $class->name;
 158
 159     if ($class->isa('Mouse::Meta::Class')) {
 160         for my $role_spec (@roles) {
 161             my $self = $role_spec->[0]->meta;
 162             for my $name (@{$self->{required_methods}}) {
 163                 unless ($classname->can($name)) {
 164                     my $method_required = 0;
 165                     for my $role (@roles) {
 166                         $method_required = 1 if $self->name ne $role->[0] && $role->[0]->can($name);
 167                     }
 168                     confess "'".$self->name."' requires the method '$name' to be implemented by '$classname'"
 169                         unless $method_required;
 170                 }
 171             }
 172         }
 173     }
 174
 175     {
 176         no strict 'refs';
 177         for my $role_spec (@roles) {
 178             my $self = $role_spec->[0]->meta;
 179             my $selfname = $self->name;
 180             my %args = %{ $role_spec->[1] };
 181             for my $name ($self->get_method_list) {
 182                 next if $name eq 'meta';
 183
 184                 my $class_function = "${classname}::${name}";
 185                 my $role_function = "${selfname}::${name}";
 186                 if (defined &$class_function) {
 187                     # XXX what's Moose's behavior?
 188                     #next;
 189                 } else {
 190                     *$class_function = *$role_function;
 191                 }
 192                 if ($args{alias} && $args{alias}->{$name}) {
 193                     my $dstname = $args{alias}->{$name};
 194                     unless ($classname->can($dstname)) {
 195                         *{"${classname}::${dstname}"} = \&$role_function;
 196                     }
 197                 }
 198             }
 199         }
 200     }
 201
 202
 203     if ($class->isa('Mouse::Meta::Class')) {
 204         # apply role to class
 205         for my $role_spec (@roles) {
 206             my $self = $role_spec->[0]->meta;
 207             for my $name ($self->get_attribute_list) {
 208                 next if $class->has_attribute($name);
 209                 my $spec = $self->get_attribute($name);
 210
 211                 my $metaclass = 'Mouse::Meta::Attribute';
 212                 if ( my $metaclass_name = $spec->{metaclass} ) {
 213                     my $new_class = Mouse::Util::resolve_metaclass_alias(
 214                         'Attribute',
 215                         $metaclass_name
 216                     );
 217                     if ( $metaclass ne $new_class ) {
 218                         $metaclass = $new_class;
 219                     }
 220                 }
 221
 222                 $metaclass->create($class, $name, %$spec);
 223             }
 224         }
 225     } else {
 226         # apply role to role
 227         # XXX Room for speed improvement
 228         for my $role_spec (@roles) {
 229             my $self = $role_spec->[0]->meta;
 230             for my $name ($self->get_attribute_list) {
 231                 next if $class->has_attribute($name);
 232                 my $spec = $self->get_attribute($name);
 233                 $class->add_attribute($name, $spec);
 234             }
 235         }
 236     }
 237
 238     # XXX Room for speed improvement in role to role
 239     for my $modifier_type (qw/before after around override/) {
 240         my $add_method = "add_${modifier_type}_method_modifier";
 241         for my $role_spec (@roles) {
 242             my $self = $role_spec->[0]->meta;
 243             my $modified = $self->{"${modifier_type}_method_modifiers"};
 244
 245             for my $method_name (keys %$modified) {
 246                 for my $code (@{ $modified->{$method_name} }) {
 247                     $class->$add_method($method_name => $code);
 248                 }
 249             }
 250         }
 251     }
 252
 253     # append roles
 254     my %role_apply_cache;
 255     my $apply_roles = $class->roles;
 256     for my $role_spec (@roles) {
 257         my $self = $role_spec->[0]->meta;
 258         push @$apply_roles, $self unless $role_apply_cache{$self}++;
 259         for my $role (@{ $self->roles }) {
 260             push @$apply_roles, $role unless $role_apply_cache{$role}++;
 261         }
 262     }
 263 }
 264
 265 for my $modifier_type (qw/before after around override/) {
 266     no strict 'refs';
 267     *{ __PACKAGE__ . '::' . "add_${modifier_type}_method_modifier" } = sub {
 268         my ($self, $method_name, $method) = @_;
 269
 270         push @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} },
 271             $method;
 272     };
 273
 274     *{ __PACKAGE__ . '::' . "get_${modifier_type}_method_modifiers" } = sub {
 275         my ($self, $method_name, $method) = @_;
 276         @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} || [] }
 277     };
 278 }
 279
 280 sub roles { $_[0]->{roles} }
 281
 282
 283 # This is currently not passing all the Moose tests.
 284 sub does_role {
 285     my ($self, $role_name) = @_;
 286
 287     (defined $role_name)
 288         || confess "You must supply a role name to look for";
 289
 290     # if we are it,.. then return true
 291     return 1 if $role_name eq $self->name;
 292
 293     for my $role (@{ $self->{roles} }) {
 294         return 1 if $role->does_role($role_name);
 295     }
 296     return 0;
 297 }
 298
 299
 300 1;
 301