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.04';
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',
72 sub _immutable_options {
73 my ( $self, @args ) = @_;
75 $self->SUPER::_immutable_options(
76 inline_destructor => 1,
78 # Moose always does this when an attribute is created
79 inline_accessors => 0,
86 my ($class, $package_name, %options) = @_;
88 (ref $options{roles} eq 'ARRAY')
89 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
90 if exists $options{roles};
91 my $roles = delete $options{roles};
93 my $new_meta = $class->SUPER::create($package_name, %options);
96 Moose::Util::apply_all_roles( $new_meta, @$roles );
104 sub create_anon_class {
105 my ($self, %options) = @_;
107 my $cache_ok = delete $options{cache};
110 = _anon_cache_key( $options{superclasses}, $options{roles} );
112 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
113 return $ANON_CLASSES{$cache_key};
116 my $new_class = $self->SUPER::create_anon_class(%options);
118 $ANON_CLASSES{$cache_key} = $new_class
124 sub _anon_cache_key {
125 # Makes something like Super::Class|Super::Class::2=Role|Role::1
127 join( '|', @{ $_[0] || [] } ),
128 join( '|', sort @{ $_[1] || [] } ),
136 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
140 my %existing_classes;
142 %existing_classes = map { $_ => $meta->$_() } qw(
145 wrapped_method_metaclass
152 $cache_key = _anon_cache_key(
153 [ $meta->superclasses ],
154 [ map { $_->name } @{ $meta->roles } ],
155 ) if $meta->is_anon_class;
158 my $new_meta = $self->SUPER::reinitialize(
164 return $new_meta unless defined $cache_key;
166 my $new_cache_key = _anon_cache_key(
167 [ $meta->superclasses ],
168 [ map { $_->name } @{ $meta->roles } ],
171 delete $ANON_CLASSES{$cache_key};
172 $ANON_CLASSES{$new_cache_key} = $new_meta;
178 my ($self, $role) = @_;
179 (blessed($role) && $role->isa('Moose::Meta::Role'))
180 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
181 push @{$self->roles} => $role;
184 sub role_applications {
187 return @{$self->_get_role_applications};
190 sub add_role_application {
191 my ($self, $application) = @_;
192 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
193 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
194 push @{$self->_get_role_applications} => $application;
197 sub calculate_all_roles {
200 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
203 sub calculate_all_roles_with_inheritance {
206 grep { !$seen{$_->name}++ }
207 map { Class::MOP::class_of($_)->can('calculate_all_roles')
208 ? Class::MOP::class_of($_)->calculate_all_roles
210 $self->linearized_isa;
214 my ($self, $role_name) = @_;
217 || $self->throw_error("You must supply a role name to look for");
219 foreach my $class ($self->class_precedence_list) {
220 my $meta = Class::MOP::class_of($class);
221 # when a Moose metaclass is itself extended with a role,
222 # this check needs to be done since some items in the
223 # class_precedence_list might in fact be Class::MOP
225 next unless $meta && $meta->can('roles');
226 foreach my $role (@{$meta->roles}) {
227 return 1 if $role->does_role($role_name);
234 my ($self, $role_name) = @_;
237 || $self->throw_error("You must supply a role name to look for");
239 foreach my $class ($self->class_precedence_list) {
240 my $meta = Class::MOP::class_of($class);
241 # when a Moose metaclass is itself extended with a role,
242 # this check needs to be done since some items in the
243 # class_precedence_list might in fact be Class::MOP
245 next unless $meta && $meta->can('roles');
246 foreach my $role (@{$meta->roles}) {
247 return 1 if $role->excludes_role($role_name);
255 my $params = @_ == 1 ? $_[0] : {@_};
256 my $object = $self->SUPER::new_object($params);
258 foreach my $attr ( $self->get_all_attributes() ) {
260 next unless $attr->can('has_trigger') && $attr->has_trigger;
262 my $init_arg = $attr->init_arg;
264 next unless defined $init_arg;
266 next unless exists $params->{$init_arg};
272 ? $attr->get_read_method_ref->($object)
273 : $params->{$init_arg}
278 $object->BUILDALL($params) if $object->can('BUILDALL');
285 my $supers = Data::OptList::mkopt(\@_);
286 foreach my $super (@{ $supers }) {
287 my ($name, $opts) = @{ $super };
288 Class::MOP::load_class($name, $opts);
289 my $meta = Class::MOP::class_of($name);
290 $self->throw_error("You cannot inherit from a Moose Role ($name)")
291 if $meta && $meta->isa('Moose::Meta::Role')
293 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
296 ### ---------------------------------------------
301 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
303 : $self->_process_attribute(@_));
304 $self->SUPER::add_attribute($attr);
305 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
306 # 'bare' and doesn't implement this method
307 if ($attr->can('_check_associated_methods')) {
308 $attr->_check_associated_methods;
313 sub add_override_method_modifier {
314 my ($self, $name, $method, $_super_package) = @_;
316 (!$self->has_method($name))
317 || $self->throw_error("Cannot add an override method if a local method is already present");
319 $self->add_method($name => Moose::Meta::Method::Overridden->new(
322 package => $_super_package, # need this for roles
327 sub add_augment_method_modifier {
328 my ($self, $name, $method) = @_;
329 (!$self->has_method($name))
330 || $self->throw_error("Cannot add an augment method if a local method is already present");
332 $self->add_method($name => Moose::Meta::Method::Augmented->new(
339 ## Private Utility methods ...
341 sub _find_next_method_by_name_which_is_not_overridden {
342 my ($self, $name) = @_;
343 foreach my $method ($self->find_all_methods_by_name($name)) {
344 return $method->{code}
345 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
350 ## Metaclass compatibility
352 sub _base_metaclasses {
354 my %metaclasses = $self->SUPER::_base_metaclasses;
355 for my $class (keys %metaclasses) {
356 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
360 error_class => 'Moose::Error::Default',
364 sub _find_common_base {
366 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
367 return unless defined $meta1 && defined $meta2;
369 # FIXME? This doesn't account for multiple inheritance (not sure
370 # if it needs to though). For example, if somewhere in $meta1's
371 # history it inherits from both ClassA and ClassB, and $meta2
372 # inherits from ClassB & ClassA, does it matter? And what crazy
373 # fool would do that anyway?
375 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
377 return first { $meta1_parents{$_} } $meta2->linearized_isa;
380 sub _get_ancestors_until {
382 my ($start_name, $until_name) = @_;
385 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
386 last if $ancestor_name eq $until_name;
387 push @ancestor_names, $ancestor_name;
389 return @ancestor_names;
392 sub _is_role_only_subclass {
394 my ($meta_name) = @_;
395 my $meta = Class::MOP::Class->initialize($meta_name);
396 my @parent_names = $meta->superclasses;
398 # XXX: don't feel like messing with multiple inheritance here... what would
400 return unless @parent_names == 1;
401 my ($parent_name) = @parent_names;
402 my $parent_meta = Class::MOP::Class->initialize($parent_name);
404 # loop over all methods that are a part of the current class
406 for my $method (map { $meta->get_method($_) } $meta->get_method_list) {
408 next if $method->name eq 'meta';
409 # we'll deal with attributes below
410 next if $method->isa('Class::MOP::Method::Accessor');
411 # if the method comes from a role we consumed, ignore it
412 next if $meta->can('does_role')
413 && $meta->does_role($method->original_package_name);
418 # loop over all attributes that are a part of the current class
420 # FIXME - this really isn't right. Just because an attribute is
421 # defined in a role doesn't mean it isn't _also_ defined in the
423 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
424 next if any { $_->has_attribute($attr->name) }
425 $meta->calculate_all_roles_with_inheritance;
433 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
435 my ($super_meta) = @_;
437 my $super_meta_name = $super_meta->_real_ref_name;
439 return $self->_classes_differ_by_roles_only(
442 'Moose::Meta::Class',
446 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
448 my ($metaclass_type, $super_meta) = @_;
450 my $class_specific_meta_name = $self->$metaclass_type;
451 return unless $super_meta->can($metaclass_type);
452 my $super_specific_meta_name = $super_meta->$metaclass_type;
453 my %metaclasses = $self->_base_metaclasses;
455 return $self->_classes_differ_by_roles_only(
456 $class_specific_meta_name,
457 $super_specific_meta_name,
458 $metaclasses{$metaclass_type},
462 sub _classes_differ_by_roles_only {
464 my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
467 = $self->_find_common_base( $self_meta_name, $super_meta_name );
469 # If they're not both moose metaclasses, and the cmop fixing couldn't do
470 # anything, there's nothing more we can do. The $expected_ancestor should
471 # always be a Moose metaclass name like Moose::Meta::Class or
472 # Moose::Meta::Attribute.
473 return unless defined $common_base_name;
474 return unless $common_base_name->isa($expected_ancestor);
476 my @super_meta_name_ancestor_names
477 = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
478 my @class_meta_name_ancestor_names
479 = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
482 unless all { $self->_is_role_only_subclass($_) }
483 @super_meta_name_ancestor_names,
484 @class_meta_name_ancestor_names;
489 sub _role_differences {
491 my ($class_meta_name, $super_meta_name) = @_;
492 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
493 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
495 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
496 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
499 for my $role_meta (@role_metas) {
500 push @differences, $role_meta
501 unless any { $_->name eq $role_meta->name } @super_role_metas;
506 sub _reconcile_roles_for_metaclass {
508 my ($class_meta_name, $super_meta_name) = @_;
510 my @role_differences = $self->_role_differences(
511 $class_meta_name, $super_meta_name,
513 return Moose::Meta::Class->create_anon_class(
514 superclasses => [$super_meta_name],
515 roles => \@role_differences,
520 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
522 my ($super_meta) = @_;
524 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
526 my %base_metaclass = $self->_base_metaclasses;
527 for my $metaclass_type (keys %base_metaclass) {
528 next unless defined $self->$metaclass_type;
529 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
535 sub _can_fix_metaclass_incompatibility {
537 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
538 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
541 sub _fix_class_metaclass_incompatibility {
543 my ($super_meta) = @_;
545 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
547 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
549 || confess "Can't fix metaclass incompatibility for "
551 . " because it is not pristine.";
552 my $super_meta_name = $super_meta->_real_ref_name;
553 my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
554 my $new_self = $class_meta_subclass_meta->name->reinitialize(
558 $self->_replace_self( $new_self, $class_meta_subclass_meta->name );
562 sub _fix_single_metaclass_incompatibility {
564 my ($metaclass_type, $super_meta) = @_;
566 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
568 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
570 || confess "Can't fix metaclass incompatibility for "
572 . " because it is not pristine.";
573 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
574 my $new_self = $super_meta->reinitialize(
576 $metaclass_type => $class_specific_meta_subclass_meta->name,
579 $self->_replace_self( $new_self, blessed($super_meta) );
586 my ( $new_self, $new_class) = @_;
589 bless $self, $new_class;
591 # We need to replace the cached metaclass instance or else when it goes
592 # out of scope Class::MOP::Class destroy's the namespace for the
593 # metaclass's class, causing much havoc.
594 Class::MOP::store_metaclass_by_name( $self->name, $self );
595 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
598 sub _process_attribute {
599 my ( $self, $name, @args ) = @_;
601 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
603 if (($name || '') =~ /^\+(.*)/) {
604 return $self->_process_inherited_attribute($1, @args);
607 return $self->_process_new_attribute($name, @args);
611 sub _process_new_attribute {
612 my ( $self, $name, @args ) = @_;
614 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
617 sub _process_inherited_attribute {
618 my ($self, $attr_name, %options) = @_;
619 my $inherited_attr = $self->find_attribute_by_name($attr_name);
620 (defined $inherited_attr)
621 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
622 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
623 return $inherited_attr->clone_and_inherit_options(%options);
627 # kind of a kludge to handle Class::MOP::Attributes
628 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
632 ## -------------------------------------------------
637 my ( $self, @args ) = @_;
638 local $error_level = ($error_level || 0) + 1;
639 $self->raise_error($self->create_error(@args));
643 my ( $self, @args ) = @_;
648 my ( $self, @args ) = @_;
652 local $error_level = ($error_level || 0 ) + 1;
654 if ( @args % 2 == 1 ) {
655 unshift @args, "message";
658 my %args = ( metaclass => $self, last_error => $@, @args );
660 $args{depth} += $error_level;
662 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
664 Class::MOP::load_class($class);
667 Carp::caller_info($args{depth}),
680 Moose::Meta::Class - The Moose metaclass
684 This class is a subclass of L<Class::MOP::Class> that provides
685 additional Moose-specific functionality.
687 To really understand this class, you will need to start with the
688 L<Class::MOP::Class> documentation. This class can be understood as a
689 set of additional features on top of the basic feature provided by
694 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
700 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
702 This overrides the parent's method in order to provide its own
703 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
704 C<method_metaclass> options.
706 These all default to the appropriate Moose class.
708 =item B<< Moose::Meta::Class->create($package_name, %options) >>
710 This overrides the parent's method in order to accept a C<roles>
711 option. This should be an array reference containing roles
712 that the class does, each optionally followed by a hashref of options
713 (C<-excludes> and C<-alias>).
715 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
717 =item B<< Moose::Meta::Class->create_anon_class >>
719 This overrides the parent's method to accept a C<roles> option, just
722 It also accepts a C<cache> option. If this is true, then the anonymous
723 class will be cached based on its superclasses and roles. If an
724 existing anonymous class in the cache has the same superclasses and
725 roles, it will be reused.
727 my $metaclass = Moose::Meta::Class->create_anon_class(
728 superclasses => ['Foo'],
729 roles => [qw/Some Roles Go Here/],
733 Each entry in both the C<superclasses> and the C<roles> option can be
734 followed by a hash reference with arguments. The C<superclasses>
735 option can be supplied with a L<-version|Class::MOP/Class Loading
736 Options> option that ensures the loaded superclass satisfies the
737 required version. The C<role> option also takes the C<-version> as an
738 argument, but the option hash reference can also contain any other
739 role relevant values like exclusions or parameterized role arguments.
741 =item B<< $metaclass->make_immutable(%options) >>
743 This overrides the parent's method to add a few options. Specifically,
744 it uses the Moose-specific constructor and destructor classes, and
745 enables inlining the destructor.
747 Also, since Moose always inlines attributes, it sets the
748 C<inline_accessors> option to false.
750 =item B<< $metaclass->new_object(%params) >>
752 This overrides the parent's method in order to add support for
755 =item B<< $metaclass->superclasses(@superclasses) >>
757 This is the accessor allowing you to read or change the parents of
760 Each superclass can be followed by a hash reference containing a
761 L<-version|Class::MOP/Class Loading Options> value. If the version
762 requirement is not satisfied an error will be thrown.
764 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
766 This adds an C<override> method modifier to the package.
768 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
770 This adds an C<augment> method modifier to the package.
772 =item B<< $metaclass->calculate_all_roles >>
774 This will return a unique array of C<Moose::Meta::Role> instances
775 which are attached to this class.
777 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
779 This will return a unique array of C<Moose::Meta::Role> instances
780 which are attached to this class, and each of this class's ancestors.
782 =item B<< $metaclass->add_role($role) >>
784 This takes a L<Moose::Meta::Role> object, and adds it to the class's
785 list of roles. This I<does not> actually apply the role to the class.
787 =item B<< $metaclass->role_applications >>
789 Returns a list of L<Moose::Meta::Role::Application::ToClass>
790 objects, which contain the arguments to role application.
792 =item B<< $metaclass->add_role_application($application) >>
794 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
795 adds it to the class's list of role applications. This I<does not>
796 actually apply any role to the class; it is only for tracking role
799 =item B<< $metaclass->does_role($role) >>
801 This returns a boolean indicating whether or not the class does the specified
802 role. The role provided can be either a role name or a L<Moose::Meta::Role>
803 object. This tests both the class and its parents.
805 =item B<< $metaclass->excludes_role($role_name) >>
807 A class excludes a role if it has already composed a role which
808 excludes the named role. This tests both the class and its parents.
810 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
812 This overrides the parent's method in order to allow the parameters to
813 be provided as a hash reference.
815 =item B<< $metaclass->constructor_class($class_name) >>
817 =item B<< $metaclass->destructor_class($class_name) >>
819 These are the names of classes used when making a class
820 immutable. These default to L<Moose::Meta::Method::Constructor> and
821 L<Moose::Meta::Method::Destructor> respectively. These accessors are
822 read-write, so you can use them to change the class name.
824 =item B<< $metaclass->error_class($class_name) >>
826 The name of the class used to throw errors. This defaults to
827 L<Moose::Error::Default>, which generates an error with a stacktrace
828 just like C<Carp::confess>.
830 =item B<< $metaclass->throw_error($message, %extra) >>
832 Throws the error created by C<create_error> using C<raise_error>
838 See L<Moose/BUGS> for details on reporting bugs.
842 Stevan Little E<lt>stevan@iinteractive.comE<gt>
844 =head1 COPYRIGHT AND LICENSE
846 Copyright 2006-2010 by Infinity Interactive, Inc.
848 L<http://www.iinteractive.com>
850 This library is free software; you can redistribute it and/or modify
851 it under the same terms as Perl itself.