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