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 _find_common_base {
353 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
354 return unless defined $meta1 && defined $meta2;
356 # FIXME? This doesn't account for multiple inheritance (not sure
357 # if it needs to though). For example, if somewhere in $meta1's
358 # history it inherits from both ClassA and ClassB, and $meta2
359 # inherits from ClassB & ClassA, does it matter? And what crazy
360 # fool would do that anyway?
362 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
364 return first { $meta1_parents{$_} } $meta2->linearized_isa;
367 sub _get_ancestors_until {
369 my ($start_name, $until_name) = @_;
372 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
373 last if $ancestor_name eq $until_name;
374 push @ancestor_names, $ancestor_name;
376 return @ancestor_names;
379 sub _is_role_only_subclass {
381 my ($meta_name) = @_;
382 my $meta = Class::MOP::Class->initialize($meta_name);
383 my @parent_names = $meta->superclasses;
385 # XXX: don't feel like messing with multiple inheritance here... what would
387 return unless @parent_names == 1;
388 my ($parent_name) = @parent_names;
389 my $parent_meta = Class::MOP::Class->initialize($parent_name);
391 my @roles = $meta->can('calculate_all_roles_with_inheritance')
392 ? $meta->calculate_all_roles_with_inheritance
395 # loop over all methods that are a part of the current class
397 for my $method ( $meta->_get_local_methods ) {
399 next if $method->name eq 'meta';
400 # we'll deal with attributes below
401 next if $method->can('associated_attribute');
402 # if the method comes from a role we consumed, ignore it
403 next if $meta->can('does_role')
404 && $meta->does_role($method->original_package_name);
405 # FIXME - this really isn't right. Just because a modifier is
406 # defined in a role doesn't mean it isn't _also_ defined in the
408 next if $method->isa('Class::MOP::Method::Wrapped')
410 (!scalar($method->around_modifiers)
411 || any { $_->has_around_method_modifiers($method->name) } @roles)
412 && (!scalar($method->before_modifiers)
413 || any { $_->has_before_method_modifiers($method->name) } @roles)
414 && (!scalar($method->after_modifiers)
415 || any { $_->has_after_method_modifiers($method->name) } @roles)
421 # loop over all attributes that are a part of the current class
423 # FIXME - this really isn't right. Just because an attribute is
424 # defined in a role doesn't mean it isn't _also_ defined in the
426 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
427 next if any { $_->has_attribute($attr->name) } @roles;
435 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
437 my ($super_meta) = @_;
439 my $super_meta_name = $super_meta->_real_ref_name;
441 return $self->_classes_differ_by_roles_only(
444 'Moose::Meta::Class',
448 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
450 my ($metaclass_type, $super_meta) = @_;
452 my $class_specific_meta_name = $self->$metaclass_type;
453 return unless $super_meta->can($metaclass_type);
454 my $super_specific_meta_name = $super_meta->$metaclass_type;
455 my %metaclasses = $self->_base_metaclasses;
457 return $self->_classes_differ_by_roles_only(
458 $class_specific_meta_name,
459 $super_specific_meta_name,
460 $metaclasses{$metaclass_type},
464 sub _classes_differ_by_roles_only {
466 my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
469 = $self->_find_common_base( $self_meta_name, $super_meta_name );
471 # If they're not both moose metaclasses, and the cmop fixing couldn't do
472 # anything, there's nothing more we can do. The $expected_ancestor should
473 # always be a Moose metaclass name like Moose::Meta::Class or
474 # Moose::Meta::Attribute.
475 return unless defined $common_base_name;
476 return unless $common_base_name->isa($expected_ancestor);
478 my @super_meta_name_ancestor_names
479 = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
480 my @class_meta_name_ancestor_names
481 = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
484 unless all { $self->_is_role_only_subclass($_) }
485 @super_meta_name_ancestor_names,
486 @class_meta_name_ancestor_names;
491 sub _role_differences {
493 my ($class_meta_name, $super_meta_name) = @_;
494 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
495 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
497 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
498 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
501 for my $role_meta (@role_metas) {
502 push @differences, $role_meta
503 unless any { $_->name eq $role_meta->name } @super_role_metas;
508 sub _reconcile_roles_for_metaclass {
510 my ($class_meta_name, $super_meta_name) = @_;
512 my @role_differences = $self->_role_differences(
513 $class_meta_name, $super_meta_name,
516 # handle the case where we need to fix compatibility between a class and
517 # its parent, but all roles in the class are already also done by the
520 return Class::MOP::class_of($super_meta_name)
521 unless @role_differences;
523 return Moose::Meta::Class->create_anon_class(
524 superclasses => [$super_meta_name],
525 roles => \@role_differences,
530 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
532 my ($super_meta) = @_;
534 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
536 my %base_metaclass = $self->_base_metaclasses;
537 for my $metaclass_type (keys %base_metaclass) {
538 next unless defined $self->$metaclass_type;
539 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
545 sub _can_fix_metaclass_incompatibility {
547 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
548 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
551 sub _fix_class_metaclass_incompatibility {
553 my ($super_meta) = @_;
555 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
557 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
559 || confess "Can't fix metaclass incompatibility for "
561 . " because it is not pristine.";
562 my $super_meta_name = $super_meta->_real_ref_name;
563 my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
564 my $new_self = $class_meta_subclass_meta->name->reinitialize(
568 $self->_replace_self( $new_self, $class_meta_subclass_meta->name );
572 sub _fix_single_metaclass_incompatibility {
574 my ($metaclass_type, $super_meta) = @_;
576 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
578 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
580 || confess "Can't fix metaclass incompatibility for "
582 . " because it is not pristine.";
583 my $super_meta_name = $super_meta->_real_ref_name;
584 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
585 my $new_self = $super_meta->reinitialize(
587 $metaclass_type => $class_specific_meta_subclass_meta->name,
590 $self->_replace_self( $new_self, $super_meta_name );
597 my ( $new_self, $new_class) = @_;
600 bless $self, $new_class;
602 # We need to replace the cached metaclass instance or else when it goes
603 # out of scope Class::MOP::Class destroy's the namespace for the
604 # metaclass's class, causing much havoc.
605 Class::MOP::store_metaclass_by_name( $self->name, $self );
606 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
609 sub _process_attribute {
610 my ( $self, $name, @args ) = @_;
612 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
614 if (($name || '') =~ /^\+(.*)/) {
615 return $self->_process_inherited_attribute($1, @args);
618 return $self->_process_new_attribute($name, @args);
622 sub _process_new_attribute {
623 my ( $self, $name, @args ) = @_;
625 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
628 sub _process_inherited_attribute {
629 my ($self, $attr_name, %options) = @_;
630 my $inherited_attr = $self->find_attribute_by_name($attr_name);
631 (defined $inherited_attr)
632 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
633 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
634 return $inherited_attr->clone_and_inherit_options(%options);
638 # kind of a kludge to handle Class::MOP::Attributes
639 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
645 sub _immutable_options {
646 my ( $self, @args ) = @_;
648 $self->SUPER::_immutable_options(
649 inline_destructor => 1,
651 # Moose always does this when an attribute is created
652 inline_accessors => 0,
658 ## -------------------------------------------------
663 my ( $self, @args ) = @_;
664 local $error_level = ($error_level || 0) + 1;
665 $self->raise_error($self->create_error(@args));
669 my ( $self, @args ) = @_;
674 my ( $self, @args ) = @_;
678 local $error_level = ($error_level || 0 ) + 1;
680 if ( @args % 2 == 1 ) {
681 unshift @args, "message";
684 my %args = ( metaclass => $self, last_error => $@, @args );
686 $args{depth} += $error_level;
688 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
690 Class::MOP::load_class($class);
693 Carp::caller_info($args{depth}),
706 Moose::Meta::Class - The Moose metaclass
710 This class is a subclass of L<Class::MOP::Class> that provides
711 additional Moose-specific functionality.
713 To really understand this class, you will need to start with the
714 L<Class::MOP::Class> documentation. This class can be understood as a
715 set of additional features on top of the basic feature provided by
720 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
726 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
728 This overrides the parent's method in order to provide its own
729 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
730 C<method_metaclass> options.
732 These all default to the appropriate Moose class.
734 =item B<< Moose::Meta::Class->create($package_name, %options) >>
736 This overrides the parent's method in order to accept a C<roles>
737 option. This should be an array reference containing roles
738 that the class does, each optionally followed by a hashref of options
739 (C<-excludes> and C<-alias>).
741 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
743 =item B<< Moose::Meta::Class->create_anon_class >>
745 This overrides the parent's method to accept a C<roles> option, just
748 It also accepts a C<cache> option. If this is true, then the anonymous
749 class will be cached based on its superclasses and roles. If an
750 existing anonymous class in the cache has the same superclasses and
751 roles, it will be reused.
753 my $metaclass = Moose::Meta::Class->create_anon_class(
754 superclasses => ['Foo'],
755 roles => [qw/Some Roles Go Here/],
759 Each entry in both the C<superclasses> and the C<roles> option can be
760 followed by a hash reference with arguments. The C<superclasses>
761 option can be supplied with a L<-version|Class::MOP/Class Loading
762 Options> option that ensures the loaded superclass satisfies the
763 required version. The C<role> option also takes the C<-version> as an
764 argument, but the option hash reference can also contain any other
765 role relevant values like exclusions or parameterized role arguments.
767 =item B<< $metaclass->make_immutable(%options) >>
769 This overrides the parent's method to add a few options. Specifically,
770 it uses the Moose-specific constructor and destructor classes, and
771 enables inlining the destructor.
773 Since Moose always inlines attributes, it sets the C<inline_accessors> option
776 =item B<< $metaclass->new_object(%params) >>
778 This overrides the parent's method in order to add support for
781 =item B<< $metaclass->superclasses(@superclasses) >>
783 This is the accessor allowing you to read or change the parents of
786 Each superclass can be followed by a hash reference containing a
787 L<-version|Class::MOP/Class Loading Options> value. If the version
788 requirement is not satisfied an error will be thrown.
790 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
792 This adds an C<override> method modifier to the package.
794 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
796 This adds an C<augment> method modifier to the package.
798 =item B<< $metaclass->calculate_all_roles >>
800 This will return a unique array of C<Moose::Meta::Role> instances
801 which are attached to this class.
803 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
805 This will return a unique array of C<Moose::Meta::Role> instances
806 which are attached to this class, and each of this class's ancestors.
808 =item B<< $metaclass->add_role($role) >>
810 This takes a L<Moose::Meta::Role> object, and adds it to the class's
811 list of roles. This I<does not> actually apply the role to the class.
813 =item B<< $metaclass->role_applications >>
815 Returns a list of L<Moose::Meta::Role::Application::ToClass>
816 objects, which contain the arguments to role application.
818 =item B<< $metaclass->add_role_application($application) >>
820 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
821 adds it to the class's list of role applications. This I<does not>
822 actually apply any role to the class; it is only for tracking role
825 =item B<< $metaclass->does_role($role) >>
827 This returns a boolean indicating whether or not the class does the specified
828 role. The role provided can be either a role name or a L<Moose::Meta::Role>
829 object. This tests both the class and its parents.
831 =item B<< $metaclass->excludes_role($role_name) >>
833 A class excludes a role if it has already composed a role which
834 excludes the named role. This tests both the class and its parents.
836 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
838 This overrides the parent's method in order to allow the parameters to
839 be provided as a hash reference.
841 =item B<< $metaclass->constructor_class($class_name) >>
843 =item B<< $metaclass->destructor_class($class_name) >>
845 These are the names of classes used when making a class immutable. These
846 default to L<Moose::Meta::Method::Constructor> and
847 L<Moose::Meta::Method::Destructor> respectively. These accessors are
848 read-write, so you can use them to change the class name.
850 =item B<< $metaclass->error_class($class_name) >>
852 The name of the class used to throw errors. This defaults to
853 L<Moose::Error::Default>, which generates an error with a stacktrace
854 just like C<Carp::confess>.
856 =item B<< $metaclass->throw_error($message, %extra) >>
858 Throws the error created by C<create_error> using C<raise_error>
864 See L<Moose/BUGS> for details on reporting bugs.
868 Stevan Little E<lt>stevan@iinteractive.comE<gt>
870 =head1 COPYRIGHT AND LICENSE
872 Copyright 2006-2010 by Infinity Interactive, Inc.
874 L<http://www.iinteractive.com>
876 This library is free software; you can redistribute it and/or modify
877 it under the same terms as Perl itself.