2 package Moose::Meta::Class;
10 use List::Util qw( first );
11 use List::MoreUtils qw( any all uniq first_index );
12 use Scalar::Util 'weaken', 'blessed';
14 our $VERSION = '0.89_02';
15 $VERSION = eval $VERSION;
16 our $AUTHORITY = 'cpan:STEVAN';
18 use Moose::Meta::Method::Overridden;
19 use Moose::Meta::Method::Augmented;
20 use Moose::Error::Default;
21 use Moose::Meta::Class::Immutable::Trait;
22 use Moose::Meta::Method::Constructor;
23 use Moose::Meta::Method::Destructor;
25 use base 'Class::MOP::Class';
27 __PACKAGE__->meta->add_attribute('roles' => (
32 __PACKAGE__->meta->add_attribute('role_applications' => (
33 reader => '_get_role_applications',
37 __PACKAGE__->meta->add_attribute(
38 Class::MOP::Attribute->new('immutable_trait' => (
39 accessor => "immutable_trait",
40 default => 'Moose::Meta::Class::Immutable::Trait',
44 __PACKAGE__->meta->add_attribute('constructor_class' => (
45 accessor => 'constructor_class',
46 default => 'Moose::Meta::Method::Constructor',
49 __PACKAGE__->meta->add_attribute('destructor_class' => (
50 accessor => 'destructor_class',
51 default => 'Moose::Meta::Method::Destructor',
54 __PACKAGE__->meta->add_attribute('error_class' => (
55 accessor => 'error_class',
56 default => 'Moose::Error::Default',
62 return Class::MOP::get_metaclass_by_name($pkg)
63 || $class->SUPER::initialize($pkg,
64 'attribute_metaclass' => 'Moose::Meta::Attribute',
65 'method_metaclass' => 'Moose::Meta::Method',
66 'instance_metaclass' => 'Moose::Meta::Instance',
71 sub _immutable_options {
72 my ( $self, @args ) = @_;
74 $self->SUPER::_immutable_options(
75 allow_mutable_ancestors => 0,
76 inline_destructor => 1,
78 # Moose always does this when an attribute is created
79 inline_accessors => 0,
86 my ($self, $package_name, %options) = @_;
88 (ref $options{roles} eq 'ARRAY')
89 || $self->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 $class = $self->SUPER::create($package_name, %options);
96 Moose::Util::apply_all_roles( $class, @$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};
119 # something like Super::Class|Super::Class::2=Role|Role::1
120 my $cache_key = join '=' => (
121 join('|', @{$options{superclasses} || []}),
122 join('|', sort @{$options{roles} || []}),
125 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
126 return $ANON_CLASSES{$cache_key};
129 my $new_class = $self->SUPER::create_anon_class(%options);
131 $ANON_CLASSES{$cache_key} = $new_class
138 my ($self, $role) = @_;
139 (blessed($role) && $role->isa('Moose::Meta::Role'))
140 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
141 push @{$self->roles} => $role;
148 # we do this for metaclasses way too often to do this check for them
149 if ( !$args{allow_mutable_ancestors}
150 && !$self->name->isa('Class::MOP::Object') ) {
151 my @superclasses = grep { $_ ne 'Moose::Object' && $_ ne $self->name }
152 $self->linearized_isa;
154 for my $superclass (@superclasses) {
155 my $meta = Class::MOP::class_of($superclass);
157 next unless $meta && $meta->isa('Moose::Meta::Class');
158 next unless $meta->is_mutable;
159 # This can happen when a base class role is applied via
160 # Moose::Util::MetaRole::apply_base_class_roles. The parent is an
161 # anon class and is still mutable, but that's okay.
162 next if $meta->is_anon_class;
164 Carp::cluck( "Calling make_immutable on "
166 . ", which has a mutable ancestor ($superclass)" );
171 $self->SUPER::make_immutable(@_);
174 sub role_applications {
177 return @{$self->_get_role_applications};
180 sub add_role_application {
181 my ($self, $application) = @_;
182 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
183 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
184 push @{$self->_get_role_applications} => $application;
187 sub calculate_all_roles {
190 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
194 my ($self, $role_name) = @_;
197 || $self->throw_error("You must supply a role name to look for");
199 foreach my $class ($self->class_precedence_list) {
200 my $meta = Class::MOP::class_of($class);
201 # when a Moose metaclass is itself extended with a role,
202 # this check needs to be done since some items in the
203 # class_precedence_list might in fact be Class::MOP
205 next unless $meta && $meta->can('roles');
206 foreach my $role (@{$meta->roles}) {
207 return 1 if $role->does_role($role_name);
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->excludes_role($role_name);
235 my $params = @_ == 1 ? $_[0] : {@_};
236 my $self = $class->SUPER::new_object($params);
238 foreach my $attr ( $class->get_all_attributes() ) {
240 next unless $attr->can('has_trigger') && $attr->has_trigger;
242 my $init_arg = $attr->init_arg;
244 next unless defined $init_arg;
246 next unless exists $params->{$init_arg};
252 ? $attr->get_read_method_ref->($self)
253 : $params->{$init_arg}
264 foreach my $super (@supers) {
265 Class::MOP::load_class($super);
266 my $meta = Class::MOP::class_of($super);
267 $self->throw_error("You cannot inherit from a Moose Role ($super)")
268 if $meta && $meta->isa('Moose::Meta::Role')
270 return $self->SUPER::superclasses(@supers);
273 ### ---------------------------------------------
278 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
280 : $self->_process_attribute(@_));
281 $self->SUPER::add_attribute($attr);
282 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
283 # 'bare' and doesn't implement this method
284 if ($attr->can('_check_associated_methods')) {
285 $attr->_check_associated_methods;
290 sub add_override_method_modifier {
291 my ($self, $name, $method, $_super_package) = @_;
293 (!$self->has_method($name))
294 || $self->throw_error("Cannot add an override method if a local method is already present");
296 $self->add_method($name => Moose::Meta::Method::Overridden->new(
299 package => $_super_package, # need this for roles
304 sub add_augment_method_modifier {
305 my ($self, $name, $method) = @_;
306 (!$self->has_method($name))
307 || $self->throw_error("Cannot add an augment method if a local method is already present");
309 $self->add_method($name => Moose::Meta::Method::Augmented->new(
316 ## Private Utility methods ...
318 sub _find_next_method_by_name_which_is_not_overridden {
319 my ($self, $name) = @_;
320 foreach my $method ($self->find_all_methods_by_name($name)) {
321 return $method->{code}
322 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
327 sub _fix_metaclass_incompatibility {
328 my ($self, @superclasses) = @_;
330 foreach my $super (@superclasses) {
331 my $meta = Class::MOP::Class->initialize($super);
333 my @all_supers = $meta->linearized_isa;
336 my @super_metas_to_fix = ($meta);
338 # We need to check & fix the immediate superclass. If its @ISA
339 # contains a class without a metaclass instance, followed by a
340 # class _with_ a metaclass instance, init a metaclass instance
341 # for classes without one and fix compat up to and including
342 # the class which was already initialized.
343 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
345 push @super_metas_to_fix,
346 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
349 foreach my $super_meta (@super_metas_to_fix) {
350 $self->_fix_one_incompatible_metaclass($super_meta);
355 sub _fix_one_incompatible_metaclass {
356 my ($self, $meta) = @_;
358 return if $self->_superclass_meta_is_compatible($meta);
360 unless ( $self->is_pristine ) {
362 "Cannot attempt to reinitialize metaclass for "
364 . ", it isn't pristine" );
367 $self->_reconcile_with_superclass_meta($meta);
370 sub _superclass_meta_is_compatible {
371 my ($self, $super_meta) = @_;
373 next unless $super_meta->isa("Class::MOP::Class");
376 = $super_meta->is_immutable
377 ? $super_meta->_get_mutable_metaclass_name
381 if $self->isa($super_meta_name)
383 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
386 # I don't want to have to type this >1 time
388 qw( attribute_metaclass
390 wrapped_method_metaclass
396 sub _reconcile_with_superclass_meta {
397 my ($self, $super_meta) = @_;
400 = $super_meta->is_immutable
401 ? $super_meta->_get_mutable_metaclass_name
404 my $self_metaclass = ref $self;
406 # If neither of these is true we have a more serious
407 # incompatibility that we just cannot fix (yet?).
408 if ( $super_meta_name->isa( ref $self )
409 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
410 $self->_reinitialize_with($super_meta);
412 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
413 $self->_reconcile_role_differences($super_meta);
417 sub _reinitialize_with {
418 my ( $self, $new_meta ) = @_;
420 my $new_self = $new_meta->reinitialize(
422 attribute_metaclass => $new_meta->attribute_metaclass,
423 method_metaclass => $new_meta->method_metaclass,
424 instance_metaclass => $new_meta->instance_metaclass,
427 $new_self->$_( $new_meta->$_ )
428 for qw( constructor_class destructor_class error_class );
432 bless $self, ref $new_self;
434 # We need to replace the cached metaclass instance or else when it
435 # goes out of scope Class::MOP::Class destroy's the namespace for
436 # the metaclass's class, causing much havoc.
437 Class::MOP::store_metaclass_by_name( $self->name, $self );
438 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
441 # In the more complex case, we share a common ancestor with our
442 # superclass's metaclass, but each metaclass (ours and the parent's)
443 # has a different set of roles applied. We reconcile this by first
444 # reinitializing into the parent class, and _then_ applying our own
446 sub _all_metaclasses_differ_by_roles_only {
447 my ($self, $super_meta) = @_;
450 [ ref $self, ref $super_meta ],
451 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
454 next if $pair->[0] eq $pair->[1];
456 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
457 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
460 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
462 return unless $common_ancestor;
465 unless _is_role_only_subclass_of(
469 && _is_role_only_subclass_of(
478 # This, and some other functions, could be called as methods, but
479 # they're not for two reasons. One, we just end up ignoring the first
480 # argument, because we can't call these directly on one of the real
481 # arguments, because one of them could be a Class::MOP::Class object
482 # and not a Moose::Meta::Class. Second, only a completely insane
483 # person would attempt to subclass this stuff!
484 sub _find_common_ancestor {
485 my ($meta1, $meta2) = @_;
487 # FIXME? This doesn't account for multiple inheritance (not sure
488 # if it needs to though). For example, is somewhere in $meta1's
489 # history it inherits from both ClassA and ClassB, and $meta2
490 # inherits from ClassB & ClassA, does it matter? And what crazy
491 # fool would do that anyway?
493 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
495 return first { $meta1_parents{$_} } $meta2->linearized_isa;
498 sub _is_role_only_subclass_of {
499 my ($meta, $ancestor) = @_;
501 return 1 if $meta->name eq $ancestor;
503 my @roles = _all_roles_until( $meta, $ancestor );
505 my %role_packages = map { $_->name => 1 } @roles;
507 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
509 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
511 for my $method ( $meta->get_all_methods() ) {
512 next if $method->name eq 'meta';
513 next if $method->can('associated_attribute');
516 if $role_packages{ $method->original_package_name }
517 || $shared_ancestors{ $method->original_package_name };
522 # FIXME - this really isn't right. Just because an attribute is
523 # defined in a role doesn't mean it isn't _also_ defined in the
525 for my $attr ( $meta->get_all_attributes ) {
526 next if $shared_ancestors{ $attr->associated_class->name };
528 next if any { $_->has_attribute( $attr->name ) } @roles;
539 return _all_roles_until($meta);
542 sub _all_roles_until {
543 my ($meta, $stop_at_class) = @_;
545 return unless $meta->can('calculate_all_roles');
547 my @roles = $meta->calculate_all_roles;
549 for my $class ( $meta->linearized_isa ) {
550 last if $stop_at_class && $stop_at_class eq $class;
552 my $meta = Class::MOP::Class->initialize($class);
553 last unless $meta->can('calculate_all_roles');
555 push @roles, $meta->calculate_all_roles;
561 sub _reconcile_role_differences {
562 my ($self, $super_meta) = @_;
564 my $self_meta = Class::MOP::class_of($self);
568 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
569 $roles{metaclass_roles} = \@roles;
572 for my $thing (@MetaClassTypes) {
573 my $name = $self->$thing();
575 my $thing_meta = Class::MOP::Class->initialize($name);
577 my @roles = map { $_->name } _all_roles($thing_meta)
580 $roles{ $thing . '_roles' } = \@roles;
583 $self->_reinitialize_with($super_meta);
585 Moose::Util::MetaRole::apply_metaclass_roles(
586 for_class => $self->name,
593 sub _process_attribute {
594 my ( $self, $name, @args ) = @_;
596 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
598 if (($name || '') =~ /^\+(.*)/) {
599 return $self->_process_inherited_attribute($1, @args);
602 return $self->_process_new_attribute($name, @args);
606 sub _process_new_attribute {
607 my ( $self, $name, @args ) = @_;
609 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
612 sub _process_inherited_attribute {
613 my ($self, $attr_name, %options) = @_;
614 my $inherited_attr = $self->find_attribute_by_name($attr_name);
615 (defined $inherited_attr)
616 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
617 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
618 return $inherited_attr->clone_and_inherit_options(%options);
622 # kind of a kludge to handle Class::MOP::Attributes
623 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
627 ## -------------------------------------------------
632 my ( $self, @args ) = @_;
633 local $error_level = ($error_level || 0) + 1;
634 $self->raise_error($self->create_error(@args));
638 my ( $self, @args ) = @_;
643 my ( $self, @args ) = @_;
647 local $error_level = ($error_level || 0 ) + 1;
649 if ( @args % 2 == 1 ) {
650 unshift @args, "message";
653 my %args = ( metaclass => $self, last_error => $@, @args );
655 $args{depth} += $error_level;
657 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
659 Class::MOP::load_class($class);
662 Carp::caller_info($args{depth}),
675 Moose::Meta::Class - The Moose metaclass
679 This class is a subclass of L<Class::MOP::Class> that provides
680 additional Moose-specific functionality.
682 To really understand this class, you will need to start with the
683 L<Class::MOP::Class> documentation. This class can be understood as a
684 set of additional features on top of the basic feature provided by
689 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
695 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
697 This overrides the parent's method in order to provide its own
698 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
699 C<method_metaclass> options.
701 These all default to the appropriate Moose class.
703 =item B<< Moose::Meta::Class->create($package_name, %options) >>
705 This overrides the parent's method in order to accept a C<roles>
706 option. This should be an array reference containing roles
707 that the class does, each optionally followed by a hashref of options
708 (C<-excludes> and C<-alias>).
710 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
712 =item B<< Moose::Meta::Class->create_anon_class >>
714 This overrides the parent's method to accept a C<roles> option, just
717 It also accepts a C<cache> option. If this is true, then the anonymous
718 class will be cached based on its superclasses and roles. If an
719 existing anonymous class in the cache has the same superclasses and
720 roles, it will be reused.
722 my $metaclass = Moose::Meta::Class->create_anon_class(
723 superclasses => ['Foo'],
724 roles => [qw/Some Roles Go Here/],
728 =item B<< $metaclass->make_immutable(%options) >>
730 This overrides the parent's method to add a few options. Specifically,
731 it uses the Moose-specific constructor and destructor classes, and
732 enables inlining the destructor.
734 Also, since Moose always inlines attributes, it sets the
735 C<inline_accessors> option to false.
737 It also accepts the additional C<allow_mutable_ancestors> option, to
738 silence the warning you get when trying to make a class with mutable
741 =item B<< $metaclass->new_object(%params) >>
743 This overrides the parent's method in order to add support for
746 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
748 This adds an C<override> method modifier to the package.
750 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
752 This adds an C<augment> method modifier to the package.
754 =item B<< $metaclass->calculate_all_roles >>
756 This will return a unique array of C<Moose::Meta::Role> instances
757 which are attached to this class.
759 =item B<< $metaclass->add_role($role) >>
761 This takes a L<Moose::Meta::Role> object, and adds it to the class's
762 list of roles. This I<does not> actually apply the role to the class.
764 =item B<< $metaclass->role_applications >>
766 Returns a list of L<Moose::Meta::Role::Application::ToClass>
767 objects, which contain the arguments to role application.
769 =item B<< $metaclass->add_role_application($application) >>
771 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
772 adds it to the class's list of role applications. This I<does not>
773 actually apply any role to the class; it is only for tracking role
776 =item B<< $metaclass->does_role($role_name) >>
778 This returns a boolean indicating whether or not the class does the
779 specified role. This tests both the class and its parents.
781 =item B<< $metaclass->excludes_role($role_name) >>
783 A class excludes a role if it has already composed a role which
784 excludes the named role. This tests both the class and its parents.
786 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
788 This overrides the parent's method in order to allow the parameters to
789 be provided as a hash reference.
791 =item B<< $metaclass->constructor_class ($class_name) >>
793 =item B<< $metaclass->destructor_class ($class_name) >>
795 These are the names of classes used when making a class
796 immutable. These default to L<Moose::Meta::Method::Constructor> and
797 L<Moose::Meta::Method::Destructor> respectively. These accessors are
798 read-write, so you can use them to change the class name.
800 =item B<< $metaclass->error_class($class_name) >>
802 The name of the class used to throw errors. This defaults to
803 L<Moose::Error::Default>, which generates an error with a stacktrace
804 just like C<Carp::confess>.
806 =item B<< $metaclass->throw_error($message, %extra) >>
808 Throws the error created by C<create_error> using C<raise_error>
814 All complex software has bugs lurking in it, and this module is no
815 exception. If you find a bug please either email me, or add the bug
820 Stevan Little E<lt>stevan@iinteractive.comE<gt>
822 =head1 COPYRIGHT AND LICENSE
824 Copyright 2006-2009 by Infinity Interactive, Inc.
826 L<http://www.iinteractive.com>
828 This library is free software; you can redistribute it and/or modify
829 it under the same terms as Perl itself.