lib/Mouse/Meta/Role.pm

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