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.12';
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;
25 use Moose::Meta::Method::Does;
27 use base 'Class::MOP::Class';
29 __PACKAGE__->meta->add_attribute('roles' => (
34 __PACKAGE__->meta->add_attribute('role_applications' => (
35 reader => '_get_role_applications',
39 __PACKAGE__->meta->add_attribute(
40 Class::MOP::Attribute->new('immutable_trait' => (
41 accessor => "immutable_trait",
42 default => 'Moose::Meta::Class::Immutable::Trait',
46 __PACKAGE__->meta->add_attribute('constructor_class' => (
47 accessor => 'constructor_class',
48 default => 'Moose::Meta::Method::Constructor',
51 __PACKAGE__->meta->add_attribute('destructor_class' => (
52 accessor => 'destructor_class',
53 default => 'Moose::Meta::Method::Destructor',
56 __PACKAGE__->meta->add_attribute('does_class' => (
57 accessor => 'does_class',
58 default => 'Moose::Meta::Method::Does',
61 __PACKAGE__->meta->add_attribute('error_class' => (
62 accessor => 'error_class',
63 default => 'Moose::Error::Default',
69 return Class::MOP::get_metaclass_by_name($pkg)
70 || $class->SUPER::initialize($pkg,
71 'attribute_metaclass' => 'Moose::Meta::Attribute',
72 'method_metaclass' => 'Moose::Meta::Method',
73 'instance_metaclass' => 'Moose::Meta::Instance',
79 my ($class, $package_name, %options) = @_;
81 (ref $options{roles} eq 'ARRAY')
82 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
83 if exists $options{roles};
84 my $roles = delete $options{roles};
86 my $new_meta = $class->SUPER::create($package_name, %options);
89 Moose::Util::apply_all_roles( $new_meta, @$roles );
97 sub create_anon_class {
98 my ($self, %options) = @_;
100 my $cache_ok = delete $options{cache};
103 = _anon_cache_key( $options{superclasses}, $options{roles} );
105 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
106 return $ANON_CLASSES{$cache_key};
109 my $new_class = $self->SUPER::create_anon_class(%options);
111 $ANON_CLASSES{$cache_key} = $new_class
117 sub _anon_cache_key {
118 # Makes something like Super::Class|Super::Class::2=Role|Role::1
120 join( '|', @{ $_[0] || [] } ),
121 join( '|', sort @{ $_[1] || [] } ),
129 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
133 my %existing_classes;
135 %existing_classes = map { $_ => $meta->$_() } qw(
138 wrapped_method_metaclass
146 $cache_key = _anon_cache_key(
147 [ $meta->superclasses ],
148 [ map { $_->name } @{ $meta->roles } ],
149 ) if $meta->is_anon_class;
152 my $new_meta = $self->SUPER::reinitialize(
158 return $new_meta unless defined $cache_key;
160 my $new_cache_key = _anon_cache_key(
161 [ $meta->superclasses ],
162 [ map { $_->name } @{ $meta->roles } ],
165 delete $ANON_CLASSES{$cache_key};
166 $ANON_CLASSES{$new_cache_key} = $new_meta;
172 my ($self, $role) = @_;
173 (blessed($role) && $role->isa('Moose::Meta::Role'))
174 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
175 push @{$self->roles} => $role;
178 sub role_applications {
181 return @{$self->_get_role_applications};
184 sub add_role_application {
185 my ($self, $application) = @_;
186 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
187 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
188 push @{$self->_get_role_applications} => $application;
191 sub calculate_all_roles {
194 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
197 sub calculate_all_roles_with_inheritance {
200 grep { !$seen{$_->name}++ }
201 map { Class::MOP::class_of($_)->can('calculate_all_roles')
202 ? Class::MOP::class_of($_)->calculate_all_roles
204 $self->linearized_isa;
208 my ($self, $role_name) = @_;
211 || $self->throw_error("You must supply a role name to look for");
213 foreach my $class ($self->class_precedence_list) {
214 my $meta = Class::MOP::class_of($class);
215 # when a Moose metaclass is itself extended with a role,
216 # this check needs to be done since some items in the
217 # class_precedence_list might in fact be Class::MOP
219 next unless $meta && $meta->can('roles');
220 foreach my $role (@{$meta->roles}) {
221 return 1 if $role->does_role($role_name);
228 my ($self, $role_name) = @_;
231 || $self->throw_error("You must supply a role name to look for");
233 foreach my $class ($self->class_precedence_list) {
234 my $meta = Class::MOP::class_of($class);
235 # when a Moose metaclass is itself extended with a role,
236 # this check needs to be done since some items in the
237 # class_precedence_list might in fact be Class::MOP
239 next unless $meta && $meta->can('roles');
240 foreach my $role (@{$meta->roles}) {
241 return 1 if $role->excludes_role($role_name);
249 my $params = @_ == 1 ? $_[0] : {@_};
250 my $object = $self->SUPER::new_object($params);
252 foreach my $attr ( $self->get_all_attributes() ) {
254 next unless $attr->can('has_trigger') && $attr->has_trigger;
256 my $init_arg = $attr->init_arg;
258 next unless defined $init_arg;
260 next unless exists $params->{$init_arg};
266 ? $attr->get_read_method_ref->($object)
267 : $params->{$init_arg}
272 $object->BUILDALL($params) if $object->can('BUILDALL');
279 my $supers = Data::OptList::mkopt(\@_);
280 foreach my $super (@{ $supers }) {
281 my ($name, $opts) = @{ $super };
282 Class::MOP::load_class($name, $opts);
283 my $meta = Class::MOP::class_of($name);
284 $self->throw_error("You cannot inherit from a Moose Role ($name)")
285 if $meta && $meta->isa('Moose::Meta::Role')
287 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
290 ### ---------------------------------------------
295 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
297 : $self->_process_attribute(@_));
298 $self->SUPER::add_attribute($attr);
299 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
300 # 'bare' and doesn't implement this method
301 if ($attr->can('_check_associated_methods')) {
302 $attr->_check_associated_methods;
307 sub add_override_method_modifier {
308 my ($self, $name, $method, $_super_package) = @_;
310 (!$self->has_method($name))
311 || $self->throw_error("Cannot add an override method if a local method is already present");
313 $self->add_method($name => Moose::Meta::Method::Overridden->new(
316 package => $_super_package, # need this for roles
321 sub add_augment_method_modifier {
322 my ($self, $name, $method) = @_;
323 (!$self->has_method($name))
324 || $self->throw_error("Cannot add an augment method if a local method is already present");
326 $self->add_method($name => Moose::Meta::Method::Augmented->new(
333 ## Private Utility methods ...
335 sub _find_next_method_by_name_which_is_not_overridden {
336 my ($self, $name) = @_;
337 foreach my $method ($self->find_all_methods_by_name($name)) {
338 return $method->{code}
339 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
344 ## Metaclass compatibility
346 sub _base_metaclasses {
348 my %metaclasses = $self->SUPER::_base_metaclasses;
349 for my $class (keys %metaclasses) {
350 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
354 error_class => 'Moose::Error::Default',
358 sub _find_common_base {
360 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
361 return unless defined $meta1 && defined $meta2;
363 # FIXME? This doesn't account for multiple inheritance (not sure
364 # if it needs to though). For example, if somewhere in $meta1's
365 # history it inherits from both ClassA and ClassB, and $meta2
366 # inherits from ClassB & ClassA, does it matter? And what crazy
367 # fool would do that anyway?
369 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
371 return first { $meta1_parents{$_} } $meta2->linearized_isa;
374 sub _get_ancestors_until {
376 my ($start_name, $until_name) = @_;
379 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
380 last if $ancestor_name eq $until_name;
381 push @ancestor_names, $ancestor_name;
383 return @ancestor_names;
386 sub _is_role_only_subclass {
388 my ($meta_name) = @_;
389 my $meta = Class::MOP::Class->initialize($meta_name);
390 my @parent_names = $meta->superclasses;
392 # XXX: don't feel like messing with multiple inheritance here... what would
394 return unless @parent_names == 1;
395 my ($parent_name) = @parent_names;
396 my $parent_meta = Class::MOP::Class->initialize($parent_name);
398 my @roles = $meta->can('calculate_all_roles_with_inheritance')
399 ? $meta->calculate_all_roles_with_inheritance
402 # loop over all methods that are a part of the current class
404 for my $method ( $meta->_get_local_methods ) {
406 next if $method->name eq 'meta';
407 # we'll deal with attributes below
408 next if $method->can('associated_attribute');
409 # if the method comes from a role we consumed, ignore it
410 next if $meta->can('does_role')
411 && $meta->does_role($method->original_package_name);
412 # FIXME - this really isn't right. Just because a modifier is
413 # defined in a role doesn't mean it isn't _also_ defined in the
415 next if $method->isa('Class::MOP::Method::Wrapped')
417 (!scalar($method->around_modifiers)
418 || any { $_->has_around_method_modifiers($method->name) } @roles)
419 && (!scalar($method->before_modifiers)
420 || any { $_->has_before_method_modifiers($method->name) } @roles)
421 && (!scalar($method->after_modifiers)
422 || any { $_->has_after_method_modifiers($method->name) } @roles)
428 # loop over all attributes that are a part of the current class
430 # FIXME - this really isn't right. Just because an attribute is
431 # defined in a role doesn't mean it isn't _also_ defined in the
433 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
434 next if any { $_->has_attribute($attr->name) } @roles;
442 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
444 my ($super_meta) = @_;
446 my $super_meta_name = $super_meta->_real_ref_name;
448 return $self->_classes_differ_by_roles_only(
451 'Moose::Meta::Class',
455 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
457 my ($metaclass_type, $super_meta) = @_;
459 my $class_specific_meta_name = $self->$metaclass_type;
460 return unless $super_meta->can($metaclass_type);
461 my $super_specific_meta_name = $super_meta->$metaclass_type;
462 my %metaclasses = $self->_base_metaclasses;
464 return $self->_classes_differ_by_roles_only(
465 $class_specific_meta_name,
466 $super_specific_meta_name,
467 $metaclasses{$metaclass_type},
471 sub _classes_differ_by_roles_only {
473 my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
476 = $self->_find_common_base( $self_meta_name, $super_meta_name );
478 # If they're not both moose metaclasses, and the cmop fixing couldn't do
479 # anything, there's nothing more we can do. The $expected_ancestor should
480 # always be a Moose metaclass name like Moose::Meta::Class or
481 # Moose::Meta::Attribute.
482 return unless defined $common_base_name;
483 return unless $common_base_name->isa($expected_ancestor);
485 my @super_meta_name_ancestor_names
486 = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
487 my @class_meta_name_ancestor_names
488 = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
491 unless all { $self->_is_role_only_subclass($_) }
492 @super_meta_name_ancestor_names,
493 @class_meta_name_ancestor_names;
498 sub _role_differences {
500 my ($class_meta_name, $super_meta_name) = @_;
501 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
502 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
504 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
505 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
508 for my $role_meta (@role_metas) {
509 push @differences, $role_meta
510 unless any { $_->name eq $role_meta->name } @super_role_metas;
515 sub _reconcile_roles_for_metaclass {
517 my ($class_meta_name, $super_meta_name) = @_;
519 my @role_differences = $self->_role_differences(
520 $class_meta_name, $super_meta_name,
523 # handle the case where we need to fix compatibility between a class and
524 # its parent, but all roles in the class are already also done by the
527 return Class::MOP::class_of($super_meta_name)
528 unless @role_differences;
530 return Moose::Meta::Class->create_anon_class(
531 superclasses => [$super_meta_name],
532 roles => \@role_differences,
537 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
539 my ($super_meta) = @_;
541 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
543 my %base_metaclass = $self->_base_metaclasses;
544 for my $metaclass_type (keys %base_metaclass) {
545 next unless defined $self->$metaclass_type;
546 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
552 sub _can_fix_metaclass_incompatibility {
554 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
555 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
558 sub _fix_class_metaclass_incompatibility {
560 my ($super_meta) = @_;
562 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
564 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
566 || confess "Can't fix metaclass incompatibility for "
568 . " because it is not pristine.";
569 my $super_meta_name = $super_meta->_real_ref_name;
570 my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
571 my $new_self = $class_meta_subclass_meta->name->reinitialize(
575 $self->_replace_self( $new_self, $class_meta_subclass_meta->name );
579 sub _fix_single_metaclass_incompatibility {
581 my ($metaclass_type, $super_meta) = @_;
583 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
585 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
587 || confess "Can't fix metaclass incompatibility for "
589 . " because it is not pristine.";
590 my $super_meta_name = $super_meta->_real_ref_name;
591 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
592 my $new_self = $super_meta->reinitialize(
594 $metaclass_type => $class_specific_meta_subclass_meta->name,
597 $self->_replace_self( $new_self, $super_meta_name );
604 my ( $new_self, $new_class) = @_;
607 bless $self, $new_class;
609 # We need to replace the cached metaclass instance or else when it goes
610 # out of scope Class::MOP::Class destroy's the namespace for the
611 # metaclass's class, causing much havoc.
612 Class::MOP::store_metaclass_by_name( $self->name, $self );
613 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
616 sub _process_attribute {
617 my ( $self, $name, @args ) = @_;
619 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
621 if (($name || '') =~ /^\+(.*)/) {
622 return $self->_process_inherited_attribute($1, @args);
625 return $self->_process_new_attribute($name, @args);
629 sub _process_new_attribute {
630 my ( $self, $name, @args ) = @_;
632 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
635 sub _process_inherited_attribute {
636 my ($self, $attr_name, %options) = @_;
637 my $inherited_attr = $self->find_attribute_by_name($attr_name);
638 (defined $inherited_attr)
639 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
640 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
641 return $inherited_attr->clone_and_inherit_options(%options);
645 # kind of a kludge to handle Class::MOP::Attributes
646 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
652 sub _immutable_options {
653 my ( $self, @args ) = @_;
655 $self->SUPER::_immutable_options(
656 inline_destructor => 1,
659 # Moose always does this when an attribute is created
660 inline_accessors => 0,
666 sub _install_inlined_code {
667 my ( $self, %args ) = @_;
669 $self->SUPER::_install_inlined_code(%args);
671 $self->_inline_does(%args) if $args{inline_does};
675 my ( $self, %args ) = @_;
677 if ( $self->has_method('does') ) {
678 my $class = $self->name;
679 warn "Not inlining a does method for $class since it defines"
680 . " its own does().\n";
684 my $does = $self->does_class->new(
688 package_name => $self->name,
691 return unless $does->can_be_inlined;
693 $self->add_method( 'does' => $does );
694 $self->_add_inlined_method($does);
697 ## -------------------------------------------------
702 my ( $self, @args ) = @_;
703 local $error_level = ($error_level || 0) + 1;
704 $self->raise_error($self->create_error(@args));
708 my ( $self, @args ) = @_;
713 my ( $self, @args ) = @_;
717 local $error_level = ($error_level || 0 ) + 1;
719 if ( @args % 2 == 1 ) {
720 unshift @args, "message";
723 my %args = ( metaclass => $self, last_error => $@, @args );
725 $args{depth} += $error_level;
727 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
729 Class::MOP::load_class($class);
732 Carp::caller_info($args{depth}),
745 Moose::Meta::Class - The Moose metaclass
749 This class is a subclass of L<Class::MOP::Class> that provides
750 additional Moose-specific functionality.
752 To really understand this class, you will need to start with the
753 L<Class::MOP::Class> documentation. This class can be understood as a
754 set of additional features on top of the basic feature provided by
759 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
765 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
767 This overrides the parent's method in order to provide its own
768 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
769 C<method_metaclass> options.
771 These all default to the appropriate Moose class.
773 =item B<< Moose::Meta::Class->create($package_name, %options) >>
775 This overrides the parent's method in order to accept a C<roles>
776 option. This should be an array reference containing roles
777 that the class does, each optionally followed by a hashref of options
778 (C<-excludes> and C<-alias>).
780 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
782 =item B<< Moose::Meta::Class->create_anon_class >>
784 This overrides the parent's method to accept a C<roles> option, just
787 It also accepts a C<cache> option. If this is true, then the anonymous
788 class will be cached based on its superclasses and roles. If an
789 existing anonymous class in the cache has the same superclasses and
790 roles, it will be reused.
792 my $metaclass = Moose::Meta::Class->create_anon_class(
793 superclasses => ['Foo'],
794 roles => [qw/Some Roles Go Here/],
798 Each entry in both the C<superclasses> and the C<roles> option can be
799 followed by a hash reference with arguments. The C<superclasses>
800 option can be supplied with a L<-version|Class::MOP/Class Loading
801 Options> option that ensures the loaded superclass satisfies the
802 required version. The C<role> option also takes the C<-version> as an
803 argument, but the option hash reference can also contain any other
804 role relevant values like exclusions or parameterized role arguments.
806 =item B<< $metaclass->make_immutable(%options) >>
808 This overrides the parent's method to add a few options. Specifically,
809 it uses the Moose-specific constructor and destructor classes, and
810 enables inlining the destructor.
812 Also, since Moose always inlines attributes, it sets the
813 C<inline_accessors> option to false.
815 =item B<< $metaclass->new_object(%params) >>
817 This overrides the parent's method in order to add support for
820 =item B<< $metaclass->superclasses(@superclasses) >>
822 This is the accessor allowing you to read or change the parents of
825 Each superclass can be followed by a hash reference containing a
826 L<-version|Class::MOP/Class Loading Options> value. If the version
827 requirement is not satisfied an error will be thrown.
829 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
831 This adds an C<override> method modifier to the package.
833 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
835 This adds an C<augment> method modifier to the package.
837 =item B<< $metaclass->calculate_all_roles >>
839 This will return a unique array of C<Moose::Meta::Role> instances
840 which are attached to this class.
842 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
844 This will return a unique array of C<Moose::Meta::Role> instances
845 which are attached to this class, and each of this class's ancestors.
847 =item B<< $metaclass->add_role($role) >>
849 This takes a L<Moose::Meta::Role> object, and adds it to the class's
850 list of roles. This I<does not> actually apply the role to the class.
852 =item B<< $metaclass->role_applications >>
854 Returns a list of L<Moose::Meta::Role::Application::ToClass>
855 objects, which contain the arguments to role application.
857 =item B<< $metaclass->add_role_application($application) >>
859 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
860 adds it to the class's list of role applications. This I<does not>
861 actually apply any role to the class; it is only for tracking role
864 =item B<< $metaclass->does_role($role) >>
866 This returns a boolean indicating whether or not the class does the specified
867 role. The role provided can be either a role name or a L<Moose::Meta::Role>
868 object. This tests both the class and its parents.
870 =item B<< $metaclass->excludes_role($role_name) >>
872 A class excludes a role if it has already composed a role which
873 excludes the named role. This tests both the class and its parents.
875 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
877 This overrides the parent's method in order to allow the parameters to
878 be provided as a hash reference.
880 =item B<< $metaclass->constructor_class($class_name) >>
882 =item B<< $metaclass->destructor_class($class_name) >>
884 =item B<< $metaclass->does_class($class_name) >>
886 These are the names of classes used when making a class immutable. These
887 default to L<Moose::Meta::Method::Constructor>,
888 L<Moose::Meta::Method::Destructor>, and L<Moose::Meta::Method::Does>
889 respectively. These accessors are read-write, so you can use them to change
892 =item B<< $metaclass->error_class($class_name) >>
894 The name of the class used to throw errors. This defaults to
895 L<Moose::Error::Default>, which generates an error with a stacktrace
896 just like C<Carp::confess>.
898 =item B<< $metaclass->throw_error($message, %extra) >>
900 Throws the error created by C<create_error> using C<raise_error>
906 See L<Moose/BUGS> for details on reporting bugs.
910 Stevan Little E<lt>stevan@iinteractive.comE<gt>
912 =head1 COPYRIGHT AND LICENSE
914 Copyright 2006-2010 by Infinity Interactive, Inc.
916 L<http://www.iinteractive.com>
918 This library is free software; you can redistribute it and/or modify
919 it under the same terms as Perl itself.