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 # only get the roles attached to this particular class, don't look at
471 my @roles = $meta->can('calculate_all_roles')
472 ? $meta->calculate_all_roles
475 # it's obviously not a role-only subclass if it doesn't do any roles
476 return unless @roles;
478 # loop over all methods that are a part of the current class
480 for my $method ( $meta->_get_local_methods ) {
482 next if $method->name eq 'meta';
483 # we'll deal with attributes below
484 next if $method->can('associated_attribute');
485 # if the method comes from a role we consumed, ignore it
486 next if $meta->can('does_role')
487 && $meta->does_role($method->original_package_name);
488 # FIXME - this really isn't right. Just because a modifier is
489 # defined in a role doesn't mean it isn't _also_ defined in the
491 next if $method->isa('Class::MOP::Method::Wrapped')
493 (!scalar($method->around_modifiers)
494 || any { $_->has_around_method_modifiers($method->name) } @roles)
495 && (!scalar($method->before_modifiers)
496 || any { $_->has_before_method_modifiers($method->name) } @roles)
497 && (!scalar($method->after_modifiers)
498 || any { $_->has_after_method_modifiers($method->name) } @roles)
504 # loop over all attributes that are a part of the current class
506 # FIXME - this really isn't right. Just because an attribute is
507 # defined in a role doesn't mean it isn't _also_ defined in the
509 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
510 next if any { $_->has_attribute($attr->name) } @roles;
518 sub _fix_class_metaclass_incompatibility {
520 my ($super_meta) = @_;
522 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
524 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
526 || confess "Can't fix metaclass incompatibility for "
528 . " because it is not pristine.";
529 my $super_meta_name = $super_meta->_real_ref_name;
530 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
531 my $new_self = $class_meta_subclass_meta_name->reinitialize(
535 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
539 sub _fix_single_metaclass_incompatibility {
541 my ($metaclass_type, $super_meta) = @_;
543 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
545 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
547 || confess "Can't fix metaclass incompatibility for "
549 . " because it is not pristine.";
550 my $super_meta_name = $super_meta->_real_ref_name;
551 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
552 my $new_self = $super_meta->reinitialize(
554 $metaclass_type => $class_specific_meta_subclass_meta_name,
557 $self->_replace_self( $new_self, $super_meta_name );
563 my ( $new_self, $new_class) = @_;
566 bless $self, $new_class;
568 # We need to replace the cached metaclass instance or else when it goes
569 # out of scope Class::MOP::Class destroy's the namespace for the
570 # metaclass's class, causing much havoc.
571 Class::MOP::store_metaclass_by_name( $self->name, $self );
572 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
575 sub _get_compatible_single_metaclass {
578 return $self->SUPER::_get_compatible_single_metaclass(@_)
579 || $self->_get_compatible_single_metaclass_by_role_reconciliation(@_);
582 sub _get_compatible_single_metaclass_by_role_reconciliation {
584 my ($single_meta_name) = @_;
586 my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
589 return unless $self->_classes_differ_by_roles_only(
591 $current_single_meta_name,
592 $single_meta_name->isa('Class::MOP::Attribute')
593 ? 'Moose::Meta::Attribute'
594 : 'Moose::Meta::Method'
597 return Moose::Util::_reconcile_roles_for_metaclass($single_meta_name, $current_single_meta_name);
600 sub _process_attribute {
601 my ( $self, $name, @args ) = @_;
603 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
605 if (($name || '') =~ /^\+(.*)/) {
606 return $self->_process_inherited_attribute($1, @args);
609 return $self->_process_new_attribute($name, @args);
613 sub _process_new_attribute {
614 my ( $self, $name, @args ) = @_;
616 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
619 sub _process_inherited_attribute {
620 my ($self, $attr_name, %options) = @_;
621 my $inherited_attr = $self->find_attribute_by_name($attr_name);
622 (defined $inherited_attr)
623 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
624 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
625 return $inherited_attr->clone_and_inherit_options(%options);
629 # kind of a kludge to handle Class::MOP::Attributes
630 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
636 sub _immutable_options {
637 my ( $self, @args ) = @_;
639 $self->SUPER::_immutable_options(
640 inline_destructor => 1,
642 # Moose always does this when an attribute is created
643 inline_accessors => 0,
649 ## -------------------------------------------------
654 my ( $self, @args ) = @_;
655 local $error_level = ($error_level || 0) + 1;
656 $self->raise_error($self->create_error(@args));
660 my ( $self, @args ) = @_;
665 my ( $self, @args ) = @_;
669 local $error_level = ($error_level || 0 ) + 1;
671 if ( @args % 2 == 1 ) {
672 unshift @args, "message";
675 my %args = ( metaclass => $self, last_error => $@, @args );
677 $args{depth} += $error_level;
679 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
681 Class::MOP::load_class($class);
684 Carp::caller_info($args{depth}),
697 Moose::Meta::Class - The Moose metaclass
701 This class is a subclass of L<Class::MOP::Class> that provides
702 additional Moose-specific functionality.
704 To really understand this class, you will need to start with the
705 L<Class::MOP::Class> documentation. This class can be understood as a
706 set of additional features on top of the basic feature provided by
711 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
717 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
719 This overrides the parent's method in order to provide its own
720 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
721 C<method_metaclass> options.
723 These all default to the appropriate Moose class.
725 =item B<< Moose::Meta::Class->create($package_name, %options) >>
727 This overrides the parent's method in order to accept a C<roles>
728 option. This should be an array reference containing roles
729 that the class does, each optionally followed by a hashref of options
730 (C<-excludes> and C<-alias>).
732 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
734 =item B<< Moose::Meta::Class->create_anon_class >>
736 This overrides the parent's method to accept a C<roles> option, just
739 It also accepts a C<cache> option. If this is true, then the anonymous
740 class will be cached based on its superclasses and roles. If an
741 existing anonymous class in the cache has the same superclasses and
742 roles, it will be reused.
744 my $metaclass = Moose::Meta::Class->create_anon_class(
745 superclasses => ['Foo'],
746 roles => [qw/Some Roles Go Here/],
750 Each entry in both the C<superclasses> and the C<roles> option can be
751 followed by a hash reference with arguments. The C<superclasses>
752 option can be supplied with a L<-version|Class::MOP/Class Loading
753 Options> option that ensures the loaded superclass satisfies the
754 required version. The C<role> option also takes the C<-version> as an
755 argument, but the option hash reference can also contain any other
756 role relevant values like exclusions or parameterized role arguments.
758 =item B<< $metaclass->make_immutable(%options) >>
760 This overrides the parent's method to add a few options. Specifically,
761 it uses the Moose-specific constructor and destructor classes, and
762 enables inlining the destructor.
764 Since Moose always inlines attributes, it sets the C<inline_accessors> option
767 =item B<< $metaclass->new_object(%params) >>
769 This overrides the parent's method in order to add support for
772 =item B<< $metaclass->superclasses(@superclasses) >>
774 This is the accessor allowing you to read or change the parents of
777 Each superclass can be followed by a hash reference containing a
778 L<-version|Class::MOP/Class Loading Options> value. If the version
779 requirement is not satisfied an error will be thrown.
781 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
783 This adds an C<override> method modifier to the package.
785 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
787 This adds an C<augment> method modifier to the package.
789 =item B<< $metaclass->calculate_all_roles >>
791 This will return a unique array of C<Moose::Meta::Role> instances
792 which are attached to this class.
794 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
796 This will return a unique array of C<Moose::Meta::Role> instances
797 which are attached to this class, and each of this class's ancestors.
799 =item B<< $metaclass->add_role($role) >>
801 This takes a L<Moose::Meta::Role> object, and adds it to the class's
802 list of roles. This I<does not> actually apply the role to the class.
804 =item B<< $metaclass->role_applications >>
806 Returns a list of L<Moose::Meta::Role::Application::ToClass>
807 objects, which contain the arguments to role application.
809 =item B<< $metaclass->add_role_application($application) >>
811 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
812 adds it to the class's list of role applications. This I<does not>
813 actually apply any role to the class; it is only for tracking role
816 =item B<< $metaclass->does_role($role) >>
818 This returns a boolean indicating whether or not the class does the specified
819 role. The role provided can be either a role name or a L<Moose::Meta::Role>
820 object. This tests both the class and its parents.
822 =item B<< $metaclass->excludes_role($role_name) >>
824 A class excludes a role if it has already composed a role which
825 excludes the named role. This tests both the class and its parents.
827 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
829 This overrides the parent's method in order to allow the parameters to
830 be provided as a hash reference.
832 =item B<< $metaclass->constructor_class($class_name) >>
834 =item B<< $metaclass->destructor_class($class_name) >>
836 These are the names of classes used when making a class immutable. These
837 default to L<Moose::Meta::Method::Constructor> and
838 L<Moose::Meta::Method::Destructor> respectively. These accessors are
839 read-write, so you can use them to change the class name.
841 =item B<< $metaclass->error_class($class_name) >>
843 The name of the class used to throw errors. This defaults to
844 L<Moose::Error::Default>, which generates an error with a stacktrace
845 just like C<Carp::confess>.
847 =item B<< $metaclass->throw_error($message, %extra) >>
849 Throws the error created by C<create_error> using C<raise_error>
855 See L<Moose/BUGS> for details on reporting bugs.
859 Stevan Little E<lt>stevan@iinteractive.comE<gt>
861 =head1 COPYRIGHT AND LICENSE
863 Copyright 2006-2010 by Infinity Interactive, Inc.
865 L<http://www.iinteractive.com>
867 This library is free software; you can redistribute it and/or modify
868 it under the same terms as Perl itself.