lib/Mouse/Meta/Role.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Meta::Role;
   3 use strict;
   4 use warnings;
   5 use Carp 'confess';
   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
  34     bless \%args, $class;
  35 }
  36
  37 sub name { $_[0]->{name} }
  38
  39 sub add_required_methods {
  40     my $self = shift;
  41     my @methods = @_;
  42     push @{$self->{required_methods}}, @methods;
  43 }
  44
  45 sub add_attribute {
  46     my $self = shift;
  47     my $name = shift;
  48     my $spec = shift;
  49     $self->{attributes}->{$name} = $spec;
  50 }
  51
  52 sub has_attribute { exists $_[0]->{attributes}->{$_[1]}  }
  53 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
  54 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
  55
  56 # copied from Class::Inspector
  57 sub get_method_list {
  58     my $self = shift;
  59     my $name = $self->name;
  60
  61     no strict 'refs';
  62     # Get all the CODE symbol table entries
  63     my @functions = grep !/^meta$/,
  64       grep { /\A[^\W\d]\w*\z/o }
  65       grep { defined &{"${name}::$_"} }
  66       keys %{"${name}::"};
  67     wantarray ? @functions : \@functions;
  68 }
  69
  70 sub apply {
  71     my $self  = shift;
  72     my $selfname = $self->name;
  73     my $class = shift;
  74     my $classname = $class->name;
  75     my %args  = @_;
  76
  77     if ($class->isa('Mouse::Meta::Class')) {
  78         for my $name (@{$self->{required_methods}}) {
  79             unless ($classname->can($name)) {
  80                 confess "'$selfname' requires the method '$name' to be implemented by '$classname'";
  81             }
  82         }
  83     }
  84
  85     {
  86         no strict 'refs';
  87         for my $name ($self->get_method_list) {
  88             next if $name eq 'has' || $name eq 'requires' || $name eq 'meta' || $name eq 'with' || $name eq 'around' || $name eq 'before' || $name eq 'after' || $name eq 'blessed' || $name eq 'extends' || $name eq 'confess' || $name eq 'excludes';
  89             my $dstname = $args{alias} ? ($args{alias}->{$name}||$name) : $name;
  90             if ($classname->can($dstname)) {
  91                 # XXX what's Moose's behavior?
  92                 next;
  93             }
  94             *{"${classname}::${dstname}"} = *{"${selfname}::${name}"};
  95         }
  96     }
  97
  98     if ($class->isa('Mouse::Meta::Class')) {
  99         # apply role to class
 100         for my $name ($self->get_attribute_list) {
 101             next if $class->has_attribute($name);
 102             my $spec = $self->get_attribute($name);
 103             Mouse::Meta::Attribute->create($class, $name, %$spec);
 104         }
 105     } else {
 106         # apply role to role
 107         # XXX Room for speed improvement
 108         for my $name ($self->get_attribute_list) {
 109             next if $class->has_attribute($name);
 110             my $spec = $self->get_attribute($name);
 111             $class->add_attribute($name, $spec);
 112         }
 113     }
 114
 115     # XXX Room for speed improvement in role to role
 116     for my $modifier_type (qw/before after around/) {
 117         my $add_method = "add_${modifier_type}_method_modifier";
 118         my $modified = $self->{"${modifier_type}_method_modifiers"};
 119
 120         for my $method_name (keys %$modified) {
 121             for my $code (@{ $modified->{$method_name} }) {
 122                 $class->$add_method($method_name => $code);
 123             }
 124         }
 125     }
 126 }
 127
 128 for my $modifier_type (qw/before after around/) {
 129     no strict 'refs';
 130     *{ __PACKAGE__ . '::' . "add_${modifier_type}_method_modifier" } = sub {
 131         my ($self, $method_name, $method) = @_;
 132
 133         push @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} },
 134             $method;
 135     };
 136
 137     *{ __PACKAGE__ . '::' . "get_${modifier_type}_method_modifiers" } = sub {
 138         my ($self, $method_name, $method) = @_;
 139         @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} || [] }
 140     };
 141 }
 142
 143 1;
 144