2 package Moose::Meta::Class;
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.03';
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 );
102 sub _check_metaclass_compatibility {
105 if ( my @supers = $self->superclasses ) {
106 $self->_fix_metaclass_incompatibility(@supers);
109 $self->SUPER::_check_metaclass_compatibility(@_);
114 sub create_anon_class {
115 my ($self, %options) = @_;
117 my $cache_ok = delete $options{cache};
120 = _anon_cache_key( $options{superclasses}, $options{roles} );
122 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
123 return $ANON_CLASSES{$cache_key};
126 my $new_class = $self->SUPER::create_anon_class(%options);
128 $ANON_CLASSES{$cache_key} = $new_class
134 sub _anon_cache_key {
135 # Makes something like Super::Class|Super::Class::2=Role|Role::1
137 join( '|', @{ $_[0] || [] } ),
138 join( '|', sort @{ $_[1] || [] } ),
146 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
150 my %existing_classes;
152 %existing_classes = map { $_ => $meta->$_() } qw(
155 wrapped_method_metaclass
162 $cache_key = _anon_cache_key(
163 [ $meta->superclasses ],
164 [ map { $_->name } @{ $meta->roles } ],
165 ) if $meta->is_anon_class;
168 my $new_meta = $self->SUPER::reinitialize(
174 return $new_meta unless defined $cache_key;
176 my $new_cache_key = _anon_cache_key(
177 [ $meta->superclasses ],
178 [ map { $_->name } @{ $meta->roles } ],
181 delete $ANON_CLASSES{$cache_key};
182 $ANON_CLASSES{$new_cache_key} = $new_meta;
188 my ($self, $role) = @_;
189 (blessed($role) && $role->isa('Moose::Meta::Role'))
190 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
191 push @{$self->roles} => $role;
194 sub role_applications {
197 return @{$self->_get_role_applications};
200 sub add_role_application {
201 my ($self, $application) = @_;
202 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
203 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
204 push @{$self->_get_role_applications} => $application;
207 sub calculate_all_roles {
210 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
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 sub _fix_metaclass_incompatibility {
351 my ($self, @superclasses) = @_;
353 $self->_fix_one_incompatible_metaclass($_)
354 for map { Moose::Meta::Class->initialize($_) } @superclasses;
357 sub _fix_one_incompatible_metaclass {
358 my ($self, $meta) = @_;
360 return if $self->_superclass_meta_is_compatible($meta);
362 unless ( $self->is_pristine ) {
364 "Cannot attempt to reinitialize metaclass for "
366 . ", it isn't pristine" );
369 $self->_reconcile_with_superclass_meta($meta);
372 sub _superclass_meta_is_compatible {
373 my ($self, $super_meta) = @_;
375 next unless $super_meta->isa("Class::MOP::Class");
378 = $super_meta->is_immutable
379 ? $super_meta->_get_mutable_metaclass_name
383 if $self->isa($super_meta_name)
385 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
388 # I don't want to have to type this >1 time
390 qw( attribute_metaclass
392 wrapped_method_metaclass
398 sub _reconcile_with_superclass_meta {
399 my ($self, $super_meta) = @_;
402 = $super_meta->is_immutable
403 ? $super_meta->_get_mutable_metaclass_name
406 my $self_metaclass = ref $self;
408 # If neither of these is true we have a more serious
409 # incompatibility that we just cannot fix (yet?).
410 if ( $super_meta_name->isa( ref $self )
411 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
412 $self->_reinitialize_with($super_meta);
414 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
415 $self->_reconcile_role_differences($super_meta);
419 sub _reinitialize_with {
420 my ( $self, $new_meta ) = @_;
422 my $new_self = $new_meta->reinitialize(
424 attribute_metaclass => $new_meta->attribute_metaclass,
425 method_metaclass => $new_meta->method_metaclass,
426 instance_metaclass => $new_meta->instance_metaclass,
429 $new_self->$_( $new_meta->$_ )
430 for qw( constructor_class destructor_class error_class );
434 bless $self, ref $new_self;
436 # We need to replace the cached metaclass instance or else when it
437 # goes out of scope Class::MOP::Class destroy's the namespace for
438 # the metaclass's class, causing much havoc.
439 Class::MOP::store_metaclass_by_name( $self->name, $self );
440 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
443 # In the more complex case, we share a common ancestor with our
444 # superclass's metaclass, but each metaclass (ours and the parent's)
445 # has a different set of roles applied. We reconcile this by first
446 # reinitializing into the parent class, and _then_ applying our own
448 sub _all_metaclasses_differ_by_roles_only {
449 my ($self, $super_meta) = @_;
452 [ ref $self, ref $super_meta ],
453 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
456 next if $pair->[0] eq $pair->[1];
458 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
459 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
462 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
464 return unless $common_ancestor;
467 unless _is_role_only_subclass_of(
471 && _is_role_only_subclass_of(
480 # This, and some other functions, could be called as methods, but
481 # they're not for two reasons. One, we just end up ignoring the first
482 # argument, because we can't call these directly on one of the real
483 # arguments, because one of them could be a Class::MOP::Class object
484 # and not a Moose::Meta::Class. Second, only a completely insane
485 # person would attempt to subclass this stuff!
486 sub _find_common_ancestor {
487 my ($meta1, $meta2) = @_;
489 # FIXME? This doesn't account for multiple inheritance (not sure
490 # if it needs to though). For example, is somewhere in $meta1's
491 # history it inherits from both ClassA and ClassB, and $meta2
492 # inherits from ClassB & ClassA, does it matter? And what crazy
493 # fool would do that anyway?
495 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
497 return first { $meta1_parents{$_} } $meta2->linearized_isa;
500 sub _is_role_only_subclass_of {
501 my ($meta, $ancestor) = @_;
503 return 1 if $meta->name eq $ancestor;
505 my @roles = _all_roles_until( $meta, $ancestor );
507 my %role_packages = map { $_->name => 1 } @roles;
509 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
511 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
513 for my $method ( $meta->get_all_methods() ) {
514 next if $method->name eq 'meta';
515 next if $method->can('associated_attribute');
518 if $role_packages{ $method->original_package_name }
519 || $shared_ancestors{ $method->original_package_name };
524 # FIXME - this really isn't right. Just because an attribute is
525 # defined in a role doesn't mean it isn't _also_ defined in the
527 for my $attr ( $meta->get_all_attributes ) {
528 next if $shared_ancestors{ $attr->associated_class->name };
530 next if any { $_->has_attribute( $attr->name ) } @roles;
541 return _all_roles_until($meta);
544 sub _all_roles_until {
545 my ($meta, $stop_at_class) = @_;
547 return unless $meta->can('calculate_all_roles');
549 my @roles = $meta->calculate_all_roles;
551 for my $class ( $meta->linearized_isa ) {
552 last if $stop_at_class && $stop_at_class eq $class;
554 my $meta = Class::MOP::Class->initialize($class);
555 last unless $meta->can('calculate_all_roles');
557 push @roles, $meta->calculate_all_roles;
563 sub _reconcile_role_differences {
564 my ($self, $super_meta) = @_;
566 my $self_meta = Class::MOP::class_of($self);
570 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
571 $roles{metaclass_roles} = \@roles;
574 for my $thing (@MetaClassTypes) {
575 my $name = $self->$thing();
577 my $thing_meta = Class::MOP::Class->initialize($name);
579 my @roles = map { $_->name } _all_roles($thing_meta)
582 $roles{ $thing . '_roles' } = \@roles;
585 $self->_reinitialize_with($super_meta);
587 Moose::Util::MetaRole::apply_metaclass_roles(
588 for_class => $self->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);
629 ## -------------------------------------------------
634 my ( $self, @args ) = @_;
635 local $error_level = ($error_level || 0) + 1;
636 $self->raise_error($self->create_error(@args));
640 my ( $self, @args ) = @_;
645 my ( $self, @args ) = @_;
649 local $error_level = ($error_level || 0 ) + 1;
651 if ( @args % 2 == 1 ) {
652 unshift @args, "message";
655 my %args = ( metaclass => $self, last_error => $@, @args );
657 $args{depth} += $error_level;
659 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
661 Class::MOP::load_class($class);
664 Carp::caller_info($args{depth}),
677 Moose::Meta::Class - The Moose metaclass
681 This class is a subclass of L<Class::MOP::Class> that provides
682 additional Moose-specific functionality.
684 To really understand this class, you will need to start with the
685 L<Class::MOP::Class> documentation. This class can be understood as a
686 set of additional features on top of the basic feature provided by
691 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
697 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
699 This overrides the parent's method in order to provide its own
700 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
701 C<method_metaclass> options.
703 These all default to the appropriate Moose class.
705 =item B<< Moose::Meta::Class->create($package_name, %options) >>
707 This overrides the parent's method in order to accept a C<roles>
708 option. This should be an array reference containing roles
709 that the class does, each optionally followed by a hashref of options
710 (C<-excludes> and C<-alias>).
712 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
714 =item B<< Moose::Meta::Class->create_anon_class >>
716 This overrides the parent's method to accept a C<roles> option, just
719 It also accepts a C<cache> option. If this is true, then the anonymous
720 class will be cached based on its superclasses and roles. If an
721 existing anonymous class in the cache has the same superclasses and
722 roles, it will be reused.
724 my $metaclass = Moose::Meta::Class->create_anon_class(
725 superclasses => ['Foo'],
726 roles => [qw/Some Roles Go Here/],
730 Each entry in both the C<superclasses> and the C<roles> option can be
731 followed by a hash reference with arguments. The C<superclasses>
732 option can be supplied with a L<-version|Class::MOP/Class Loading
733 Options> option that ensures the loaded superclass satisfies the
734 required version. The C<role> option also takes the C<-version> as an
735 argument, but the option hash reference can also contain any other
736 role relevant values like exclusions or parameterized role arguments.
738 =item B<< $metaclass->make_immutable(%options) >>
740 This overrides the parent's method to add a few options. Specifically,
741 it uses the Moose-specific constructor and destructor classes, and
742 enables inlining the destructor.
744 Also, since Moose always inlines attributes, it sets the
745 C<inline_accessors> option to false.
747 =item B<< $metaclass->new_object(%params) >>
749 This overrides the parent's method in order to add support for
752 =item B<< $metaclass->superclasses(@superclasses) >>
754 This is the accessor allowing you to read or change the parents of
757 Each superclass can be followed by a hash reference containing a
758 L<-version|Class::MOP/Class Loading Options> value. If the version
759 requirement is not satisfied an error will be thrown.
761 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
763 This adds an C<override> method modifier to the package.
765 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
767 This adds an C<augment> method modifier to the package.
769 =item B<< $metaclass->calculate_all_roles >>
771 This will return a unique array of C<Moose::Meta::Role> instances
772 which are attached to this class.
774 =item B<< $metaclass->add_role($role) >>
776 This takes a L<Moose::Meta::Role> object, and adds it to the class's
777 list of roles. This I<does not> actually apply the role to the class.
779 =item B<< $metaclass->role_applications >>
781 Returns a list of L<Moose::Meta::Role::Application::ToClass>
782 objects, which contain the arguments to role application.
784 =item B<< $metaclass->add_role_application($application) >>
786 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
787 adds it to the class's list of role applications. This I<does not>
788 actually apply any role to the class; it is only for tracking role
791 =item B<< $metaclass->does_role($role) >>
793 This returns a boolean indicating whether or not the class does the specified
794 role. The role provided can be either a role name or a L<Moose::Meta::Role>
795 object. This tests both the class and its parents.
797 =item B<< $metaclass->excludes_role($role_name) >>
799 A class excludes a role if it has already composed a role which
800 excludes the named role. This tests both the class and its parents.
802 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
804 This overrides the parent's method in order to allow the parameters to
805 be provided as a hash reference.
807 =item B<< $metaclass->constructor_class ($class_name) >>
809 =item B<< $metaclass->destructor_class ($class_name) >>
811 These are the names of classes used when making a class
812 immutable. These default to L<Moose::Meta::Method::Constructor> and
813 L<Moose::Meta::Method::Destructor> respectively. These accessors are
814 read-write, so you can use them to change the class name.
816 =item B<< $metaclass->error_class($class_name) >>
818 The name of the class used to throw errors. This defaults to
819 L<Moose::Error::Default>, which generates an error with a stacktrace
820 just like C<Carp::confess>.
822 =item B<< $metaclass->throw_error($message, %extra) >>
824 Throws the error created by C<create_error> using C<raise_error>
830 See L<Moose/BUGS> for details on reporting bugs.
834 Stevan Little E<lt>stevan@iinteractive.comE<gt>
836 =head1 COPYRIGHT AND LICENSE
838 Copyright 2006-2010 by Infinity Interactive, Inc.
840 L<http://www.iinteractive.com>
842 This library is free software; you can redistribute it and/or modify
843 it under the same terms as Perl itself.