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;
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',
73 my ($class, $package_name, %options) = @_;
75 (ref $options{roles} eq 'ARRAY')
76 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
77 if exists $options{roles};
78 my $roles = delete $options{roles};
80 my $new_meta = $class->SUPER::create($package_name, %options);
83 Moose::Util::apply_all_roles( $new_meta, @$roles );
91 sub create_anon_class {
92 my ($self, %options) = @_;
94 my $cache_ok = delete $options{cache};
97 = _anon_cache_key( $options{superclasses}, $options{roles} );
99 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
100 return $ANON_CLASSES{$cache_key};
103 my $new_class = $self->SUPER::create_anon_class(%options);
105 $ANON_CLASSES{$cache_key} = $new_class
111 sub _anon_cache_key {
112 # Makes something like Super::Class|Super::Class::2=Role|Role::1
114 join( '|', @{ $_[0] || [] } ),
115 join( '|', sort @{ $_[1] || [] } ),
123 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
127 my %existing_classes;
129 %existing_classes = map { $_ => $meta->$_() } qw(
132 wrapped_method_metaclass
139 $cache_key = _anon_cache_key(
140 [ $meta->superclasses ],
141 [ map { $_->name } @{ $meta->roles } ],
142 ) if $meta->is_anon_class;
145 my $new_meta = $self->SUPER::reinitialize(
151 return $new_meta unless defined $cache_key;
153 my $new_cache_key = _anon_cache_key(
154 [ $meta->superclasses ],
155 [ map { $_->name } @{ $meta->roles } ],
158 delete $ANON_CLASSES{$cache_key};
159 $ANON_CLASSES{$new_cache_key} = $new_meta;
165 my ($self, $role) = @_;
166 (blessed($role) && $role->isa('Moose::Meta::Role'))
167 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
168 push @{$self->roles} => $role;
171 sub role_applications {
174 return @{$self->_get_role_applications};
177 sub add_role_application {
178 my ($self, $application) = @_;
179 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
180 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
181 push @{$self->_get_role_applications} => $application;
184 sub calculate_all_roles {
187 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
190 sub calculate_all_roles_with_inheritance {
193 grep { !$seen{$_->name}++ }
194 map { Class::MOP::class_of($_)->can('calculate_all_roles')
195 ? Class::MOP::class_of($_)->calculate_all_roles
197 $self->linearized_isa;
201 my ($self, $role_name) = @_;
204 || $self->throw_error("You must supply a role name to look for");
206 foreach my $class ($self->class_precedence_list) {
207 my $meta = Class::MOP::class_of($class);
208 # when a Moose metaclass is itself extended with a role,
209 # this check needs to be done since some items in the
210 # class_precedence_list might in fact be Class::MOP
212 next unless $meta && $meta->can('roles');
213 foreach my $role (@{$meta->roles}) {
214 return 1 if $role->does_role($role_name);
221 my ($self, $role_name) = @_;
224 || $self->throw_error("You must supply a role name to look for");
226 foreach my $class ($self->class_precedence_list) {
227 my $meta = Class::MOP::class_of($class);
228 # when a Moose metaclass is itself extended with a role,
229 # this check needs to be done since some items in the
230 # class_precedence_list might in fact be Class::MOP
232 next unless $meta && $meta->can('roles');
233 foreach my $role (@{$meta->roles}) {
234 return 1 if $role->excludes_role($role_name);
242 my $params = @_ == 1 ? $_[0] : {@_};
243 my $object = $self->SUPER::new_object($params);
245 foreach my $attr ( $self->get_all_attributes() ) {
247 next unless $attr->can('has_trigger') && $attr->has_trigger;
249 my $init_arg = $attr->init_arg;
251 next unless defined $init_arg;
253 next unless exists $params->{$init_arg};
259 ? $attr->get_read_method_ref->($object)
260 : $params->{$init_arg}
265 $object->BUILDALL($params) if $object->can('BUILDALL');
272 my $supers = Data::OptList::mkopt(\@_);
273 foreach my $super (@{ $supers }) {
274 my ($name, $opts) = @{ $super };
275 Class::MOP::load_class($name, $opts);
276 my $meta = Class::MOP::class_of($name);
277 $self->throw_error("You cannot inherit from a Moose Role ($name)")
278 if $meta && $meta->isa('Moose::Meta::Role')
280 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
283 ### ---------------------------------------------
288 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
290 : $self->_process_attribute(@_));
291 $self->SUPER::add_attribute($attr);
292 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
293 # 'bare' and doesn't implement this method
294 if ($attr->can('_check_associated_methods')) {
295 $attr->_check_associated_methods;
300 sub add_override_method_modifier {
301 my ($self, $name, $method, $_super_package) = @_;
303 (!$self->has_method($name))
304 || $self->throw_error("Cannot add an override method if a local method is already present");
306 $self->add_method($name => Moose::Meta::Method::Overridden->new(
309 package => $_super_package, # need this for roles
314 sub add_augment_method_modifier {
315 my ($self, $name, $method) = @_;
316 (!$self->has_method($name))
317 || $self->throw_error("Cannot add an augment method if a local method is already present");
319 $self->add_method($name => Moose::Meta::Method::Augmented->new(
326 ## Private Utility methods ...
328 sub _find_next_method_by_name_which_is_not_overridden {
329 my ($self, $name) = @_;
330 foreach my $method ($self->find_all_methods_by_name($name)) {
331 return $method->{code}
332 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
337 ## Metaclass compatibility
339 sub _base_metaclasses {
341 my %metaclasses = $self->SUPER::_base_metaclasses;
342 for my $class (keys %metaclasses) {
343 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
347 error_class => 'Moose::Error::Default',
351 sub _can_fix_metaclass_incompatibility {
353 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
354 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
357 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
359 my ($super_meta) = @_;
361 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
363 my %base_metaclass = $self->_base_metaclasses;
364 for my $metaclass_type (keys %base_metaclass) {
365 next unless defined $self->$metaclass_type;
366 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
372 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
374 my ($super_meta) = @_;
376 my $super_meta_name = $super_meta->_real_ref_name;
378 return $self->_classes_differ_by_roles_only(
381 'Moose::Meta::Class',
385 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
387 my ($metaclass_type, $super_meta) = @_;
389 my $class_specific_meta_name = $self->$metaclass_type;
390 return unless $super_meta->can($metaclass_type);
391 my $super_specific_meta_name = $super_meta->$metaclass_type;
392 my %metaclasses = $self->_base_metaclasses;
394 return $self->_classes_differ_by_roles_only(
395 $class_specific_meta_name,
396 $super_specific_meta_name,
397 $metaclasses{$metaclass_type},
401 sub _classes_differ_by_roles_only {
403 my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
406 = $self->_find_common_base( $self_meta_name, $super_meta_name );
408 # If they're not both moose metaclasses, and the cmop fixing couldn't do
409 # anything, there's nothing more we can do. The $expected_ancestor should
410 # always be a Moose metaclass name like Moose::Meta::Class or
411 # Moose::Meta::Attribute.
412 return unless defined $common_base_name;
413 return unless $common_base_name->isa($expected_ancestor);
415 my @super_meta_name_ancestor_names
416 = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
417 my @class_meta_name_ancestor_names
418 = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
421 unless all { $self->_is_role_only_subclass($_) }
422 @super_meta_name_ancestor_names,
423 @class_meta_name_ancestor_names;
428 sub _find_common_base {
430 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
431 return unless defined $meta1 && defined $meta2;
433 # FIXME? This doesn't account for multiple inheritance (not sure
434 # if it needs to though). For example, if somewhere in $meta1's
435 # history it inherits from both ClassA and ClassB, and $meta2
436 # inherits from ClassB & ClassA, does it matter? And what crazy
437 # fool would do that anyway?
439 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
441 return first { $meta1_parents{$_} } $meta2->linearized_isa;
444 sub _get_ancestors_until {
446 my ($start_name, $until_name) = @_;
449 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
450 last if $ancestor_name eq $until_name;
451 push @ancestor_names, $ancestor_name;
453 return @ancestor_names;
456 sub _is_role_only_subclass {
458 my ($meta_name) = @_;
459 my $meta = Class::MOP::Class->initialize($meta_name);
460 my @parent_names = $meta->superclasses;
462 # XXX: don't feel like messing with multiple inheritance here... what would
464 return unless @parent_names == 1;
465 my ($parent_name) = @parent_names;
466 my $parent_meta = Class::MOP::Class->initialize($parent_name);
468 my @roles = $meta->can('calculate_all_roles_with_inheritance')
469 ? $meta->calculate_all_roles_with_inheritance
472 # loop over all methods that are a part of the current class
474 for my $method ( $meta->_get_local_methods ) {
476 next if $method->name eq 'meta';
477 # we'll deal with attributes below
478 next if $method->can('associated_attribute');
479 # if the method comes from a role we consumed, ignore it
480 next if $meta->can('does_role')
481 && $meta->does_role($method->original_package_name);
482 # FIXME - this really isn't right. Just because a modifier is
483 # defined in a role doesn't mean it isn't _also_ defined in the
485 next if $method->isa('Class::MOP::Method::Wrapped')
487 (!scalar($method->around_modifiers)
488 || any { $_->has_around_method_modifiers($method->name) } @roles)
489 && (!scalar($method->before_modifiers)
490 || any { $_->has_before_method_modifiers($method->name) } @roles)
491 && (!scalar($method->after_modifiers)
492 || any { $_->has_after_method_modifiers($method->name) } @roles)
498 # loop over all attributes that are a part of the current class
500 # FIXME - this really isn't right. Just because an attribute is
501 # defined in a role doesn't mean it isn't _also_ defined in the
503 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
504 next if any { $_->has_attribute($attr->name) } @roles;
512 sub _fix_class_metaclass_incompatibility {
514 my ($super_meta) = @_;
516 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
518 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
520 || confess "Can't fix metaclass incompatibility for "
522 . " because it is not pristine.";
523 my $super_meta_name = $super_meta->_real_ref_name;
524 my $class_meta_subclass_meta_name = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
525 my $new_self = $class_meta_subclass_meta_name->reinitialize(
529 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
533 sub _fix_single_metaclass_incompatibility {
535 my ($metaclass_type, $super_meta) = @_;
537 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
539 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
541 || confess "Can't fix metaclass incompatibility for "
543 . " because it is not pristine.";
544 my $super_meta_name = $super_meta->_real_ref_name;
545 my $class_specific_meta_subclass_meta_name = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
546 my $new_self = $super_meta->reinitialize(
548 $metaclass_type => $class_specific_meta_subclass_meta_name,
551 $self->_replace_self( $new_self, $super_meta_name );
555 sub _reconcile_roles_for_metaclass {
557 my ($class_meta_name, $super_meta_name) = @_;
559 my @role_differences = $self->_role_differences(
560 $class_meta_name, $super_meta_name,
563 # handle the case where we need to fix compatibility between a class and
564 # its parent, but all roles in the class are already also done by the
567 return $super_meta_name
568 unless @role_differences;
570 return Moose::Meta::Class->create_anon_class(
571 superclasses => [$super_meta_name],
572 roles => [map { $_->name } @role_differences],
577 sub _role_differences {
579 my ($class_meta_name, $super_meta_name) = @_;
580 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
581 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
583 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
584 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
587 for my $role_meta (@role_metas) {
588 push @differences, $role_meta
589 unless any { $_->name eq $role_meta->name } @super_role_metas;
596 my ( $new_self, $new_class) = @_;
599 bless $self, $new_class;
601 # We need to replace the cached metaclass instance or else when it goes
602 # out of scope Class::MOP::Class destroy's the namespace for the
603 # metaclass's class, causing much havoc.
604 Class::MOP::store_metaclass_by_name( $self->name, $self );
605 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
608 sub _get_compatible_single_metaclass {
611 return $self->SUPER::_get_compatible_single_metaclass(@_)
612 || $self->_get_compatible_single_metaclass_by_role_reconciliation(@_);
615 sub _get_compatible_single_metaclass_by_role_reconciliation {
617 my ($single_meta_name) = @_;
619 my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
621 return $self->_reconcile_roles_for_metaclass($single_meta_name, $current_single_meta_name);
624 sub _process_attribute {
625 my ( $self, $name, @args ) = @_;
627 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
629 if (($name || '') =~ /^\+(.*)/) {
630 return $self->_process_inherited_attribute($1, @args);
633 return $self->_process_new_attribute($name, @args);
637 sub _process_new_attribute {
638 my ( $self, $name, @args ) = @_;
640 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
643 sub _process_inherited_attribute {
644 my ($self, $attr_name, %options) = @_;
645 my $inherited_attr = $self->find_attribute_by_name($attr_name);
646 (defined $inherited_attr)
647 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
648 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
649 return $inherited_attr->clone_and_inherit_options(%options);
653 # kind of a kludge to handle Class::MOP::Attributes
654 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
660 sub _immutable_options {
661 my ( $self, @args ) = @_;
663 $self->SUPER::_immutable_options(
664 inline_destructor => 1,
666 # Moose always does this when an attribute is created
667 inline_accessors => 0,
673 ## -------------------------------------------------
678 my ( $self, @args ) = @_;
679 local $error_level = ($error_level || 0) + 1;
680 $self->raise_error($self->create_error(@args));
684 my ( $self, @args ) = @_;
689 my ( $self, @args ) = @_;
693 local $error_level = ($error_level || 0 ) + 1;
695 if ( @args % 2 == 1 ) {
696 unshift @args, "message";
699 my %args = ( metaclass => $self, last_error => $@, @args );
701 $args{depth} += $error_level;
703 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
705 Class::MOP::load_class($class);
708 Carp::caller_info($args{depth}),
721 Moose::Meta::Class - The Moose metaclass
725 This class is a subclass of L<Class::MOP::Class> that provides
726 additional Moose-specific functionality.
728 To really understand this class, you will need to start with the
729 L<Class::MOP::Class> documentation. This class can be understood as a
730 set of additional features on top of the basic feature provided by
735 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
741 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
743 This overrides the parent's method in order to provide its own
744 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
745 C<method_metaclass> options.
747 These all default to the appropriate Moose class.
749 =item B<< Moose::Meta::Class->create($package_name, %options) >>
751 This overrides the parent's method in order to accept a C<roles>
752 option. This should be an array reference containing roles
753 that the class does, each optionally followed by a hashref of options
754 (C<-excludes> and C<-alias>).
756 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
758 =item B<< Moose::Meta::Class->create_anon_class >>
760 This overrides the parent's method to accept a C<roles> option, just
763 It also accepts a C<cache> option. If this is true, then the anonymous
764 class will be cached based on its superclasses and roles. If an
765 existing anonymous class in the cache has the same superclasses and
766 roles, it will be reused.
768 my $metaclass = Moose::Meta::Class->create_anon_class(
769 superclasses => ['Foo'],
770 roles => [qw/Some Roles Go Here/],
774 Each entry in both the C<superclasses> and the C<roles> option can be
775 followed by a hash reference with arguments. The C<superclasses>
776 option can be supplied with a L<-version|Class::MOP/Class Loading
777 Options> option that ensures the loaded superclass satisfies the
778 required version. The C<role> option also takes the C<-version> as an
779 argument, but the option hash reference can also contain any other
780 role relevant values like exclusions or parameterized role arguments.
782 =item B<< $metaclass->make_immutable(%options) >>
784 This overrides the parent's method to add a few options. Specifically,
785 it uses the Moose-specific constructor and destructor classes, and
786 enables inlining the destructor.
788 Since Moose always inlines attributes, it sets the C<inline_accessors> option
791 =item B<< $metaclass->new_object(%params) >>
793 This overrides the parent's method in order to add support for
796 =item B<< $metaclass->superclasses(@superclasses) >>
798 This is the accessor allowing you to read or change the parents of
801 Each superclass can be followed by a hash reference containing a
802 L<-version|Class::MOP/Class Loading Options> value. If the version
803 requirement is not satisfied an error will be thrown.
805 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
807 This adds an C<override> method modifier to the package.
809 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
811 This adds an C<augment> method modifier to the package.
813 =item B<< $metaclass->calculate_all_roles >>
815 This will return a unique array of C<Moose::Meta::Role> instances
816 which are attached to this class.
818 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
820 This will return a unique array of C<Moose::Meta::Role> instances
821 which are attached to this class, and each of this class's ancestors.
823 =item B<< $metaclass->add_role($role) >>
825 This takes a L<Moose::Meta::Role> object, and adds it to the class's
826 list of roles. This I<does not> actually apply the role to the class.
828 =item B<< $metaclass->role_applications >>
830 Returns a list of L<Moose::Meta::Role::Application::ToClass>
831 objects, which contain the arguments to role application.
833 =item B<< $metaclass->add_role_application($application) >>
835 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
836 adds it to the class's list of role applications. This I<does not>
837 actually apply any role to the class; it is only for tracking role
840 =item B<< $metaclass->does_role($role) >>
842 This returns a boolean indicating whether or not the class does the specified
843 role. The role provided can be either a role name or a L<Moose::Meta::Role>
844 object. This tests both the class and its parents.
846 =item B<< $metaclass->excludes_role($role_name) >>
848 A class excludes a role if it has already composed a role which
849 excludes the named role. This tests both the class and its parents.
851 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
853 This overrides the parent's method in order to allow the parameters to
854 be provided as a hash reference.
856 =item B<< $metaclass->constructor_class($class_name) >>
858 =item B<< $metaclass->destructor_class($class_name) >>
860 These are the names of classes used when making a class immutable. These
861 default to L<Moose::Meta::Method::Constructor> and
862 L<Moose::Meta::Method::Destructor> respectively. These accessors are
863 read-write, so you can use them to change the class name.
865 =item B<< $metaclass->error_class($class_name) >>
867 The name of the class used to throw errors. This defaults to
868 L<Moose::Error::Default>, which generates an error with a stacktrace
869 just like C<Carp::confess>.
871 =item B<< $metaclass->throw_error($message, %extra) >>
873 Throws the error created by C<create_error> using C<raise_error>
879 See L<Moose/BUGS> for details on reporting bugs.
883 Stevan Little E<lt>stevan@iinteractive.comE<gt>
885 =head1 COPYRIGHT AND LICENSE
887 Copyright 2006-2010 by Infinity Interactive, Inc.
889 L<http://www.iinteractive.com>
891 This library is free software; you can redistribute it and/or modify
892 it under the same terms as Perl itself.