2 package Moose::Meta::Class;
9 use Carp qw( confess );
11 use List::Util qw( first );
12 use List::MoreUtils qw( any all uniq first_index );
13 use Scalar::Util 'weaken', 'blessed';
15 our $VERSION = '1.04';
16 $VERSION = eval $VERSION;
17 our $AUTHORITY = 'cpan:STEVAN';
19 use Moose::Meta::Method::Overridden;
20 use Moose::Meta::Method::Augmented;
21 use Moose::Error::Default;
22 use Moose::Meta::Class::Immutable::Trait;
23 use Moose::Meta::Method::Constructor;
24 use Moose::Meta::Method::Destructor;
26 use base 'Class::MOP::Class';
28 __PACKAGE__->meta->add_attribute('roles' => (
33 __PACKAGE__->meta->add_attribute('role_applications' => (
34 reader => '_get_role_applications',
38 __PACKAGE__->meta->add_attribute(
39 Class::MOP::Attribute->new('immutable_trait' => (
40 accessor => "immutable_trait",
41 default => 'Moose::Meta::Class::Immutable::Trait',
45 __PACKAGE__->meta->add_attribute('constructor_class' => (
46 accessor => 'constructor_class',
47 default => 'Moose::Meta::Method::Constructor',
50 __PACKAGE__->meta->add_attribute('destructor_class' => (
51 accessor => 'destructor_class',
52 default => 'Moose::Meta::Method::Destructor',
55 __PACKAGE__->meta->add_attribute('error_class' => (
56 accessor => 'error_class',
57 default => 'Moose::Error::Default',
63 return Class::MOP::get_metaclass_by_name($pkg)
64 || $class->SUPER::initialize($pkg,
65 'attribute_metaclass' => 'Moose::Meta::Attribute',
66 'method_metaclass' => 'Moose::Meta::Method',
67 'instance_metaclass' => 'Moose::Meta::Instance',
72 sub _immutable_options {
73 my ( $self, @args ) = @_;
75 $self->SUPER::_immutable_options(
76 inline_destructor => 1,
78 # Moose always does this when an attribute is created
79 inline_accessors => 0,
86 my ($class, $package_name, %options) = @_;
88 (ref $options{roles} eq 'ARRAY')
89 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
90 if exists $options{roles};
91 my $roles = delete $options{roles};
93 my $new_meta = $class->SUPER::create($package_name, %options);
96 Moose::Util::apply_all_roles( $new_meta, @$roles );
104 sub create_anon_class {
105 my ($self, %options) = @_;
107 my $cache_ok = delete $options{cache};
110 = _anon_cache_key( $options{superclasses}, $options{roles} );
112 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
113 return $ANON_CLASSES{$cache_key};
116 my $new_class = $self->SUPER::create_anon_class(%options);
118 $ANON_CLASSES{$cache_key} = $new_class
124 sub _anon_cache_key {
125 # Makes something like Super::Class|Super::Class::2=Role|Role::1
127 join( '|', @{ $_[0] || [] } ),
128 join( '|', sort @{ $_[1] || [] } ),
136 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
140 my %existing_classes;
142 %existing_classes = map { $_ => $meta->$_() } qw(
145 wrapped_method_metaclass
152 $cache_key = _anon_cache_key(
153 [ $meta->superclasses ],
154 [ map { $_->name } @{ $meta->roles } ],
155 ) if $meta->is_anon_class;
158 my $new_meta = $self->SUPER::reinitialize(
164 return $new_meta unless defined $cache_key;
166 my $new_cache_key = _anon_cache_key(
167 [ $meta->superclasses ],
168 [ map { $_->name } @{ $meta->roles } ],
171 delete $ANON_CLASSES{$cache_key};
172 $ANON_CLASSES{$new_cache_key} = $new_meta;
178 my ($self, $role) = @_;
179 (blessed($role) && $role->isa('Moose::Meta::Role'))
180 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
181 push @{$self->roles} => $role;
184 sub role_applications {
187 return @{$self->_get_role_applications};
190 sub add_role_application {
191 my ($self, $application) = @_;
192 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
193 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
194 push @{$self->_get_role_applications} => $application;
197 sub calculate_all_roles {
200 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
203 sub calculate_all_roles_with_inheritance {
206 grep { !$seen{$_->name}++ }
207 map { Class::MOP::class_of($_)->can('calculate_all_roles')
208 ? Class::MOP::class_of($_)->calculate_all_roles
210 $self->linearized_isa;
214 my ($self, $role_name) = @_;
217 || $self->throw_error("You must supply a role name to look for");
219 foreach my $class ($self->class_precedence_list) {
220 my $meta = Class::MOP::class_of($class);
221 # when a Moose metaclass is itself extended with a role,
222 # this check needs to be done since some items in the
223 # class_precedence_list might in fact be Class::MOP
225 next unless $meta && $meta->can('roles');
226 foreach my $role (@{$meta->roles}) {
227 return 1 if $role->does_role($role_name);
234 my ($self, $role_name) = @_;
237 || $self->throw_error("You must supply a role name to look for");
239 foreach my $class ($self->class_precedence_list) {
240 my $meta = Class::MOP::class_of($class);
241 # when a Moose metaclass is itself extended with a role,
242 # this check needs to be done since some items in the
243 # class_precedence_list might in fact be Class::MOP
245 next unless $meta && $meta->can('roles');
246 foreach my $role (@{$meta->roles}) {
247 return 1 if $role->excludes_role($role_name);
255 my $params = @_ == 1 ? $_[0] : {@_};
256 my $object = $self->SUPER::new_object($params);
258 foreach my $attr ( $self->get_all_attributes() ) {
260 next unless $attr->can('has_trigger') && $attr->has_trigger;
262 my $init_arg = $attr->init_arg;
264 next unless defined $init_arg;
266 next unless exists $params->{$init_arg};
272 ? $attr->get_read_method_ref->($object)
273 : $params->{$init_arg}
278 $object->BUILDALL($params) if $object->can('BUILDALL');
285 my $supers = Data::OptList::mkopt(\@_);
286 foreach my $super (@{ $supers }) {
287 my ($name, $opts) = @{ $super };
288 Class::MOP::load_class($name, $opts);
289 my $meta = Class::MOP::class_of($name);
290 $self->throw_error("You cannot inherit from a Moose Role ($name)")
291 if $meta && $meta->isa('Moose::Meta::Role')
293 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
296 ### ---------------------------------------------
301 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
303 : $self->_process_attribute(@_));
304 $self->SUPER::add_attribute($attr);
305 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
306 # 'bare' and doesn't implement this method
307 if ($attr->can('_check_associated_methods')) {
308 $attr->_check_associated_methods;
313 sub add_override_method_modifier {
314 my ($self, $name, $method, $_super_package) = @_;
316 (!$self->has_method($name))
317 || $self->throw_error("Cannot add an override method if a local method is already present");
319 $self->add_method($name => Moose::Meta::Method::Overridden->new(
322 package => $_super_package, # need this for roles
327 sub add_augment_method_modifier {
328 my ($self, $name, $method) = @_;
329 (!$self->has_method($name))
330 || $self->throw_error("Cannot add an augment method if a local method is already present");
332 $self->add_method($name => Moose::Meta::Method::Augmented->new(
339 ## Private Utility methods ...
341 sub _find_next_method_by_name_which_is_not_overridden {
342 my ($self, $name) = @_;
343 foreach my $method ($self->find_all_methods_by_name($name)) {
344 return $method->{code}
345 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
350 ## Metaclass compatibility
352 sub _base_metaclasses {
354 my %metaclasses = $self->SUPER::_base_metaclasses;
355 for my $class (keys %metaclasses) {
356 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
360 error_class => 'Moose::Error::Default',
364 sub _find_common_base {
366 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
367 return unless defined($meta1) && defined($meta2);
369 # FIXME? This doesn't account for multiple inheritance (not sure
370 # if it needs to though). For example, if somewhere in $meta1's
371 # history it inherits from both ClassA and ClassB, and $meta2
372 # inherits from ClassB & ClassA, does it matter? And what crazy
373 # fool would do that anyway?
375 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
377 return first { $meta1_parents{$_} } $meta2->linearized_isa;
380 sub _get_ancestors_until {
382 my ($start_name, $until_name) = @_;
385 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
386 last if $ancestor_name eq $until_name;
387 push @ancestor_names, $ancestor_name;
389 return @ancestor_names;
392 sub _is_role_only_subclass {
394 my ($meta_name) = @_;
395 my $meta = Class::MOP::Class->initialize($meta_name);
396 my @parent_names = $meta->superclasses;
398 # XXX: don't feel like messing with multiple inheritance here... what would
400 return unless @parent_names == 1;
401 my ($parent_name) = @parent_names;
402 my $parent_meta = Class::MOP::Class->initialize($parent_name);
404 # loop over all methods that are a part of the current class
406 for my $method (map { $meta->get_method($_) } $meta->get_method_list) {
408 next if $method->name eq 'meta';
409 # we'll deal with attributes below
410 next if $method->isa('Class::MOP::Method::Accessor');
411 # if the method comes from a role we consumed, ignore it
412 next if $meta->can('does_role')
413 && $meta->does_role($method->original_package_name);
418 # loop over all attributes that are a part of the current class
420 # FIXME - this really isn't right. Just because an attribute is
421 # defined in a role doesn't mean it isn't _also_ defined in the
423 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
424 next if any { $_->has_attribute($attr->name) }
425 $meta->calculate_all_roles_with_inheritance;
433 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
435 my ($super_meta) = @_;
437 my $super_meta_name = $super_meta->_real_ref_name;
438 my $common_base_name = $self->_find_common_base(blessed($self), $super_meta_name);
439 # if they're not both moose metaclasses, and the cmop fixing couldn't
440 # do anything, there's nothing more we can do
441 return unless defined($common_base_name);
442 return unless $common_base_name->isa('Moose::Meta::Class');
444 my @super_meta_name_ancestor_names = $self->_get_ancestors_until($super_meta_name, $common_base_name);
445 my @class_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($self), $common_base_name);
446 # we're only dealing with roles here
447 return unless all { $self->_is_role_only_subclass($_) }
448 (@super_meta_name_ancestor_names,
449 @class_meta_name_ancestor_names);
454 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
456 my ($metaclass_type, $super_meta) = @_;
458 my $class_specific_meta_name = $self->$metaclass_type;
459 return unless $super_meta->can($metaclass_type);
460 my $super_specific_meta_name = $super_meta->$metaclass_type;
461 my %metaclasses = $self->_base_metaclasses;
463 my $common_base_name = $self->_find_common_base($class_specific_meta_name, $super_specific_meta_name);
464 # if they're not both moose metaclasses, and the cmop fixing couldn't
465 # do anything, there's nothing more we can do
466 return unless defined($common_base_name);
467 return unless $common_base_name->isa($metaclasses{$metaclass_type});
469 my @super_specific_meta_name_ancestor_names = $self->_get_ancestors_until($super_specific_meta_name, $common_base_name);
470 my @class_specific_meta_name_ancestor_names = $self->_get_ancestors_until($class_specific_meta_name, $common_base_name);
471 # we're only dealing with roles here
472 return unless all { $self->_is_role_only_subclass($_) }
473 (@super_specific_meta_name_ancestor_names,
474 @class_specific_meta_name_ancestor_names);
479 sub _role_differences {
481 my ($class_meta_name, $super_meta_name) = @_;
482 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
483 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
485 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
486 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
489 for my $role_meta (@role_metas) {
490 push @differences, $role_meta
491 unless any { $_->name eq $role_meta->name } @super_role_metas;
496 sub _reconcile_roles_for_metaclass {
498 my ($class_meta_name, $super_meta_name) = @_;
500 my @role_differences = $self->_role_differences(
501 $class_meta_name, $super_meta_name,
503 return Moose::Meta::Class->create_anon_class(
504 superclasses => [$super_meta_name],
505 roles => \@role_differences,
510 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
512 my ($super_meta) = @_;
514 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
516 my %base_metaclass = $self->_base_metaclasses;
517 for my $metaclass_type (keys %base_metaclass) {
518 next unless defined $self->$metaclass_type;
519 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
525 sub _can_fix_metaclass_incompatibility {
527 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
528 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
531 sub _fix_class_metaclass_incompatibility {
533 my ($super_meta) = @_;
535 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
537 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
539 || confess "Can't fix metaclass incompatibility for "
541 . " because it is not pristine.";
542 my $super_meta_name = $super_meta->_real_ref_name;
543 my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
544 my $new_self = $class_meta_subclass_meta->name->reinitialize(
548 bless $self, $class_meta_subclass_meta->name;
549 # We need to replace the cached metaclass instance or else when it
550 # goes out of scope Class::MOP::Class destroy's the namespace for
551 # the metaclass's class, causing much havoc.
552 Class::MOP::store_metaclass_by_name( $self->name, $self );
553 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
557 sub _fix_single_metaclass_incompatibility {
559 my ($metaclass_type, $super_meta) = @_;
561 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
563 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
565 || confess "Can't fix metaclass incompatibility for "
567 . " because it is not pristine.";
568 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
569 my $new_self = $super_meta->reinitialize(
571 $metaclass_type => $class_specific_meta_subclass_meta->name,
574 bless $self, blessed($super_meta);
575 # We need to replace the cached metaclass instance or else when it
576 # goes out of scope Class::MOP::Class destroy's the namespace for
577 # the metaclass's class, causing much havoc.
578 Class::MOP::store_metaclass_by_name( $self->name, $self );
579 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
583 sub _process_attribute {
584 my ( $self, $name, @args ) = @_;
586 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
588 if (($name || '') =~ /^\+(.*)/) {
589 return $self->_process_inherited_attribute($1, @args);
592 return $self->_process_new_attribute($name, @args);
596 sub _process_new_attribute {
597 my ( $self, $name, @args ) = @_;
599 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
602 sub _process_inherited_attribute {
603 my ($self, $attr_name, %options) = @_;
604 my $inherited_attr = $self->find_attribute_by_name($attr_name);
605 (defined $inherited_attr)
606 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
607 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
608 return $inherited_attr->clone_and_inherit_options(%options);
612 # kind of a kludge to handle Class::MOP::Attributes
613 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
617 ## -------------------------------------------------
622 my ( $self, @args ) = @_;
623 local $error_level = ($error_level || 0) + 1;
624 $self->raise_error($self->create_error(@args));
628 my ( $self, @args ) = @_;
633 my ( $self, @args ) = @_;
637 local $error_level = ($error_level || 0 ) + 1;
639 if ( @args % 2 == 1 ) {
640 unshift @args, "message";
643 my %args = ( metaclass => $self, last_error => $@, @args );
645 $args{depth} += $error_level;
647 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
649 Class::MOP::load_class($class);
652 Carp::caller_info($args{depth}),
665 Moose::Meta::Class - The Moose metaclass
669 This class is a subclass of L<Class::MOP::Class> that provides
670 additional Moose-specific functionality.
672 To really understand this class, you will need to start with the
673 L<Class::MOP::Class> documentation. This class can be understood as a
674 set of additional features on top of the basic feature provided by
679 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
685 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
687 This overrides the parent's method in order to provide its own
688 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
689 C<method_metaclass> options.
691 These all default to the appropriate Moose class.
693 =item B<< Moose::Meta::Class->create($package_name, %options) >>
695 This overrides the parent's method in order to accept a C<roles>
696 option. This should be an array reference containing roles
697 that the class does, each optionally followed by a hashref of options
698 (C<-excludes> and C<-alias>).
700 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
702 =item B<< Moose::Meta::Class->create_anon_class >>
704 This overrides the parent's method to accept a C<roles> option, just
707 It also accepts a C<cache> option. If this is true, then the anonymous
708 class will be cached based on its superclasses and roles. If an
709 existing anonymous class in the cache has the same superclasses and
710 roles, it will be reused.
712 my $metaclass = Moose::Meta::Class->create_anon_class(
713 superclasses => ['Foo'],
714 roles => [qw/Some Roles Go Here/],
718 Each entry in both the C<superclasses> and the C<roles> option can be
719 followed by a hash reference with arguments. The C<superclasses>
720 option can be supplied with a L<-version|Class::MOP/Class Loading
721 Options> option that ensures the loaded superclass satisfies the
722 required version. The C<role> option also takes the C<-version> as an
723 argument, but the option hash reference can also contain any other
724 role relevant values like exclusions or parameterized role arguments.
726 =item B<< $metaclass->make_immutable(%options) >>
728 This overrides the parent's method to add a few options. Specifically,
729 it uses the Moose-specific constructor and destructor classes, and
730 enables inlining the destructor.
732 Also, since Moose always inlines attributes, it sets the
733 C<inline_accessors> option to false.
735 =item B<< $metaclass->new_object(%params) >>
737 This overrides the parent's method in order to add support for
740 =item B<< $metaclass->superclasses(@superclasses) >>
742 This is the accessor allowing you to read or change the parents of
745 Each superclass can be followed by a hash reference containing a
746 L<-version|Class::MOP/Class Loading Options> value. If the version
747 requirement is not satisfied an error will be thrown.
749 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
751 This adds an C<override> method modifier to the package.
753 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
755 This adds an C<augment> method modifier to the package.
757 =item B<< $metaclass->calculate_all_roles >>
759 This will return a unique array of C<Moose::Meta::Role> instances
760 which are attached to this class.
762 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
764 This will return a unique array of C<Moose::Meta::Role> instances
765 which are attached to this class, and each of this class's ancestors.
767 =item B<< $metaclass->add_role($role) >>
769 This takes a L<Moose::Meta::Role> object, and adds it to the class's
770 list of roles. This I<does not> actually apply the role to the class.
772 =item B<< $metaclass->role_applications >>
774 Returns a list of L<Moose::Meta::Role::Application::ToClass>
775 objects, which contain the arguments to role application.
777 =item B<< $metaclass->add_role_application($application) >>
779 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
780 adds it to the class's list of role applications. This I<does not>
781 actually apply any role to the class; it is only for tracking role
784 =item B<< $metaclass->does_role($role) >>
786 This returns a boolean indicating whether or not the class does the specified
787 role. The role provided can be either a role name or a L<Moose::Meta::Role>
788 object. This tests both the class and its parents.
790 =item B<< $metaclass->excludes_role($role_name) >>
792 A class excludes a role if it has already composed a role which
793 excludes the named role. This tests both the class and its parents.
795 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
797 This overrides the parent's method in order to allow the parameters to
798 be provided as a hash reference.
800 =item B<< $metaclass->constructor_class($class_name) >>
802 =item B<< $metaclass->destructor_class($class_name) >>
804 These are the names of classes used when making a class
805 immutable. These default to L<Moose::Meta::Method::Constructor> and
806 L<Moose::Meta::Method::Destructor> respectively. These accessors are
807 read-write, so you can use them to change the class name.
809 =item B<< $metaclass->error_class($class_name) >>
811 The name of the class used to throw errors. This defaults to
812 L<Moose::Error::Default>, which generates an error with a stacktrace
813 just like C<Carp::confess>.
815 =item B<< $metaclass->throw_error($message, %extra) >>
817 Throws the error created by C<create_error> using C<raise_error>
823 See L<Moose/BUGS> for details on reporting bugs.
827 Stevan Little E<lt>stevan@iinteractive.comE<gt>
829 =head1 COPYRIGHT AND LICENSE
831 Copyright 2006-2010 by Infinity Interactive, Inc.
833 L<http://www.iinteractive.com>
835 This library is free software; you can redistribute it and/or modify
836 it under the same terms as Perl itself.