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.96';
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',
75 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
79 %existing_classes = map { $_ => $meta->$_() } qw(
82 wrapped_method_metaclass
90 return $self->SUPER::reinitialize(
97 sub _immutable_options {
98 my ( $self, @args ) = @_;
100 $self->SUPER::_immutable_options(
101 inline_destructor => 1,
103 # Moose always does this when an attribute is created
104 inline_accessors => 0,
111 my ($self, $package_name, %options) = @_;
113 (ref $options{roles} eq 'ARRAY')
114 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
115 if exists $options{roles};
116 my $roles = delete $options{roles};
118 my $class = $self->SUPER::create($package_name, %options);
121 Moose::Util::apply_all_roles( $class, @$roles );
127 sub _check_metaclass_compatibility {
130 if ( my @supers = $self->superclasses ) {
131 $self->_fix_metaclass_incompatibility(@supers);
134 $self->SUPER::_check_metaclass_compatibility(@_);
139 sub create_anon_class {
140 my ($self, %options) = @_;
142 my $cache_ok = delete $options{cache};
144 # something like Super::Class|Super::Class::2=Role|Role::1
145 my $cache_key = join '=' => (
146 join('|', @{$options{superclasses} || []}),
147 join('|', sort @{$options{roles} || []}),
150 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
151 return $ANON_CLASSES{$cache_key};
154 my $new_class = $self->SUPER::create_anon_class(%options);
156 $ANON_CLASSES{$cache_key} = $new_class
163 my ($self, $role) = @_;
164 (blessed($role) && $role->isa('Moose::Meta::Role'))
165 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
166 push @{$self->roles} => $role;
169 sub role_applications {
172 return @{$self->_get_role_applications};
175 sub add_role_application {
176 my ($self, $application) = @_;
177 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
178 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
179 push @{$self->_get_role_applications} => $application;
182 sub calculate_all_roles {
185 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
189 my ($self, $role_name) = @_;
192 || $self->throw_error("You must supply a role name to look for");
194 foreach my $class ($self->class_precedence_list) {
195 my $meta = Class::MOP::class_of($class);
196 # when a Moose metaclass is itself extended with a role,
197 # this check needs to be done since some items in the
198 # class_precedence_list might in fact be Class::MOP
200 next unless $meta && $meta->can('roles');
201 foreach my $role (@{$meta->roles}) {
202 return 1 if $role->does_role($role_name);
209 my ($self, $role_name) = @_;
212 || $self->throw_error("You must supply a role name to look for");
214 foreach my $class ($self->class_precedence_list) {
215 my $meta = Class::MOP::class_of($class);
216 # when a Moose metaclass is itself extended with a role,
217 # this check needs to be done since some items in the
218 # class_precedence_list might in fact be Class::MOP
220 next unless $meta && $meta->can('roles');
221 foreach my $role (@{$meta->roles}) {
222 return 1 if $role->excludes_role($role_name);
230 my $params = @_ == 1 ? $_[0] : {@_};
231 my $self = $class->SUPER::new_object($params);
233 foreach my $attr ( $class->get_all_attributes() ) {
235 next unless $attr->can('has_trigger') && $attr->has_trigger;
237 my $init_arg = $attr->init_arg;
239 next unless defined $init_arg;
241 next unless exists $params->{$init_arg};
247 ? $attr->get_read_method_ref->($self)
248 : $params->{$init_arg}
259 foreach my $super (@supers) {
260 Class::MOP::load_class($super);
261 my $meta = Class::MOP::class_of($super);
262 $self->throw_error("You cannot inherit from a Moose Role ($super)")
263 if $meta && $meta->isa('Moose::Meta::Role')
265 return $self->SUPER::superclasses(@supers);
268 ### ---------------------------------------------
273 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
275 : $self->_process_attribute(@_));
276 $self->SUPER::add_attribute($attr);
277 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
278 # 'bare' and doesn't implement this method
279 if ($attr->can('_check_associated_methods')) {
280 $attr->_check_associated_methods;
285 sub add_override_method_modifier {
286 my ($self, $name, $method, $_super_package) = @_;
288 (!$self->has_method($name))
289 || $self->throw_error("Cannot add an override method if a local method is already present");
291 $self->add_method($name => Moose::Meta::Method::Overridden->new(
294 package => $_super_package, # need this for roles
299 sub add_augment_method_modifier {
300 my ($self, $name, $method) = @_;
301 (!$self->has_method($name))
302 || $self->throw_error("Cannot add an augment method if a local method is already present");
304 $self->add_method($name => Moose::Meta::Method::Augmented->new(
311 ## Private Utility methods ...
313 sub _find_next_method_by_name_which_is_not_overridden {
314 my ($self, $name) = @_;
315 foreach my $method ($self->find_all_methods_by_name($name)) {
316 return $method->{code}
317 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
322 sub _fix_metaclass_incompatibility {
323 my ($self, @superclasses) = @_;
325 $self->_fix_one_incompatible_metaclass($_)
326 for map { Moose::Meta::Class->initialize($_) } @superclasses;
329 sub _fix_one_incompatible_metaclass {
330 my ($self, $meta) = @_;
332 return if $self->_superclass_meta_is_compatible($meta);
334 unless ( $self->is_pristine ) {
336 "Cannot attempt to reinitialize metaclass for "
338 . ", it isn't pristine" );
341 $self->_reconcile_with_superclass_meta($meta);
344 sub _superclass_meta_is_compatible {
345 my ($self, $super_meta) = @_;
347 next unless $super_meta->isa("Class::MOP::Class");
350 = $super_meta->is_immutable
351 ? $super_meta->_get_mutable_metaclass_name
355 if $self->isa($super_meta_name)
357 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
360 # I don't want to have to type this >1 time
362 qw( attribute_metaclass
364 wrapped_method_metaclass
370 sub _reconcile_with_superclass_meta {
371 my ($self, $super_meta) = @_;
374 = $super_meta->is_immutable
375 ? $super_meta->_get_mutable_metaclass_name
378 my $self_metaclass = ref $self;
380 # If neither of these is true we have a more serious
381 # incompatibility that we just cannot fix (yet?).
382 if ( $super_meta_name->isa( ref $self )
383 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
384 $self->_reinitialize_with($super_meta);
386 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
387 $self->_reconcile_role_differences($super_meta);
391 sub _reinitialize_with {
392 my ( $self, $new_meta ) = @_;
394 my $new_self = $new_meta->reinitialize(
396 attribute_metaclass => $new_meta->attribute_metaclass,
397 method_metaclass => $new_meta->method_metaclass,
398 instance_metaclass => $new_meta->instance_metaclass,
401 $new_self->$_( $new_meta->$_ )
402 for qw( constructor_class destructor_class error_class );
406 bless $self, ref $new_self;
408 # We need to replace the cached metaclass instance or else when it
409 # goes out of scope Class::MOP::Class destroy's the namespace for
410 # the metaclass's class, causing much havoc.
411 Class::MOP::store_metaclass_by_name( $self->name, $self );
412 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
415 # In the more complex case, we share a common ancestor with our
416 # superclass's metaclass, but each metaclass (ours and the parent's)
417 # has a different set of roles applied. We reconcile this by first
418 # reinitializing into the parent class, and _then_ applying our own
420 sub _all_metaclasses_differ_by_roles_only {
421 my ($self, $super_meta) = @_;
424 [ ref $self, ref $super_meta ],
425 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
428 next if $pair->[0] eq $pair->[1];
430 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
431 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
434 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
436 return unless $common_ancestor;
439 unless _is_role_only_subclass_of(
443 && _is_role_only_subclass_of(
452 # This, and some other functions, could be called as methods, but
453 # they're not for two reasons. One, we just end up ignoring the first
454 # argument, because we can't call these directly on one of the real
455 # arguments, because one of them could be a Class::MOP::Class object
456 # and not a Moose::Meta::Class. Second, only a completely insane
457 # person would attempt to subclass this stuff!
458 sub _find_common_ancestor {
459 my ($meta1, $meta2) = @_;
461 # FIXME? This doesn't account for multiple inheritance (not sure
462 # if it needs to though). For example, is somewhere in $meta1's
463 # history it inherits from both ClassA and ClassB, and $meta2
464 # inherits from ClassB & ClassA, does it matter? And what crazy
465 # fool would do that anyway?
467 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
469 return first { $meta1_parents{$_} } $meta2->linearized_isa;
472 sub _is_role_only_subclass_of {
473 my ($meta, $ancestor) = @_;
475 return 1 if $meta->name eq $ancestor;
477 my @roles = _all_roles_until( $meta, $ancestor );
479 my %role_packages = map { $_->name => 1 } @roles;
481 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
483 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
485 for my $method ( $meta->get_all_methods() ) {
486 next if $method->name eq 'meta';
487 next if $method->can('associated_attribute');
490 if $role_packages{ $method->original_package_name }
491 || $shared_ancestors{ $method->original_package_name };
496 # FIXME - this really isn't right. Just because an attribute is
497 # defined in a role doesn't mean it isn't _also_ defined in the
499 for my $attr ( $meta->get_all_attributes ) {
500 next if $shared_ancestors{ $attr->associated_class->name };
502 next if any { $_->has_attribute( $attr->name ) } @roles;
513 return _all_roles_until($meta);
516 sub _all_roles_until {
517 my ($meta, $stop_at_class) = @_;
519 return unless $meta->can('calculate_all_roles');
521 my @roles = $meta->calculate_all_roles;
523 for my $class ( $meta->linearized_isa ) {
524 last if $stop_at_class && $stop_at_class eq $class;
526 my $meta = Class::MOP::Class->initialize($class);
527 last unless $meta->can('calculate_all_roles');
529 push @roles, $meta->calculate_all_roles;
535 sub _reconcile_role_differences {
536 my ($self, $super_meta) = @_;
538 my $self_meta = Class::MOP::class_of($self);
542 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
543 $roles{metaclass_roles} = \@roles;
546 for my $thing (@MetaClassTypes) {
547 my $name = $self->$thing();
549 my $thing_meta = Class::MOP::Class->initialize($name);
551 my @roles = map { $_->name } _all_roles($thing_meta)
554 $roles{ $thing . '_roles' } = \@roles;
557 $self->_reinitialize_with($super_meta);
559 Moose::Util::MetaRole::apply_metaclass_roles(
560 for_class => $self->name,
567 sub _process_attribute {
568 my ( $self, $name, @args ) = @_;
570 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
572 if (($name || '') =~ /^\+(.*)/) {
573 return $self->_process_inherited_attribute($1, @args);
576 return $self->_process_new_attribute($name, @args);
580 sub _process_new_attribute {
581 my ( $self, $name, @args ) = @_;
583 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
586 sub _process_inherited_attribute {
587 my ($self, $attr_name, %options) = @_;
588 my $inherited_attr = $self->find_attribute_by_name($attr_name);
589 (defined $inherited_attr)
590 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
591 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
592 return $inherited_attr->clone_and_inherit_options(%options);
596 # kind of a kludge to handle Class::MOP::Attributes
597 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
601 ## -------------------------------------------------
606 my ( $self, @args ) = @_;
607 local $error_level = ($error_level || 0) + 1;
608 $self->raise_error($self->create_error(@args));
612 my ( $self, @args ) = @_;
617 my ( $self, @args ) = @_;
621 local $error_level = ($error_level || 0 ) + 1;
623 if ( @args % 2 == 1 ) {
624 unshift @args, "message";
627 my %args = ( metaclass => $self, last_error => $@, @args );
629 $args{depth} += $error_level;
631 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
633 Class::MOP::load_class($class);
636 Carp::caller_info($args{depth}),
649 Moose::Meta::Class - The Moose metaclass
653 This class is a subclass of L<Class::MOP::Class> that provides
654 additional Moose-specific functionality.
656 To really understand this class, you will need to start with the
657 L<Class::MOP::Class> documentation. This class can be understood as a
658 set of additional features on top of the basic feature provided by
663 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
669 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
671 This overrides the parent's method in order to provide its own
672 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
673 C<method_metaclass> options.
675 These all default to the appropriate Moose class.
677 =item B<< Moose::Meta::Class->create($package_name, %options) >>
679 This overrides the parent's method in order to accept a C<roles>
680 option. This should be an array reference containing roles
681 that the class does, each optionally followed by a hashref of options
682 (C<-excludes> and C<-alias>).
684 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
686 =item B<< Moose::Meta::Class->create_anon_class >>
688 This overrides the parent's method to accept a C<roles> option, just
691 It also accepts a C<cache> option. If this is true, then the anonymous
692 class will be cached based on its superclasses and roles. If an
693 existing anonymous class in the cache has the same superclasses and
694 roles, it will be reused.
696 my $metaclass = Moose::Meta::Class->create_anon_class(
697 superclasses => ['Foo'],
698 roles => [qw/Some Roles Go Here/],
702 =item B<< $metaclass->make_immutable(%options) >>
704 This overrides the parent's method to add a few options. Specifically,
705 it uses the Moose-specific constructor and destructor classes, and
706 enables inlining the destructor.
708 Also, since Moose always inlines attributes, it sets the
709 C<inline_accessors> option to false.
711 =item B<< $metaclass->new_object(%params) >>
713 This overrides the parent's method in order to add support for
716 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
718 This adds an C<override> method modifier to the package.
720 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
722 This adds an C<augment> method modifier to the package.
724 =item B<< $metaclass->calculate_all_roles >>
726 This will return a unique array of C<Moose::Meta::Role> instances
727 which are attached to this class.
729 =item B<< $metaclass->add_role($role) >>
731 This takes a L<Moose::Meta::Role> object, and adds it to the class's
732 list of roles. This I<does not> actually apply the role to the class.
734 =item B<< $metaclass->role_applications >>
736 Returns a list of L<Moose::Meta::Role::Application::ToClass>
737 objects, which contain the arguments to role application.
739 =item B<< $metaclass->add_role_application($application) >>
741 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
742 adds it to the class's list of role applications. This I<does not>
743 actually apply any role to the class; it is only for tracking role
746 =item B<< $metaclass->does_role($role) >>
748 This returns a boolean indicating whether or not the class does the specified
749 role. The role provided can be either a role name or a L<Moose::Meta::Role>
750 object. This tests both the class and its parents.
752 =item B<< $metaclass->excludes_role($role_name) >>
754 A class excludes a role if it has already composed a role which
755 excludes the named role. This tests both the class and its parents.
757 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
759 This overrides the parent's method in order to allow the parameters to
760 be provided as a hash reference.
762 =item B<< $metaclass->constructor_class ($class_name) >>
764 =item B<< $metaclass->destructor_class ($class_name) >>
766 These are the names of classes used when making a class
767 immutable. These default to L<Moose::Meta::Method::Constructor> and
768 L<Moose::Meta::Method::Destructor> respectively. These accessors are
769 read-write, so you can use them to change the class name.
771 =item B<< $metaclass->error_class($class_name) >>
773 The name of the class used to throw errors. This defaults to
774 L<Moose::Error::Default>, which generates an error with a stacktrace
775 just like C<Carp::confess>.
777 =item B<< $metaclass->throw_error($message, %extra) >>
779 Throws the error created by C<create_error> using C<raise_error>
785 See L<Moose/BUGS> for details on reporting bugs.
789 Stevan Little E<lt>stevan@iinteractive.comE<gt>
791 =head1 COPYRIGHT AND LICENSE
793 Copyright 2006-2010 by Infinity Interactive, Inc.
795 L<http://www.iinteractive.com>
797 This library is free software; you can redistribute it and/or modify
798 it under the same terms as Perl itself.