2 package Moose::Meta::Class;
10 use Scalar::Util 'weaken', 'blessed', 'reftype';
12 our $VERSION = '0.11';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use Moose::Meta::Method::Overriden;
17 use base 'Class::MOP::Class';
19 __PACKAGE__->meta->add_attribute('roles' => (
27 $class->SUPER::initialize($pkg,
28 'attribute_metaclass' => 'Moose::Meta::Attribute',
29 'method_metaclass' => 'Moose::Meta::Method',
30 'instance_metaclass' => 'Moose::Meta::Instance',
35 my ($self, $role) = @_;
36 (blessed($role) && $role->isa('Moose::Meta::Role'))
37 || confess "Roles must be instances of Moose::Meta::Role";
38 push @{$self->roles} => $role;
41 sub calculate_all_roles {
44 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
48 my ($self, $role_name) = @_;
50 || confess "You must supply a role name to look for";
51 foreach my $class ($self->class_precedence_list) {
52 next unless $class->can('meta');
53 foreach my $role (@{$class->meta->roles}) {
54 return 1 if $role->does_role($role_name);
61 my ($self, $role_name) = @_;
63 || confess "You must supply a role name to look for";
64 foreach my $class ($self->class_precedence_list) {
65 next unless $class->can('meta');
66 foreach my $role (@{$class->meta->roles}) {
67 return 1 if $role->excludes_role($role_name);
74 my ($class, %params) = @_;
75 my $self = $class->SUPER::new_object(%params);
76 foreach my $attr ($class->compute_all_applicable_attributes()) {
78 # this does not accept undefined
79 # values, nor does it accept false
80 # values to be passed into the init-arg
81 next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
82 $attr->trigger->($self, $params{$attr->init_arg}, $attr);
87 sub construct_instance {
88 my ($class, %params) = @_;
89 my $meta_instance = $class->get_meta_instance;
91 # the code below is almost certainly incorrect
92 # but this is foreign inheritence, so we might
93 # have to kludge it in the end.
94 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
95 foreach my $attr ($class->compute_all_applicable_attributes()) {
96 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
106 my $map = $self->{'%!methods'};
108 my $class_name = $self->name;
109 my $method_metaclass = $self->method_metaclass;
111 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
113 my $code = $self->get_package_symbol('&' . $symbol);
115 next if exists $map->{$symbol} &&
116 defined $map->{$symbol} &&
117 $map->{$symbol}->body == $code;
119 my $gv = B::svref_2object($code)->GV;
121 my $pkg = $gv->STASH->NAME;
122 if ($pkg->can('meta') && $pkg->meta && $pkg->meta->isa('Moose::Meta::Role')) {
123 #my $role = $pkg->meta->name;
124 #next unless $self->does_role($role);
127 next if ($gv->STASH->NAME || '') ne $class_name &&
128 ($gv->NAME || '') ne '__ANON__';
131 $map->{$symbol} = $method_metaclass->wrap($code);
137 ### ---------------------------------------------
142 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
144 # if it is a HASH ref, we de-ref it.
145 # this will usually mean that it is
147 $self->SUPER::add_attribute($name => %{$_[0]});
150 # otherwise we just pass the args
151 $self->SUPER::add_attribute($name => @_);
155 sub add_override_method_modifier {
156 my ($self, $name, $method, $_super_package) = @_;
157 (!$self->has_method($name))
158 || confess "Cannot add an override method if a local method is already present";
159 # need this for roles ...
160 $_super_package ||= $self->name;
161 my $super = $self->find_next_method_by_name($name);
163 || confess "You cannot override '$name' because it has no super method";
164 $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
167 no warnings 'redefine';
168 local *{$_super_package . '::super'} = sub { $super->(@args) };
169 return $method->(@args);
173 sub add_augment_method_modifier {
174 my ($self, $name, $method) = @_;
175 (!$self->has_method($name))
176 || confess "Cannot add an augment method if a local method is already present";
177 my $super = $self->find_next_method_by_name($name);
179 || confess "You cannot augment '$name' because it has no super method";
180 my $_super_package = $super->package_name;
181 # BUT!,... if this is an overriden method ....
182 if ($super->isa('Moose::Meta::Method::Overriden')) {
183 # we need to be sure that we actually
184 # find the next method, which is not
185 # an 'override' method, the reason is
186 # that an 'override' method will not
187 # be the one calling inner()
188 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
189 $_super_package = $real_super->package_name;
191 $self->add_method($name => sub {
194 no warnings 'redefine';
195 local *{$_super_package . '::inner'} = sub { $method->(@args) };
196 return $super->(@args);
200 ## Private Utility methods ...
202 sub _find_next_method_by_name_which_is_not_overridden {
203 my ($self, $name) = @_;
204 foreach my $method ($self->find_all_methods_by_name($name)) {
205 return $method->{code}
206 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
211 sub _fix_metaclass_incompatability {
212 my ($self, @superclasses) = @_;
213 foreach my $super (@superclasses) {
214 # don't bother if it does not have a meta.
215 next unless $super->can('meta');
216 # get the name, make sure we take
217 # immutable classes into account
218 my $super_meta_name = ($super->meta->is_immutable
219 ? $super->meta->get_mutable_metaclass_name
220 : blessed($super->meta));
221 # if it's meta is a vanilla Moose,
222 # then we can safely ignore it.
223 next if $super_meta_name eq 'Moose::Meta::Class';
224 # but if we have anything else,
225 # we need to check it out ...
226 unless (# see if of our metaclass is incompatible
227 ($self->isa($super_meta_name) &&
228 # and see if our instance metaclass is incompatible
229 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
230 # ... and if we are just a vanilla Moose
231 $self->isa('Moose::Meta::Class')) {
232 # re-initialize the meta ...
233 my $super_meta = $super->meta;
235 # We might want to consider actually
236 # transfering any attributes from the
237 # original meta into this one, but in
238 # general you should not have any there
239 # at this point anyway, so it's very
240 # much an obscure edge case anyway
241 $self = $super_meta->reinitialize($self->name => (
242 'attribute_metaclass' => $super_meta->attribute_metaclass,
243 'method_metaclass' => $super_meta->method_metaclass,
244 'instance_metaclass' => $super_meta->instance_metaclass,
251 sub _apply_all_roles {
252 my ($self, @roles) = @_;
253 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
254 || confess "You can only consume roles, $_ is not a Moose role"
256 if (scalar @roles == 1) {
257 $roles[0]->meta->apply($self);
261 # we should make a Moose::Meta::Role::Composite
262 # which is a smaller version of Moose::Meta::Role
263 # which does not use any package stuff
264 Moose::Meta::Role->combine(
265 map { $_->meta } @roles
270 sub _process_attribute {
271 my ($self, $name, %options) = @_;
272 if ($name =~ /^\+(.*)/) {
273 my $new_attr = $self->_process_inherited_attribute($1, %options);
274 $self->add_attribute($new_attr);
277 if ($options{metaclass}) {
278 Class::MOP::load_class($options{metaclass});
279 $self->add_attribute($options{metaclass}->new($name, %options));
282 $self->add_attribute($name, %options);
287 sub _process_inherited_attribute {
288 my ($self, $attr_name, %options) = @_;
289 my $inherited_attr = $self->find_attribute_by_name($attr_name);
290 (defined $inherited_attr)
291 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
293 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
294 $new_attr = $inherited_attr->clone_and_inherit_options(%options);
298 # kind of a kludge to handle Class::MOP::Attributes
299 $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
300 $inherited_attr, %options
306 ## -------------------------------------------------
308 use Moose::Meta::Method::Constructor;
309 use Moose::Meta::Method::Destructor;
313 # the immutable version of a
314 # particular metaclass is
315 # really class-level data so
316 # we don't want to regenerate
317 # it any more than we need to
318 my $IMMUTABLE_METACLASS;
322 $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
323 read_only => [qw/superclasses/],
331 remove_package_symbol
335 class_precedence_list => 'ARRAY',
336 compute_all_applicable_attributes => 'ARRAY',
337 get_meta_instance => 'SCALAR',
338 get_method_map => 'SCALAR',
340 calculate_all_roles => 'ARRAY',
344 $IMMUTABLE_METACLASS->make_metaclass_immutable(
346 constructor_class => 'Moose::Meta::Method::Constructor',
347 destructor_class => 'Moose::Meta::Method::Destructor',
348 inline_destructor => 1,
350 # no need to do this,
351 # Moose always does it
352 inline_accessors => 0,
366 Moose::Meta::Class - The Moose metaclass
370 This is a subclass of L<Class::MOP::Class> with Moose specific
373 For the most part, the only time you will ever encounter an
374 instance of this class is if you are doing some serious deep
375 introspection. To really understand this class, you need to refer
376 to the L<Class::MOP::Class> documentation.
384 =item B<make_immutable>
388 We override this method to support the C<trigger> attribute option.
390 =item B<construct_instance>
392 This provides some Moose specific extensions to this method, you
393 almost never call this method directly unless you really know what
396 This method makes sure to handle the moose weak-ref, type-constraint
397 and type coercion features.
399 =item B<get_method_map>
401 This accommodates Moose::Meta::Role::Method instances, which are
402 aliased, instead of added, but still need to be counted as valid
405 =item B<add_override_method_modifier ($name, $method)>
407 This will create an C<override> method modifier for you, and install
410 =item B<add_augment_method_modifier ($name, $method)>
412 This will create an C<augment> method modifier for you, and install
415 =item B<calculate_all_roles>
419 This will return an array of C<Moose::Meta::Role> instances which are
420 attached to this class.
422 =item B<add_role ($role)>
424 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
425 to the list of associated roles.
427 =item B<does_role ($role_name)>
429 This will test if this class C<does> a given C<$role_name>. It will
430 not only check it's local roles, but ask them as well in order to
431 cascade down the role hierarchy.
433 =item B<excludes_role ($role_name)>
435 This will test if this class C<excludes> a given C<$role_name>. It will
436 not only check it's local roles, but ask them as well in order to
437 cascade down the role hierarchy.
439 =item B<add_attribute ($attr_name, %params|$params)>
441 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
442 support for taking the C<$params> as a HASH ref.
448 All complex software has bugs lurking in it, and this module is no
449 exception. If you find a bug please either email me, or add the bug
454 Stevan Little E<lt>stevan@iinteractive.comE<gt>
456 =head1 COPYRIGHT AND LICENSE
458 Copyright 2006, 2007 by Infinity Interactive, Inc.
460 L<http://www.iinteractive.com>
462 This library is free software; you can redistribute it and/or modify
463 it under the same terms as Perl itself.