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, is 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 %metaclasses = $self->_base_metaclasses;
569 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
570 my $new_self = $super_meta->reinitialize(
572 $metaclass_type => $class_specific_meta_subclass_meta->name,
575 bless $self, blessed($super_meta);
576 # We need to replace the cached metaclass instance or else when it
577 # goes out of scope Class::MOP::Class destroy's the namespace for
578 # the metaclass's class, causing much havoc.
579 Class::MOP::store_metaclass_by_name( $self->name, $self );
580 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
584 sub _process_attribute {
585 my ( $self, $name, @args ) = @_;
587 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
589 if (($name || '') =~ /^\+(.*)/) {
590 return $self->_process_inherited_attribute($1, @args);
593 return $self->_process_new_attribute($name, @args);
597 sub _process_new_attribute {
598 my ( $self, $name, @args ) = @_;
600 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
603 sub _process_inherited_attribute {
604 my ($self, $attr_name, %options) = @_;
605 my $inherited_attr = $self->find_attribute_by_name($attr_name);
606 (defined $inherited_attr)
607 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
608 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
609 return $inherited_attr->clone_and_inherit_options(%options);
613 # kind of a kludge to handle Class::MOP::Attributes
614 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
618 ## -------------------------------------------------
623 my ( $self, @args ) = @_;
624 local $error_level = ($error_level || 0) + 1;
625 $self->raise_error($self->create_error(@args));
629 my ( $self, @args ) = @_;
634 my ( $self, @args ) = @_;
638 local $error_level = ($error_level || 0 ) + 1;
640 if ( @args % 2 == 1 ) {
641 unshift @args, "message";
644 my %args = ( metaclass => $self, last_error => $@, @args );
646 $args{depth} += $error_level;
648 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
650 Class::MOP::load_class($class);
653 Carp::caller_info($args{depth}),
666 Moose::Meta::Class - The Moose metaclass
670 This class is a subclass of L<Class::MOP::Class> that provides
671 additional Moose-specific functionality.
673 To really understand this class, you will need to start with the
674 L<Class::MOP::Class> documentation. This class can be understood as a
675 set of additional features on top of the basic feature provided by
680 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
686 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
688 This overrides the parent's method in order to provide its own
689 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
690 C<method_metaclass> options.
692 These all default to the appropriate Moose class.
694 =item B<< Moose::Meta::Class->create($package_name, %options) >>
696 This overrides the parent's method in order to accept a C<roles>
697 option. This should be an array reference containing roles
698 that the class does, each optionally followed by a hashref of options
699 (C<-excludes> and C<-alias>).
701 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
703 =item B<< Moose::Meta::Class->create_anon_class >>
705 This overrides the parent's method to accept a C<roles> option, just
708 It also accepts a C<cache> option. If this is true, then the anonymous
709 class will be cached based on its superclasses and roles. If an
710 existing anonymous class in the cache has the same superclasses and
711 roles, it will be reused.
713 my $metaclass = Moose::Meta::Class->create_anon_class(
714 superclasses => ['Foo'],
715 roles => [qw/Some Roles Go Here/],
719 Each entry in both the C<superclasses> and the C<roles> option can be
720 followed by a hash reference with arguments. The C<superclasses>
721 option can be supplied with a L<-version|Class::MOP/Class Loading
722 Options> option that ensures the loaded superclass satisfies the
723 required version. The C<role> option also takes the C<-version> as an
724 argument, but the option hash reference can also contain any other
725 role relevant values like exclusions or parameterized role arguments.
727 =item B<< $metaclass->make_immutable(%options) >>
729 This overrides the parent's method to add a few options. Specifically,
730 it uses the Moose-specific constructor and destructor classes, and
731 enables inlining the destructor.
733 Also, since Moose always inlines attributes, it sets the
734 C<inline_accessors> option to false.
736 =item B<< $metaclass->new_object(%params) >>
738 This overrides the parent's method in order to add support for
741 =item B<< $metaclass->superclasses(@superclasses) >>
743 This is the accessor allowing you to read or change the parents of
746 Each superclass can be followed by a hash reference containing a
747 L<-version|Class::MOP/Class Loading Options> value. If the version
748 requirement is not satisfied an error will be thrown.
750 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
752 This adds an C<override> method modifier to the package.
754 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
756 This adds an C<augment> method modifier to the package.
758 =item B<< $metaclass->calculate_all_roles >>
760 This will return a unique array of C<Moose::Meta::Role> instances
761 which are attached to this class.
763 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
765 This will return a unique array of C<Moose::Meta::Role> instances
766 which are attached to this class, and each of this class's ancestors.
768 =item B<< $metaclass->add_role($role) >>
770 This takes a L<Moose::Meta::Role> object, and adds it to the class's
771 list of roles. This I<does not> actually apply the role to the class.
773 =item B<< $metaclass->role_applications >>
775 Returns a list of L<Moose::Meta::Role::Application::ToClass>
776 objects, which contain the arguments to role application.
778 =item B<< $metaclass->add_role_application($application) >>
780 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
781 adds it to the class's list of role applications. This I<does not>
782 actually apply any role to the class; it is only for tracking role
785 =item B<< $metaclass->does_role($role) >>
787 This returns a boolean indicating whether or not the class does the specified
788 role. The role provided can be either a role name or a L<Moose::Meta::Role>
789 object. This tests both the class and its parents.
791 =item B<< $metaclass->excludes_role($role_name) >>
793 A class excludes a role if it has already composed a role which
794 excludes the named role. This tests both the class and its parents.
796 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
798 This overrides the parent's method in order to allow the parameters to
799 be provided as a hash reference.
801 =item B<< $metaclass->constructor_class($class_name) >>
803 =item B<< $metaclass->destructor_class($class_name) >>
805 These are the names of classes used when making a class
806 immutable. These default to L<Moose::Meta::Method::Constructor> and
807 L<Moose::Meta::Method::Destructor> respectively. These accessors are
808 read-write, so you can use them to change the class name.
810 =item B<< $metaclass->error_class($class_name) >>
812 The name of the class used to throw errors. This defaults to
813 L<Moose::Error::Default>, which generates an error with a stacktrace
814 just like C<Carp::confess>.
816 =item B<< $metaclass->throw_error($message, %extra) >>
818 Throws the error created by C<create_error> using C<raise_error>
824 See L<Moose/BUGS> for details on reporting bugs.
828 Stevan Little E<lt>stevan@iinteractive.comE<gt>
830 =head1 COPYRIGHT AND LICENSE
832 Copyright 2006-2010 by Infinity Interactive, Inc.
834 L<http://www.iinteractive.com>
836 This library is free software; you can redistribute it and/or modify
837 it under the same terms as Perl itself.