lib/Mouse/Meta/Role.pm

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