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.05';
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 my @roles = $meta->can('calculate_all_roles_with_inheritance')
405 ? $meta->calculate_all_roles_with_inheritance
408 # loop over all methods that are a part of the current class
410 for my $method (map { $meta->get_method($_) } $meta->get_method_list) {
412 next if $method->name eq 'meta';
413 # we'll deal with attributes below
414 next if $method->can('associated_attribute');
415 # if the method comes from a role we consumed, ignore it
416 next if $meta->can('does_role')
417 && $meta->does_role($method->original_package_name);
418 # FIXME - this really isn't right. Just because a modifier is
419 # defined in a role doesn't mean it isn't _also_ defined in the
421 next if $method->isa('Class::MOP::Method::Wrapped')
423 (!scalar($method->around_modifiers)
424 || any { $_->has_around_method_modifiers($method->name) } @roles)
425 && (!scalar($method->before_modifiers)
426 || any { $_->has_before_method_modifiers($method->name) } @roles)
427 && (!scalar($method->after_modifiers)
428 || any { $_->has_after_method_modifiers($method->name) } @roles)
434 # loop over all attributes that are a part of the current class
436 # FIXME - this really isn't right. Just because an attribute is
437 # defined in a role doesn't mean it isn't _also_ defined in the
439 for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
440 next if any { $_->has_attribute($attr->name) } @roles;
448 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
450 my ($super_meta) = @_;
452 my $super_meta_name = $super_meta->_real_ref_name;
454 return $self->_classes_differ_by_roles_only(
457 'Moose::Meta::Class',
461 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
463 my ($metaclass_type, $super_meta) = @_;
465 my $class_specific_meta_name = $self->$metaclass_type;
466 return unless $super_meta->can($metaclass_type);
467 my $super_specific_meta_name = $super_meta->$metaclass_type;
468 my %metaclasses = $self->_base_metaclasses;
470 return $self->_classes_differ_by_roles_only(
471 $class_specific_meta_name,
472 $super_specific_meta_name,
473 $metaclasses{$metaclass_type},
477 sub _classes_differ_by_roles_only {
479 my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
482 = $self->_find_common_base( $self_meta_name, $super_meta_name );
484 # If they're not both moose metaclasses, and the cmop fixing couldn't do
485 # anything, there's nothing more we can do. The $expected_ancestor should
486 # always be a Moose metaclass name like Moose::Meta::Class or
487 # Moose::Meta::Attribute.
488 return unless defined $common_base_name;
489 return unless $common_base_name->isa($expected_ancestor);
491 my @super_meta_name_ancestor_names
492 = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
493 my @class_meta_name_ancestor_names
494 = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
497 unless all { $self->_is_role_only_subclass($_) }
498 @super_meta_name_ancestor_names,
499 @class_meta_name_ancestor_names;
504 sub _role_differences {
506 my ($class_meta_name, $super_meta_name) = @_;
507 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
508 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
510 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
511 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
514 for my $role_meta (@role_metas) {
515 push @differences, $role_meta
516 unless any { $_->name eq $role_meta->name } @super_role_metas;
521 sub _reconcile_roles_for_metaclass {
523 my ($class_meta_name, $super_meta_name) = @_;
525 my @role_differences = $self->_role_differences(
526 $class_meta_name, $super_meta_name,
528 return Moose::Meta::Class->create_anon_class(
529 superclasses => [$super_meta_name],
530 roles => \@role_differences,
535 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
537 my ($super_meta) = @_;
539 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
541 my %base_metaclass = $self->_base_metaclasses;
542 for my $metaclass_type (keys %base_metaclass) {
543 next unless defined $self->$metaclass_type;
544 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
550 sub _can_fix_metaclass_incompatibility {
552 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
553 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
556 sub _fix_class_metaclass_incompatibility {
558 my ($super_meta) = @_;
560 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
562 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
564 || confess "Can't fix metaclass incompatibility for "
566 . " because it is not pristine.";
567 my $super_meta_name = $super_meta->_real_ref_name;
568 my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
569 my $new_self = $class_meta_subclass_meta->name->reinitialize(
573 $self->_replace_self( $new_self, $class_meta_subclass_meta->name );
577 sub _fix_single_metaclass_incompatibility {
579 my ($metaclass_type, $super_meta) = @_;
581 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
583 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
585 || confess "Can't fix metaclass incompatibility for "
587 . " because it is not pristine.";
588 my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
589 my $new_self = $super_meta->reinitialize(
591 $metaclass_type => $class_specific_meta_subclass_meta->name,
594 $self->_replace_self( $new_self, blessed($super_meta) );
601 my ( $new_self, $new_class) = @_;
604 bless $self, $new_class;
606 # We need to replace the cached metaclass instance or else when it goes
607 # out of scope Class::MOP::Class destroy's the namespace for the
608 # metaclass's class, causing much havoc.
609 Class::MOP::store_metaclass_by_name( $self->name, $self );
610 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
613 sub _process_attribute {
614 my ( $self, $name, @args ) = @_;
616 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
618 if (($name || '') =~ /^\+(.*)/) {
619 return $self->_process_inherited_attribute($1, @args);
622 return $self->_process_new_attribute($name, @args);
626 sub _process_new_attribute {
627 my ( $self, $name, @args ) = @_;
629 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
632 sub _process_inherited_attribute {
633 my ($self, $attr_name, %options) = @_;
634 my $inherited_attr = $self->find_attribute_by_name($attr_name);
635 (defined $inherited_attr)
636 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
637 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
638 return $inherited_attr->clone_and_inherit_options(%options);
642 # kind of a kludge to handle Class::MOP::Attributes
643 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
647 ## -------------------------------------------------
652 my ( $self, @args ) = @_;
653 local $error_level = ($error_level || 0) + 1;
654 $self->raise_error($self->create_error(@args));
658 my ( $self, @args ) = @_;
663 my ( $self, @args ) = @_;
667 local $error_level = ($error_level || 0 ) + 1;
669 if ( @args % 2 == 1 ) {
670 unshift @args, "message";
673 my %args = ( metaclass => $self, last_error => $@, @args );
675 $args{depth} += $error_level;
677 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
679 Class::MOP::load_class($class);
682 Carp::caller_info($args{depth}),
695 Moose::Meta::Class - The Moose metaclass
699 This class is a subclass of L<Class::MOP::Class> that provides
700 additional Moose-specific functionality.
702 To really understand this class, you will need to start with the
703 L<Class::MOP::Class> documentation. This class can be understood as a
704 set of additional features on top of the basic feature provided by
709 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
715 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
717 This overrides the parent's method in order to provide its own
718 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
719 C<method_metaclass> options.
721 These all default to the appropriate Moose class.
723 =item B<< Moose::Meta::Class->create($package_name, %options) >>
725 This overrides the parent's method in order to accept a C<roles>
726 option. This should be an array reference containing roles
727 that the class does, each optionally followed by a hashref of options
728 (C<-excludes> and C<-alias>).
730 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
732 =item B<< Moose::Meta::Class->create_anon_class >>
734 This overrides the parent's method to accept a C<roles> option, just
737 It also accepts a C<cache> option. If this is true, then the anonymous
738 class will be cached based on its superclasses and roles. If an
739 existing anonymous class in the cache has the same superclasses and
740 roles, it will be reused.
742 my $metaclass = Moose::Meta::Class->create_anon_class(
743 superclasses => ['Foo'],
744 roles => [qw/Some Roles Go Here/],
748 Each entry in both the C<superclasses> and the C<roles> option can be
749 followed by a hash reference with arguments. The C<superclasses>
750 option can be supplied with a L<-version|Class::MOP/Class Loading
751 Options> option that ensures the loaded superclass satisfies the
752 required version. The C<role> option also takes the C<-version> as an
753 argument, but the option hash reference can also contain any other
754 role relevant values like exclusions or parameterized role arguments.
756 =item B<< $metaclass->make_immutable(%options) >>
758 This overrides the parent's method to add a few options. Specifically,
759 it uses the Moose-specific constructor and destructor classes, and
760 enables inlining the destructor.
762 Also, since Moose always inlines attributes, it sets the
763 C<inline_accessors> option to false.
765 =item B<< $metaclass->new_object(%params) >>
767 This overrides the parent's method in order to add support for
770 =item B<< $metaclass->superclasses(@superclasses) >>
772 This is the accessor allowing you to read or change the parents of
775 Each superclass can be followed by a hash reference containing a
776 L<-version|Class::MOP/Class Loading Options> value. If the version
777 requirement is not satisfied an error will be thrown.
779 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
781 This adds an C<override> method modifier to the package.
783 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
785 This adds an C<augment> method modifier to the package.
787 =item B<< $metaclass->calculate_all_roles >>
789 This will return a unique array of C<Moose::Meta::Role> instances
790 which are attached to this class.
792 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
794 This will return a unique array of C<Moose::Meta::Role> instances
795 which are attached to this class, and each of this class's ancestors.
797 =item B<< $metaclass->add_role($role) >>
799 This takes a L<Moose::Meta::Role> object, and adds it to the class's
800 list of roles. This I<does not> actually apply the role to the class.
802 =item B<< $metaclass->role_applications >>
804 Returns a list of L<Moose::Meta::Role::Application::ToClass>
805 objects, which contain the arguments to role application.
807 =item B<< $metaclass->add_role_application($application) >>
809 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
810 adds it to the class's list of role applications. This I<does not>
811 actually apply any role to the class; it is only for tracking role
814 =item B<< $metaclass->does_role($role) >>
816 This returns a boolean indicating whether or not the class does the specified
817 role. The role provided can be either a role name or a L<Moose::Meta::Role>
818 object. This tests both the class and its parents.
820 =item B<< $metaclass->excludes_role($role_name) >>
822 A class excludes a role if it has already composed a role which
823 excludes the named role. This tests both the class and its parents.
825 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
827 This overrides the parent's method in order to allow the parameters to
828 be provided as a hash reference.
830 =item B<< $metaclass->constructor_class($class_name) >>
832 =item B<< $metaclass->destructor_class($class_name) >>
834 These are the names of classes used when making a class
835 immutable. These default to L<Moose::Meta::Method::Constructor> and
836 L<Moose::Meta::Method::Destructor> respectively. These accessors are
837 read-write, so you can use them to change the class name.
839 =item B<< $metaclass->error_class($class_name) >>
841 The name of the class used to throw errors. This defaults to
842 L<Moose::Error::Default>, which generates an error with a stacktrace
843 just like C<Carp::confess>.
845 =item B<< $metaclass->throw_error($message, %extra) >>
847 Throws the error created by C<create_error> using C<raise_error>
853 See L<Moose/BUGS> for details on reporting bugs.
857 Stevan Little E<lt>stevan@iinteractive.comE<gt>
859 =head1 COPYRIGHT AND LICENSE
861 Copyright 2006-2010 by Infinity Interactive, Inc.
863 L<http://www.iinteractive.com>
865 This library is free software; you can redistribute it and/or modify
866 it under the same terms as Perl itself.