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.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 };
204 my ($self, $role_name) = @_;
207 || $self->throw_error("You must supply a role name to look for");
209 foreach my $class ($self->class_precedence_list) {
210 my $meta = Class::MOP::class_of($class);
211 # when a Moose metaclass is itself extended with a role,
212 # this check needs to be done since some items in the
213 # class_precedence_list might in fact be Class::MOP
215 next unless $meta && $meta->can('roles');
216 foreach my $role (@{$meta->roles}) {
217 return 1 if $role->does_role($role_name);
224 my ($self, $role_name) = @_;
227 || $self->throw_error("You must supply a role name to look for");
229 foreach my $class ($self->class_precedence_list) {
230 my $meta = Class::MOP::class_of($class);
231 # when a Moose metaclass is itself extended with a role,
232 # this check needs to be done since some items in the
233 # class_precedence_list might in fact be Class::MOP
235 next unless $meta && $meta->can('roles');
236 foreach my $role (@{$meta->roles}) {
237 return 1 if $role->excludes_role($role_name);
245 my $params = @_ == 1 ? $_[0] : {@_};
246 my $object = $self->SUPER::new_object($params);
248 foreach my $attr ( $self->get_all_attributes() ) {
250 next unless $attr->can('has_trigger') && $attr->has_trigger;
252 my $init_arg = $attr->init_arg;
254 next unless defined $init_arg;
256 next unless exists $params->{$init_arg};
262 ? $attr->get_read_method_ref->($object)
263 : $params->{$init_arg}
268 $object->BUILDALL($params) if $object->can('BUILDALL');
275 my $supers = Data::OptList::mkopt(\@_);
276 foreach my $super (@{ $supers }) {
277 my ($name, $opts) = @{ $super };
278 Class::MOP::load_class($name, $opts);
279 my $meta = Class::MOP::class_of($name);
280 $self->throw_error("You cannot inherit from a Moose Role ($name)")
281 if $meta && $meta->isa('Moose::Meta::Role')
283 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
286 ### ---------------------------------------------
291 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
293 : $self->_process_attribute(@_));
294 $self->SUPER::add_attribute($attr);
295 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
296 # 'bare' and doesn't implement this method
297 if ($attr->can('_check_associated_methods')) {
298 $attr->_check_associated_methods;
303 sub add_override_method_modifier {
304 my ($self, $name, $method, $_super_package) = @_;
306 (!$self->has_method($name))
307 || $self->throw_error("Cannot add an override method if a local method is already present");
309 $self->add_method($name => Moose::Meta::Method::Overridden->new(
312 package => $_super_package, # need this for roles
317 sub add_augment_method_modifier {
318 my ($self, $name, $method) = @_;
319 (!$self->has_method($name))
320 || $self->throw_error("Cannot add an augment method if a local method is already present");
322 $self->add_method($name => Moose::Meta::Method::Augmented->new(
329 ## Private Utility methods ...
331 sub _find_next_method_by_name_which_is_not_overridden {
332 my ($self, $name) = @_;
333 foreach my $method ($self->find_all_methods_by_name($name)) {
334 return $method->{code}
335 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
340 ## Metaclass compatibility
342 sub _base_metaclasses {
344 my %metaclasses = $self->SUPER::_base_metaclasses;
345 for my $class (keys %metaclasses) {
346 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
350 error_class => 'Moose::Error::Default',
354 sub _find_common_base {
356 my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
357 return unless defined($meta1) && defined($meta2);
359 # FIXME? This doesn't account for multiple inheritance (not sure
360 # if it needs to though). For example, is somewhere in $meta1's
361 # history it inherits from both ClassA and ClassB, and $meta2
362 # inherits from ClassB & ClassA, does it matter? And what crazy
363 # fool would do that anyway?
365 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
367 return first { $meta1_parents{$_} } $meta2->linearized_isa;
370 sub _get_ancestors_until {
372 my ($start_name, $until_name) = @_;
375 for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
376 last if $ancestor_name eq $until_name;
377 push @ancestor_names, $ancestor_name;
379 return @ancestor_names;
382 sub _is_role_only_subclass {
384 my ($meta_name) = @_;
385 my $meta = Class::MOP::Class->initialize($meta_name);
386 my @parent_names = $meta->superclasses;
388 # XXX: don't feel like messing with multiple inheritance here... what would
390 return unless @parent_names == 1;
391 my ($parent_name) = @parent_names;
392 my $parent_meta = Class::MOP::Class->initialize($parent_name);
394 # loop over all methods that are a part of the current class
396 for my $method (map { $meta->get_method($_) } $meta->get_method_list) {
398 next if $method->name eq 'meta';
399 # we'll deal with attributes below
400 next if $method->isa('Class::MOP::Method::Accessor');
401 # if the method comes from a role we consumed, ignore it
402 next if $meta->can('does_role')
403 && $meta->does_role($method->original_package_name);
408 # loop over all attributes that are a part of the current class
410 # FIXME - this really isn't right. Just because an attribute is
411 # defined in a role doesn't mean it isn't _also_ defined in the
413 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
414 next if any { $_->has_attribute($attr->name) }
415 map { $_->meta->can('calculate_all_roles')
416 ? $_->meta->calculate_all_roles
418 $meta->linearized_isa;
426 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
428 my ($super_meta) = @_;
430 my $common_base_name = $self->_find_common_base(blessed($self), blessed($super_meta));
431 # if they're not both moose metaclasses, and the cmop fixing couldn't
432 # do anything, there's nothing more we can do
433 return unless defined($common_base_name);
434 return unless $common_base_name->isa('Moose::Meta::Class');
436 my @super_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($super_meta), $common_base_name);
437 my @class_meta_name_ancestor_names = $self->_get_ancestors_until(blessed($self), $common_base_name);
438 # we're only dealing with roles here
439 return unless all { $self->_is_role_only_subclass($_) }
440 (@super_meta_name_ancestor_names,
441 @class_meta_name_ancestor_names);
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 my $common_base_name = $self->_find_common_base($class_specific_meta_name, $super_specific_meta_name);
456 # if they're not both moose metaclasses, and the cmop fixing couldn't
457 # do anything, there's nothing more we can do
458 return unless defined($common_base_name);
459 return unless $common_base_name->isa($metaclasses{$metaclass_type});
461 my @super_specific_meta_name_ancestor_names = $self->_get_ancestors_until($super_specific_meta_name, $common_base_name);
462 my @class_specific_meta_name_ancestor_names = $self->_get_ancestors_until($class_specific_meta_name, $common_base_name);
463 # we're only dealing with roles here
464 return unless all { $self->_is_role_only_subclass($_) }
465 (@super_specific_meta_name_ancestor_names,
466 @class_specific_meta_name_ancestor_names);
471 sub _role_differences {
473 my ($class_meta_name, $super_meta_name) = @_;
474 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles')
475 ? $super_meta_name->meta->calculate_all_roles
477 my @role_metas = $class_meta_name->meta->can('calculate_all_roles')
478 ? $class_meta_name->meta->calculate_all_roles
481 for my $role_meta (@role_metas) {
482 push @differences, $role_meta
483 unless any { $_->name eq $role_meta->name } @super_role_metas;
488 sub _reconcile_roles_for_metaclass {
490 my ($class_meta_name, $super_meta_name) = @_;
492 my @role_differences = $self->_role_differences(
493 $class_meta_name, $super_meta_name,
495 return $self->create_anon_class(
496 superclasses => [$super_meta_name],
497 roles => \@role_differences,
502 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
504 my ($super_meta) = @_;
506 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
508 my %base_metaclass = $self->_base_metaclasses;
509 for my $metaclass_type (keys %base_metaclass) {
510 next unless defined $self->$metaclass_type;
511 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
517 sub _can_fix_metaclass_incompatibility {
519 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
520 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
523 sub _fix_class_metaclass_incompatibility {
525 my ($super_meta) = @_;
527 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
529 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
530 my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), blessed($super_meta));
531 my $new_self = $class_meta_subclass_meta->name->reinitialize(
535 bless $self, $class_meta_subclass_meta->name;
536 # We need to replace the cached metaclass instance or else when it
537 # goes out of scope Class::MOP::Class destroy's the namespace for
538 # the metaclass's class, causing much havoc.
539 Class::MOP::store_metaclass_by_name( $self->name, $self );
540 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
544 sub _fix_single_metaclass_incompatibility {
546 my ($metaclass_type, $super_meta) = @_;
548 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
550 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
551 my %metaclasses = $self->_base_metaclasses;
552 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
553 my $new_self = $super_meta->reinitialize(
555 $metaclass_type => $class_specific_meta_subclass_meta->name,
558 bless $self, blessed($super_meta);
559 # We need to replace the cached metaclass instance or else when it
560 # goes out of scope Class::MOP::Class destroy's the namespace for
561 # the metaclass's class, causing much havoc.
562 Class::MOP::store_metaclass_by_name( $self->name, $self );
563 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
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 Each entry in both the C<superclasses> and the C<roles> option can be
703 followed by a hash reference with arguments. The C<superclasses>
704 option can be supplied with a L<-version|Class::MOP/Class Loading
705 Options> option that ensures the loaded superclass satisfies the
706 required version. The C<role> option also takes the C<-version> as an
707 argument, but the option hash reference can also contain any other
708 role relevant values like exclusions or parameterized role arguments.
710 =item B<< $metaclass->make_immutable(%options) >>
712 This overrides the parent's method to add a few options. Specifically,
713 it uses the Moose-specific constructor and destructor classes, and
714 enables inlining the destructor.
716 Also, since Moose always inlines attributes, it sets the
717 C<inline_accessors> option to false.
719 =item B<< $metaclass->new_object(%params) >>
721 This overrides the parent's method in order to add support for
724 =item B<< $metaclass->superclasses(@superclasses) >>
726 This is the accessor allowing you to read or change the parents of
729 Each superclass can be followed by a hash reference containing a
730 L<-version|Class::MOP/Class Loading Options> value. If the version
731 requirement is not satisfied an error will be thrown.
733 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
735 This adds an C<override> method modifier to the package.
737 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
739 This adds an C<augment> method modifier to the package.
741 =item B<< $metaclass->calculate_all_roles >>
743 This will return a unique array of C<Moose::Meta::Role> instances
744 which are attached to this class.
746 =item B<< $metaclass->add_role($role) >>
748 This takes a L<Moose::Meta::Role> object, and adds it to the class's
749 list of roles. This I<does not> actually apply the role to the class.
751 =item B<< $metaclass->role_applications >>
753 Returns a list of L<Moose::Meta::Role::Application::ToClass>
754 objects, which contain the arguments to role application.
756 =item B<< $metaclass->add_role_application($application) >>
758 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
759 adds it to the class's list of role applications. This I<does not>
760 actually apply any role to the class; it is only for tracking role
763 =item B<< $metaclass->does_role($role) >>
765 This returns a boolean indicating whether or not the class does the specified
766 role. The role provided can be either a role name or a L<Moose::Meta::Role>
767 object. This tests both the class and its parents.
769 =item B<< $metaclass->excludes_role($role_name) >>
771 A class excludes a role if it has already composed a role which
772 excludes the named role. This tests both the class and its parents.
774 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
776 This overrides the parent's method in order to allow the parameters to
777 be provided as a hash reference.
779 =item B<< $metaclass->constructor_class($class_name) >>
781 =item B<< $metaclass->destructor_class($class_name) >>
783 These are the names of classes used when making a class
784 immutable. These default to L<Moose::Meta::Method::Constructor> and
785 L<Moose::Meta::Method::Destructor> respectively. These accessors are
786 read-write, so you can use them to change the class name.
788 =item B<< $metaclass->error_class($class_name) >>
790 The name of the class used to throw errors. This defaults to
791 L<Moose::Error::Default>, which generates an error with a stacktrace
792 just like C<Carp::confess>.
794 =item B<< $metaclass->throw_error($message, %extra) >>
796 Throws the error created by C<create_error> using C<raise_error>
802 See L<Moose/BUGS> for details on reporting bugs.
806 Stevan Little E<lt>stevan@iinteractive.comE<gt>
808 =head1 COPYRIGHT AND LICENSE
810 Copyright 2006-2010 by Infinity Interactive, Inc.
812 L<http://www.iinteractive.com>
814 This library is free software; you can redistribute it and/or modify
815 it under the same terms as Perl itself.