1 package Mouse::Meta::Role;
9 # because Mouse doesn't introspect existing classes, we're forced to
10 # only pay attention to other Mouse classes
11 sub _metaclass_cache {
14 return $METACLASS_CACHE{$name};
20 $METACLASS_CACHE{$name} = $class->new(name => $name)
21 if !exists($METACLASS_CACHE{$name});
22 return $METACLASS_CACHE{$name};
30 $args{attributes} ||= {};
31 $args{required_methods} ||= [];
37 sub name { $_[0]->{name} }
39 sub add_required_methods {
42 push @{$self->{required_methods}}, @methods;
49 $self->{attributes}->{$name} = $spec;
52 sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
53 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
54 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
56 # copied from Class::Inspector
59 my $name = $self->name;
62 # Get all the CODE symbol table entries
64 grep !/^(?:has|with|around|before|after|blessed|extends|confess|excludes|meta|requires)$/,
65 grep { defined &{"${name}::$_"} }
67 wantarray ? @functions : \@functions;
72 my $selfname = $self->name;
74 my $classname = $class->name;
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'";
87 for my $name ($self->get_method_list) {
88 next if $name eq 'meta';
90 if ($classname->can($name)) {
91 # XXX what's Moose's behavior?
94 *{"${classname}::${name}"} = *{"${selfname}::${name}"};
96 if ($args{alias} && $args{alias}->{$name}) {
97 my $dstname = $args{alias}->{$name};
98 unless ($classname->can($dstname)) {
99 *{"${classname}::${dstname}"} = *{"${selfname}::${name}"};
105 if ($class->isa('Mouse::Meta::Class')) {
106 # apply role to class
107 for my $name ($self->get_attribute_list) {
108 next if $class->has_attribute($name);
109 my $spec = $self->get_attribute($name);
110 Mouse::Meta::Attribute->create($class, $name, %$spec);
114 # XXX Room for speed improvement
115 for my $name ($self->get_attribute_list) {
116 next if $class->has_attribute($name);
117 my $spec = $self->get_attribute($name);
118 $class->add_attribute($name, $spec);
122 # XXX Room for speed improvement in role to role
123 for my $modifier_type (qw/before after around/) {
124 my $add_method = "add_${modifier_type}_method_modifier";
125 my $modified = $self->{"${modifier_type}_method_modifiers"};
127 for my $method_name (keys %$modified) {
128 for my $code (@{ $modified->{$method_name} }) {
129 $class->$add_method($method_name => $code);
135 push @{ $class->roles }, $self, @{ $self->roles };
139 my(undef, $class, @roles) = @_;
140 my $classname = $class->name;
142 if ($class->isa('Mouse::Meta::Class')) {
143 for my $role_spec (@roles) {
144 my $self = $role_spec->[0]->meta;
145 for my $name (@{$self->{required_methods}}) {
146 unless ($classname->can($name)) {
147 my $method_required = 0;
148 for my $role (@roles) {
149 $method_required = 1 if $self->name ne $role->[0] && $role->[0]->can($name);
151 confess "'".$self->name."' requires the method '$name' to be implemented by '$classname'"
152 unless $method_required;
160 for my $role_spec (@roles) {
161 my $self = $role_spec->[0]->meta;
162 my $selfname = $self->name;
163 my %args = %{ $role_spec->[1] };
164 for my $name ($self->get_method_list) {
165 next if $name eq 'meta';
167 if ($classname->can($name)) {
168 # XXX what's Moose's behavior?
171 *{"${classname}::${name}"} = *{"${selfname}::${name}"};
173 if ($args{alias} && $args{alias}->{$name}) {
174 my $dstname = $args{alias}->{$name};
175 unless ($classname->can($dstname)) {
176 *{"${classname}::${dstname}"} = *{"${selfname}::${name}"};
184 if ($class->isa('Mouse::Meta::Class')) {
185 # apply role to class
186 for my $role_spec (@roles) {
187 my $self = $role_spec->[0]->meta;
188 for my $name ($self->get_attribute_list) {
189 next if $class->has_attribute($name);
190 my $spec = $self->get_attribute($name);
191 Mouse::Meta::Attribute->create($class, $name, %$spec);
196 # XXX Room for speed improvement
197 for my $role_spec (@roles) {
198 my $self = $role_spec->[0]->meta;
199 for my $name ($self->get_attribute_list) {
200 next if $class->has_attribute($name);
201 my $spec = $self->get_attribute($name);
202 $class->add_attribute($name, $spec);
207 # XXX Room for speed improvement in role to role
208 for my $modifier_type (qw/before after around/) {
209 my $add_method = "add_${modifier_type}_method_modifier";
210 for my $role_spec (@roles) {
211 my $self = $role_spec->[0]->meta;
212 my $modified = $self->{"${modifier_type}_method_modifiers"};
214 for my $method_name (keys %$modified) {
215 for my $code (@{ $modified->{$method_name} }) {
216 $class->$add_method($method_name => $code);
223 my %role_apply_cache;
225 for my $role_spec (@roles) {
226 my $self = $role_spec->[0]->meta;
227 push @apply_roles, $self unless $role_apply_cache{$self}++;
228 for my $role ($self->roles) {
229 push @apply_roles, $role unless $role_apply_cache{$role}++;
234 for my $modifier_type (qw/before after around/) {
236 *{ __PACKAGE__ . '::' . "add_${modifier_type}_method_modifier" } = sub {
237 my ($self, $method_name, $method) = @_;
239 push @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} },
243 *{ __PACKAGE__ . '::' . "get_${modifier_type}_method_modifiers" } = sub {
244 my ($self, $method_name, $method) = @_;
245 @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} || [] }
249 sub roles { $_[0]->{roles} }