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, $until) = @_;
375 for my $ancestor (Class::MOP::class_of($start)->linearized_isa) {
376 last if $ancestor eq $until;
377 push @ancestors, $ancestor;
382 sub _is_role_only_subclass {
385 my $meta = Class::MOP::Class->initialize($class);
386 my @parents = $meta->superclasses;
388 # XXX: don't feel like messing with multiple inheritance here... what would
390 return unless @parents == 1;
391 my ($parent) = @parents;
392 my $parent_meta = Class::MOP::Class->initialize($parent);
394 # loop over all methods that are a part of the current class
396 for my $method (map { $meta->meta->get_method($_) } $meta->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->meta->can('does_role')
403 && $meta->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->meta->get_attribute($_) } $meta->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 = $self->_find_common_base($self, $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);
434 return unless $common_base->isa('Moose::Meta::Class');
436 my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base);
437 my @ancestors = $self->_get_ancestors_until($self, $common_base);
438 # we're only dealing with roles here
439 return unless all { $self->_is_role_only_subclass($_) }
440 (@superclass_ancestors, @ancestors);
445 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
447 my ($metaclass_type, $super_metaclass) = @_;
449 my $meta = $self->$metaclass_type;
450 return unless $super_metaclass->can($metaclass_type);
451 my $super_meta = $super_metaclass->$metaclass_type;
452 my %metaclasses = $self->_base_metaclasses;
454 my $common_base = $self->_find_common_base($meta, $super_meta);
455 # if they're not both moose metaclasses, and the cmop fixing couldn't
456 # do anything, there's nothing more we can do
457 return unless defined($common_base);
458 return unless $common_base->isa($metaclasses{$metaclass_type});
460 my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base);
461 my @ancestors = $self->_get_ancestors_until($meta, $common_base);
462 # we're only dealing with roles here
463 return unless all { $self->_is_role_only_subclass($_) }
464 (@superclass_ancestors, @ancestors);
469 sub _role_differences {
471 my ($meta, $super_meta) = @_;
472 my @super_roles = $super_meta->meta->calculate_all_roles;
473 my @roles = $meta->meta->calculate_all_roles;
475 for my $role (@super_roles) {
476 push @differences, $role unless any { $_->name eq $role->name } @roles;
481 sub _reconcile_roles_for_metaclass {
483 my ($meta, $super_meta, $base_class) = @_;
485 my @role_differences = $self->_role_differences($meta, $super_meta);
486 return $self->meta->create_anon_class(
487 superclasses => [$super_meta],
488 roles => \@role_differences,
493 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
495 my ($super_meta) = @_;
497 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
499 my %base_metaclass = $self->_base_metaclasses;
500 for my $metaclass_type (keys %base_metaclass) {
501 next unless defined $self->$metaclass_type;
502 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
508 sub _can_fix_metaclass_incompatibility {
510 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
511 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
514 sub _fix_class_metaclass_incompatibility {
516 my ($super_meta) = @_;
518 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
520 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
521 my $subclass = $self->_reconcile_roles_for_metaclass($self, $super_meta, 'Moose::Meta::Class');
522 $subclass->meta->rebless_instace($self);
526 sub _fix_single_metaclass_incompatibility {
528 my ($metaclass_type, $super_meta) = @_;
530 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
532 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
533 my %metaclasses = $self->_base_metaclasses;
534 my $subclass = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type, $metaclasses{$metaclass_type});
535 $self->$metaclass_type($subclass->name);
539 sub _process_attribute {
540 my ( $self, $name, @args ) = @_;
542 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
544 if (($name || '') =~ /^\+(.*)/) {
545 return $self->_process_inherited_attribute($1, @args);
548 return $self->_process_new_attribute($name, @args);
552 sub _process_new_attribute {
553 my ( $self, $name, @args ) = @_;
555 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
558 sub _process_inherited_attribute {
559 my ($self, $attr_name, %options) = @_;
560 my $inherited_attr = $self->find_attribute_by_name($attr_name);
561 (defined $inherited_attr)
562 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
563 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
564 return $inherited_attr->clone_and_inherit_options(%options);
568 # kind of a kludge to handle Class::MOP::Attributes
569 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
573 ## -------------------------------------------------
578 my ( $self, @args ) = @_;
579 local $error_level = ($error_level || 0) + 1;
580 $self->raise_error($self->create_error(@args));
584 my ( $self, @args ) = @_;
589 my ( $self, @args ) = @_;
593 local $error_level = ($error_level || 0 ) + 1;
595 if ( @args % 2 == 1 ) {
596 unshift @args, "message";
599 my %args = ( metaclass => $self, last_error => $@, @args );
601 $args{depth} += $error_level;
603 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
605 Class::MOP::load_class($class);
608 Carp::caller_info($args{depth}),
621 Moose::Meta::Class - The Moose metaclass
625 This class is a subclass of L<Class::MOP::Class> that provides
626 additional Moose-specific functionality.
628 To really understand this class, you will need to start with the
629 L<Class::MOP::Class> documentation. This class can be understood as a
630 set of additional features on top of the basic feature provided by
635 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
641 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
643 This overrides the parent's method in order to provide its own
644 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
645 C<method_metaclass> options.
647 These all default to the appropriate Moose class.
649 =item B<< Moose::Meta::Class->create($package_name, %options) >>
651 This overrides the parent's method in order to accept a C<roles>
652 option. This should be an array reference containing roles
653 that the class does, each optionally followed by a hashref of options
654 (C<-excludes> and C<-alias>).
656 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
658 =item B<< Moose::Meta::Class->create_anon_class >>
660 This overrides the parent's method to accept a C<roles> option, just
663 It also accepts a C<cache> option. If this is true, then the anonymous
664 class will be cached based on its superclasses and roles. If an
665 existing anonymous class in the cache has the same superclasses and
666 roles, it will be reused.
668 my $metaclass = Moose::Meta::Class->create_anon_class(
669 superclasses => ['Foo'],
670 roles => [qw/Some Roles Go Here/],
674 Each entry in both the C<superclasses> and the C<roles> option can be
675 followed by a hash reference with arguments. The C<superclasses>
676 option can be supplied with a L<-version|Class::MOP/Class Loading
677 Options> option that ensures the loaded superclass satisfies the
678 required version. The C<role> option also takes the C<-version> as an
679 argument, but the option hash reference can also contain any other
680 role relevant values like exclusions or parameterized role arguments.
682 =item B<< $metaclass->make_immutable(%options) >>
684 This overrides the parent's method to add a few options. Specifically,
685 it uses the Moose-specific constructor and destructor classes, and
686 enables inlining the destructor.
688 Also, since Moose always inlines attributes, it sets the
689 C<inline_accessors> option to false.
691 =item B<< $metaclass->new_object(%params) >>
693 This overrides the parent's method in order to add support for
696 =item B<< $metaclass->superclasses(@superclasses) >>
698 This is the accessor allowing you to read or change the parents of
701 Each superclass can be followed by a hash reference containing a
702 L<-version|Class::MOP/Class Loading Options> value. If the version
703 requirement is not satisfied an error will be thrown.
705 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
707 This adds an C<override> method modifier to the package.
709 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
711 This adds an C<augment> method modifier to the package.
713 =item B<< $metaclass->calculate_all_roles >>
715 This will return a unique array of C<Moose::Meta::Role> instances
716 which are attached to this class.
718 =item B<< $metaclass->add_role($role) >>
720 This takes a L<Moose::Meta::Role> object, and adds it to the class's
721 list of roles. This I<does not> actually apply the role to the class.
723 =item B<< $metaclass->role_applications >>
725 Returns a list of L<Moose::Meta::Role::Application::ToClass>
726 objects, which contain the arguments to role application.
728 =item B<< $metaclass->add_role_application($application) >>
730 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
731 adds it to the class's list of role applications. This I<does not>
732 actually apply any role to the class; it is only for tracking role
735 =item B<< $metaclass->does_role($role) >>
737 This returns a boolean indicating whether or not the class does the specified
738 role. The role provided can be either a role name or a L<Moose::Meta::Role>
739 object. This tests both the class and its parents.
741 =item B<< $metaclass->excludes_role($role_name) >>
743 A class excludes a role if it has already composed a role which
744 excludes the named role. This tests both the class and its parents.
746 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
748 This overrides the parent's method in order to allow the parameters to
749 be provided as a hash reference.
751 =item B<< $metaclass->constructor_class($class_name) >>
753 =item B<< $metaclass->destructor_class($class_name) >>
755 These are the names of classes used when making a class
756 immutable. These default to L<Moose::Meta::Method::Constructor> and
757 L<Moose::Meta::Method::Destructor> respectively. These accessors are
758 read-write, so you can use them to change the class name.
760 =item B<< $metaclass->error_class($class_name) >>
762 The name of the class used to throw errors. This defaults to
763 L<Moose::Error::Default>, which generates an error with a stacktrace
764 just like C<Carp::confess>.
766 =item B<< $metaclass->throw_error($message, %extra) >>
768 Throws the error created by C<create_error> using C<raise_error>
774 See L<Moose/BUGS> for details on reporting bugs.
778 Stevan Little E<lt>stevan@iinteractive.comE<gt>
780 =head1 COPYRIGHT AND LICENSE
782 Copyright 2006-2010 by Infinity Interactive, Inc.
784 L<http://www.iinteractive.com>
786 This library is free software; you can redistribute it and/or modify
787 it under the same terms as Perl itself.