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.14';
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;
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('error_class' => (
57 accessor => 'error_class',
58 default => 'Moose::Error::Default',
64 return Class::MOP::get_metaclass_by_name($pkg)
65 || $class->SUPER::initialize($pkg,
66 'attribute_metaclass' => 'Moose::Meta::Attribute',
67 'method_metaclass' => 'Moose::Meta::Method',
68 'instance_metaclass' => 'Moose::Meta::Instance',
74 my ($class, $package_name, %options) = @_;
76 (ref $options{roles} eq 'ARRAY')
77 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
78 if exists $options{roles};
79 my $roles = delete $options{roles};
81 my $new_meta = $class->SUPER::create($package_name, %options);
84 Moose::Util::apply_all_roles( $new_meta, @$roles );
92 sub create_anon_class {
93 my ($self, %options) = @_;
95 my $cache_ok = delete $options{cache};
98 = _anon_cache_key( $options{superclasses}, $options{roles} );
100 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
101 return $ANON_CLASSES{$cache_key};
104 my $new_class = $self->SUPER::create_anon_class(%options);
106 $ANON_CLASSES{$cache_key} = $new_class
112 sub _anon_cache_key {
113 # Makes something like Super::Class|Super::Class::2=Role|Role::1
115 join( '|', @{ $_[0] || [] } ),
116 join( '|', sort @{ $_[1] || [] } ),
124 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
128 my %existing_classes;
130 %existing_classes = map { $_ => $meta->$_() } qw(
133 wrapped_method_metaclass
140 $cache_key = _anon_cache_key(
141 [ $meta->superclasses ],
142 [ map { $_->name } @{ $meta->roles } ],
143 ) if $meta->is_anon_class;
146 my $new_meta = $self->SUPER::reinitialize(
152 return $new_meta unless defined $cache_key;
154 my $new_cache_key = _anon_cache_key(
155 [ $meta->superclasses ],
156 [ map { $_->name } @{ $meta->roles } ],
159 delete $ANON_CLASSES{$cache_key};
160 $ANON_CLASSES{$new_cache_key} = $new_meta;
166 my ($self, $role) = @_;
167 (blessed($role) && $role->isa('Moose::Meta::Role'))
168 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
169 push @{$self->roles} => $role;
172 sub role_applications {
175 return @{$self->_get_role_applications};
178 sub add_role_application {
179 my ($self, $application) = @_;
180 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
181 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
182 push @{$self->_get_role_applications} => $application;
185 sub calculate_all_roles {
188 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
191 sub calculate_all_roles_with_inheritance {
194 grep { !$seen{$_->name}++ }
195 map { Class::MOP::class_of($_)->can('calculate_all_roles')
196 ? Class::MOP::class_of($_)->calculate_all_roles
198 $self->linearized_isa;
202 my ($self, $role_name) = @_;
205 || $self->throw_error("You must supply a role name to look for");
207 foreach my $class ($self->class_precedence_list) {
208 my $meta = Class::MOP::class_of($class);
209 # when a Moose metaclass is itself extended with a role,
210 # this check needs to be done since some items in the
211 # class_precedence_list might in fact be Class::MOP
213 next unless $meta && $meta->can('roles');
214 foreach my $role (@{$meta->roles}) {
215 return 1 if $role->does_role($role_name);
222 my ($self, $role_name) = @_;
225 || $self->throw_error("You must supply a role name to look for");
227 foreach my $class ($self->class_precedence_list) {
228 my $meta = Class::MOP::class_of($class);
229 # when a Moose metaclass is itself extended with a role,
230 # this check needs to be done since some items in the
231 # class_precedence_list might in fact be Class::MOP
233 next unless $meta && $meta->can('roles');
234 foreach my $role (@{$meta->roles}) {
235 return 1 if $role->excludes_role($role_name);
243 my $params = @_ == 1 ? $_[0] : {@_};
244 my $object = $self->SUPER::new_object($params);
246 foreach my $attr ( $self->get_all_attributes() ) {
248 next unless $attr->can('has_trigger') && $attr->has_trigger;
250 my $init_arg = $attr->init_arg;
252 next unless defined $init_arg;
254 next unless exists $params->{$init_arg};
260 ? $attr->get_read_method_ref->($object)
261 : $params->{$init_arg}
266 $object->BUILDALL($params) if $object->can('BUILDALL');
273 my $supers = Data::OptList::mkopt(\@_);
274 foreach my $super (@{ $supers }) {
275 my ($name, $opts) = @{ $super };
276 Class::MOP::load_class($name, $opts);
277 my $meta = Class::MOP::class_of($name);
278 $self->throw_error("You cannot inherit from a Moose Role ($name)")
279 if $meta && $meta->isa('Moose::Meta::Role')
281 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
284 ### ---------------------------------------------
289 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
291 : $self->_process_attribute(@_));
292 $self->SUPER::add_attribute($attr);
293 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
294 # 'bare' and doesn't implement this method
295 if ($attr->can('_check_associated_methods')) {
296 $attr->_check_associated_methods;
301 sub add_override_method_modifier {
302 my ($self, $name, $method, $_super_package) = @_;
304 (!$self->has_method($name))
305 || $self->throw_error("Cannot add an override method if a local method is already present");
307 $self->add_method($name => Moose::Meta::Method::Overridden->new(
310 package => $_super_package, # need this for roles
315 sub add_augment_method_modifier {
316 my ($self, $name, $method) = @_;
317 (!$self->has_method($name))
318 || $self->throw_error("Cannot add an augment method if a local method is already present");
320 $self->add_method($name => Moose::Meta::Method::Augmented->new(
327 ## Private Utility methods ...
329 sub _find_next_method_by_name_which_is_not_overridden {
330 my ($self, $name) = @_;
331 foreach my $method ($self->find_all_methods_by_name($name)) {
332 return $method->{code}
333 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
338 ## Metaclass compatibility
340 sub _base_metaclasses {
342 my %metaclasses = $self->SUPER::_base_metaclasses;
343 for my $class (keys %metaclasses) {
344 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
348 error_class => 'Moose::Error::Default',
352 sub _can_fix_metaclass_incompatibility {
354 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
355 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
358 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
360 my ($super_meta) = @_;
362 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
364 my %base_metaclass = $self->_base_metaclasses;
365 for my $metaclass_type (keys %base_metaclass) {
366 next unless defined $self->$metaclass_type;
367 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
373 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
375 my ($super_meta) = @_;
377 my $super_meta_name = $super_meta->_real_ref_name;
379 return $self->_classes_differ_by_roles_only(
382 'Moose::Meta::Class',
386 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
388 my ($metaclass_type, $super_meta) = @_;
390 my $class_specific_meta_name = $self->$metaclass_type;
391 return unless $super_meta->can($metaclass_type);
392 my $super_specific_meta_name = $super_meta->$metaclass_type;
393 my %metaclasses = $self->_base_metaclasses;
395 return $self->_classes_differ_by_roles_only(
396 $class_specific_meta_name,
397 $super_specific_meta_name,
398 $metaclasses{$metaclass_type},
402 sub _classes_differ_by_roles_only {
404 my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
407 = $self->_find_common_base( $self_meta_name, $super_meta_name );
409 # If they're not both moose metaclasses, and the cmop fixing couldn't do
410 # anything, there's nothing more we can do. The $expected_ancestor should
411 # always be a Moose metaclass name like Moose::Meta::Class or
412 # Moose::Meta::Attribute.
413 return unless defined $common_base_name;
414 return unless $common_base_name->isa($expected_ancestor);
416 my @super_meta_name_ancestor_names
417 = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
418 my @class_meta_name_ancestor_names
419 = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
422 unless all { $self->_is_role_only_subclass($_) }
423 @super_meta_name_ancestor_names,
424 @class_meta_name_ancestor_names;
429 sub _find_common_base {
431 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
432 return unless defined $meta1 && defined $meta2;
434 # FIXME? This doesn't account for multiple inheritance (not sure
435 # if it needs to though). For example, if somewhere in $meta1's
436 # history it inherits from both ClassA and ClassB, and $meta2
437 # inherits from ClassB & ClassA, does it matter? And what crazy
438 # fool would do that anyway?
440 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
442 return first { $meta1_parents{$_} } $meta2->linearized_isa;
445 sub _get_ancestors_until {
447 my ($start_name, $until_name) = @_;
450 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
451 last if $ancestor_name eq $until_name;
452 push @ancestor_names, $ancestor_name;
454 return @ancestor_names;
457 sub _is_role_only_subclass {
459 my ($meta_name) = @_;
460 my $meta = Class::MOP::Class->initialize($meta_name);
461 my @parent_names = $meta->superclasses;
463 # XXX: don't feel like messing with multiple inheritance here... what would
465 return unless @parent_names == 1;
466 my ($parent_name) = @parent_names;
467 my $parent_meta = Class::MOP::Class->initialize($parent_name);
469 my @roles = $meta->can('calculate_all_roles_with_inheritance')
470 ? $meta->calculate_all_roles_with_inheritance
473 # loop over all methods that are a part of the current class
475 for my $method ( $meta->_get_local_methods ) {
477 next if $method->name eq 'meta';
478 # we'll deal with attributes below
479 next if $method->can('associated_attribute');
480 # if the method comes from a role we consumed, ignore it
481 next if $meta->can('does_role')
482 && $meta->does_role($method->original_package_name);
483 # FIXME - this really isn't right. Just because a modifier is
484 # defined in a role doesn't mean it isn't _also_ defined in the
486 next if $method->isa('Class::MOP::Method::Wrapped')
488 (!scalar($method->around_modifiers)
489 || any { $_->has_around_method_modifiers($method->name) } @roles)
490 && (!scalar($method->before_modifiers)
491 || any { $_->has_before_method_modifiers($method->name) } @roles)
492 && (!scalar($method->after_modifiers)
493 || any { $_->has_after_method_modifiers($method->name) } @roles)
499 # loop over all attributes that are a part of the current class
501 # FIXME - this really isn't right. Just because an attribute is
502 # defined in a role doesn't mean it isn't _also_ defined in the
504 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
505 next if any { $_->has_attribute($attr->name) } @roles;
513 sub _fix_class_metaclass_incompatibility {
515 my ($super_meta) = @_;
517 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
519 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
521 || confess "Can't fix metaclass incompatibility for "
523 . " because it is not pristine.";
524 my $super_meta_name = $super_meta->_real_ref_name;
525 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
526 my $new_self = $class_meta_subclass_meta_name->reinitialize(
530 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
534 sub _fix_single_metaclass_incompatibility {
536 my ($metaclass_type, $super_meta) = @_;
538 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
540 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
542 || confess "Can't fix metaclass incompatibility for "
544 . " because it is not pristine.";
545 my $super_meta_name = $super_meta->_real_ref_name;
546 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
547 my $new_self = $super_meta->reinitialize(
549 $metaclass_type => $class_specific_meta_subclass_meta_name,
552 $self->_replace_self( $new_self, $super_meta_name );
558 my ( $new_self, $new_class) = @_;
561 bless $self, $new_class;
563 # We need to replace the cached metaclass instance or else when it goes
564 # out of scope Class::MOP::Class destroy's the namespace for the
565 # metaclass's class, causing much havoc.
566 Class::MOP::store_metaclass_by_name( $self->name, $self );
567 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
570 sub _get_compatible_single_metaclass {
573 return $self->SUPER::_get_compatible_single_metaclass(@_)
574 || $self->_get_compatible_single_metaclass_by_role_reconciliation(@_);
577 sub _get_compatible_single_metaclass_by_role_reconciliation {
579 my ($single_meta_name) = @_;
581 my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
584 return unless $self->_classes_differ_by_roles_only(
586 $current_single_meta_name,
587 $single_meta_name->isa('Class::MOP::Attribute')
588 ? 'Moose::Meta::Attribute'
589 : 'Moose::Meta::Method'
592 return Moose::Util::_reconcile_roles_for_metaclass($single_meta_name, $current_single_meta_name);
595 sub _process_attribute {
596 my ( $self, $name, @args ) = @_;
598 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
600 if (($name || '') =~ /^\+(.*)/) {
601 return $self->_process_inherited_attribute($1, @args);
604 return $self->_process_new_attribute($name, @args);
608 sub _process_new_attribute {
609 my ( $self, $name, @args ) = @_;
611 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
614 sub _process_inherited_attribute {
615 my ($self, $attr_name, %options) = @_;
616 my $inherited_attr = $self->find_attribute_by_name($attr_name);
617 (defined $inherited_attr)
618 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
619 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
620 return $inherited_attr->clone_and_inherit_options(%options);
624 # kind of a kludge to handle Class::MOP::Attributes
625 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
631 sub _immutable_options {
632 my ( $self, @args ) = @_;
634 $self->SUPER::_immutable_options(
635 inline_destructor => 1,
637 # Moose always does this when an attribute is created
638 inline_accessors => 0,
644 ## -------------------------------------------------
649 my ( $self, @args ) = @_;
650 local $error_level = ($error_level || 0) + 1;
651 $self->raise_error($self->create_error(@args));
655 my ( $self, @args ) = @_;
660 my ( $self, @args ) = @_;
664 local $error_level = ($error_level || 0 ) + 1;
666 if ( @args % 2 == 1 ) {
667 unshift @args, "message";
670 my %args = ( metaclass => $self, last_error => $@, @args );
672 $args{depth} += $error_level;
674 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
676 Class::MOP::load_class($class);
679 Carp::caller_info($args{depth}),
692 Moose::Meta::Class - The Moose metaclass
696 This class is a subclass of L<Class::MOP::Class> that provides
697 additional Moose-specific functionality.
699 To really understand this class, you will need to start with the
700 L<Class::MOP::Class> documentation. This class can be understood as a
701 set of additional features on top of the basic feature provided by
706 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
712 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
714 This overrides the parent's method in order to provide its own
715 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
716 C<method_metaclass> options.
718 These all default to the appropriate Moose class.
720 =item B<< Moose::Meta::Class->create($package_name, %options) >>
722 This overrides the parent's method in order to accept a C<roles>
723 option. This should be an array reference containing roles
724 that the class does, each optionally followed by a hashref of options
725 (C<-excludes> and C<-alias>).
727 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
729 =item B<< Moose::Meta::Class->create_anon_class >>
731 This overrides the parent's method to accept a C<roles> option, just
734 It also accepts a C<cache> option. If this is true, then the anonymous
735 class will be cached based on its superclasses and roles. If an
736 existing anonymous class in the cache has the same superclasses and
737 roles, it will be reused.
739 my $metaclass = Moose::Meta::Class->create_anon_class(
740 superclasses => ['Foo'],
741 roles => [qw/Some Roles Go Here/],
745 Each entry in both the C<superclasses> and the C<roles> option can be
746 followed by a hash reference with arguments. The C<superclasses>
747 option can be supplied with a L<-version|Class::MOP/Class Loading
748 Options> option that ensures the loaded superclass satisfies the
749 required version. The C<role> option also takes the C<-version> as an
750 argument, but the option hash reference can also contain any other
751 role relevant values like exclusions or parameterized role arguments.
753 =item B<< $metaclass->make_immutable(%options) >>
755 This overrides the parent's method to add a few options. Specifically,
756 it uses the Moose-specific constructor and destructor classes, and
757 enables inlining the destructor.
759 Since Moose always inlines attributes, it sets the C<inline_accessors> option
762 =item B<< $metaclass->new_object(%params) >>
764 This overrides the parent's method in order to add support for
767 =item B<< $metaclass->superclasses(@superclasses) >>
769 This is the accessor allowing you to read or change the parents of
772 Each superclass can be followed by a hash reference containing a
773 L<-version|Class::MOP/Class Loading Options> value. If the version
774 requirement is not satisfied an error will be thrown.
776 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
778 This adds an C<override> method modifier to the package.
780 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
782 This adds an C<augment> method modifier to the package.
784 =item B<< $metaclass->calculate_all_roles >>
786 This will return a unique array of C<Moose::Meta::Role> instances
787 which are attached to this class.
789 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
791 This will return a unique array of C<Moose::Meta::Role> instances
792 which are attached to this class, and each of this class's ancestors.
794 =item B<< $metaclass->add_role($role) >>
796 This takes a L<Moose::Meta::Role> object, and adds it to the class's
797 list of roles. This I<does not> actually apply the role to the class.
799 =item B<< $metaclass->role_applications >>
801 Returns a list of L<Moose::Meta::Role::Application::ToClass>
802 objects, which contain the arguments to role application.
804 =item B<< $metaclass->add_role_application($application) >>
806 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
807 adds it to the class's list of role applications. This I<does not>
808 actually apply any role to the class; it is only for tracking role
811 =item B<< $metaclass->does_role($role) >>
813 This returns a boolean indicating whether or not the class does the specified
814 role. The role provided can be either a role name or a L<Moose::Meta::Role>
815 object. This tests both the class and its parents.
817 =item B<< $metaclass->excludes_role($role_name) >>
819 A class excludes a role if it has already composed a role which
820 excludes the named role. This tests both the class and its parents.
822 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
824 This overrides the parent's method in order to allow the parameters to
825 be provided as a hash reference.
827 =item B<< $metaclass->constructor_class($class_name) >>
829 =item B<< $metaclass->destructor_class($class_name) >>
831 These are the names of classes used when making a class immutable. These
832 default to L<Moose::Meta::Method::Constructor> and
833 L<Moose::Meta::Method::Destructor> respectively. These accessors are
834 read-write, so you can use them to change the class name.
836 =item B<< $metaclass->error_class($class_name) >>
838 The name of the class used to throw errors. This defaults to
839 L<Moose::Error::Default>, which generates an error with a stacktrace
840 just like C<Carp::confess>.
842 =item B<< $metaclass->throw_error($message, %extra) >>
844 Throws the error created by C<create_error> using C<raise_error>
850 See L<Moose/BUGS> for details on reporting bugs.
854 Stevan Little E<lt>stevan@iinteractive.comE<gt>
856 =head1 COPYRIGHT AND LICENSE
858 Copyright 2006-2010 by Infinity Interactive, Inc.
860 L<http://www.iinteractive.com>
862 This library is free software; you can redistribute it and/or modify
863 it under the same terms as Perl itself.