2 package Moose::Meta::Class;
10 use List::Util qw( first );
11 use List::MoreUtils qw( any all uniq );
12 use Scalar::Util 'weaken', 'blessed';
14 our $VERSION = '0.77';
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 inline_destructor => 1,
77 # Moose always does this when an attribute is created
78 inline_accessors => 0,
85 my ($self, $package_name, %options) = @_;
87 (ref $options{roles} eq 'ARRAY')
88 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
89 if exists $options{roles};
90 my $roles = delete $options{roles};
92 my $class = $self->SUPER::create($package_name, %options);
95 Moose::Util::apply_all_roles( $class, @$roles );
101 sub _check_metaclass_compatibility {
104 if ( my @supers = $self->superclasses ) {
105 $self->_fix_metaclass_incompatibility(@supers);
108 $self->SUPER::_check_metaclass_compatibility(@_);
113 sub create_anon_class {
114 my ($self, %options) = @_;
116 my $cache_ok = delete $options{cache};
118 # something like Super::Class|Super::Class::2=Role|Role::1
119 my $cache_key = join '=' => (
120 join('|', @{$options{superclasses} || []}),
121 join('|', sort @{$options{roles} || []}),
124 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
125 return $ANON_CLASSES{$cache_key};
128 my $new_class = $self->SUPER::create_anon_class(%options);
130 $ANON_CLASSES{$cache_key} = $new_class
137 my ($self, $role) = @_;
138 (blessed($role) && $role->isa('Moose::Meta::Role'))
139 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
140 push @{$self->roles} => $role;
143 sub role_applications {
146 return @{$self->_get_role_applications};
149 sub add_role_application {
150 my ($self, $application) = @_;
151 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
152 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
153 push @{$self->_get_role_applications} => $application;
156 sub calculate_all_roles {
159 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
163 my ($self, $role_name) = @_;
166 || $self->throw_error("You must supply a role name to look for");
168 foreach my $class ($self->class_precedence_list) {
169 my $meta = Class::MOP::class_of($class);
170 # when a Moose metaclass is itself extended with a role,
171 # this check needs to be done since some items in the
172 # class_precedence_list might in fact be Class::MOP
174 next unless $meta && $meta->can('roles');
175 foreach my $role (@{$meta->roles}) {
176 return 1 if $role->does_role($role_name);
183 my ($self, $role_name) = @_;
186 || $self->throw_error("You must supply a role name to look for");
188 foreach my $class ($self->class_precedence_list) {
189 my $meta = Class::MOP::class_of($class);
190 # when a Moose metaclass is itself extended with a role,
191 # this check needs to be done since some items in the
192 # class_precedence_list might in fact be Class::MOP
194 next unless $meta && $meta->can('roles');
195 foreach my $role (@{$meta->roles}) {
196 return 1 if $role->excludes_role($role_name);
204 my $params = @_ == 1 ? $_[0] : {@_};
205 my $self = $class->SUPER::new_object($params);
207 foreach my $attr ( $class->get_all_attributes() ) {
209 next unless $attr->can('has_trigger') && $attr->has_trigger;
211 my $init_arg = $attr->init_arg;
213 next unless defined $init_arg;
215 next unless exists $params->{$init_arg};
221 ? $attr->get_read_method_ref->($self)
222 : $params->{$init_arg}
230 sub _construct_instance {
232 my $params = @_ == 1 ? $_[0] : {@_};
233 my $meta_instance = $class->get_meta_instance;
235 # the code below is almost certainly incorrect
236 # but this is foreign inheritance, so we might
237 # have to kludge it in the end.
238 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
239 foreach my $attr ($class->get_all_attributes()) {
240 $attr->initialize_instance_slot($meta_instance, $instance, $params);
248 foreach my $super (@supers) {
249 my $meta = Class::MOP::load_class($super);
250 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
251 if $meta && $meta->isa('Moose::Meta::Role')
253 return $self->SUPER::superclasses(@supers);
256 ### ---------------------------------------------
260 $self->SUPER::add_attribute(
261 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
263 : $self->_process_attribute(@_))
267 sub add_override_method_modifier {
268 my ($self, $name, $method, $_super_package) = @_;
270 (!$self->has_method($name))
271 || $self->throw_error("Cannot add an override method if a local method is already present");
273 $self->add_method($name => Moose::Meta::Method::Overridden->new(
276 package => $_super_package, # need this for roles
281 sub add_augment_method_modifier {
282 my ($self, $name, $method) = @_;
283 (!$self->has_method($name))
284 || $self->throw_error("Cannot add an augment method if a local method is already present");
286 $self->add_method($name => Moose::Meta::Method::Augmented->new(
293 ## Private Utility methods ...
295 sub _find_next_method_by_name_which_is_not_overridden {
296 my ($self, $name) = @_;
297 foreach my $method ($self->find_all_methods_by_name($name)) {
298 return $method->{code}
299 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
304 sub _fix_metaclass_incompatibility {
305 my ($self, @superclasses) = @_;
307 foreach my $super (@superclasses) {
308 next if $self->_superclass_meta_is_compatible($super);
310 unless ( $self->is_pristine ) {
312 "Cannot attempt to reinitialize metaclass for "
314 . ", it isn't pristine" );
317 $self->_reconcile_with_superclass_meta($super);
321 sub _superclass_meta_is_compatible {
322 my ($self, $super) = @_;
324 my $super_meta = Class::MOP::Class->initialize($super)
327 next unless $super_meta->isa("Class::MOP::Class");
330 = $super_meta->is_immutable
331 ? $super_meta->get_mutable_metaclass_name
335 if $self->isa($super_meta_name)
337 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
340 # I don't want to have to type this >1 time
342 qw( attribute_metaclass
344 wrapped_method_metaclass
350 sub _reconcile_with_superclass_meta {
351 my ($self, $super) = @_;
353 my $super_meta = Class::MOP::class_of($super);
356 = $super_meta->is_immutable
357 ? $super_meta->get_mutable_metaclass_name
360 my $self_metaclass = ref $self;
362 # If neither of these is true we have a more serious
363 # incompatibility that we just cannot fix (yet?).
364 if ( $super_meta_name->isa( ref $self )
365 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
366 $self->_reinitialize_with($super_meta);
368 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
369 $self->_reconcile_role_differences($super_meta);
373 sub _reinitialize_with {
374 my ( $self, $new_meta ) = @_;
376 my $new_self = $new_meta->reinitialize(
378 attribute_metaclass => $new_meta->attribute_metaclass,
379 method_metaclass => $new_meta->method_metaclass,
380 instance_metaclass => $new_meta->instance_metaclass,
383 $new_self->$_( $new_meta->$_ )
384 for qw( constructor_class destructor_class error_class );
388 bless $self, ref $new_self;
390 # We need to replace the cached metaclass instance or else when it
391 # goes out of scope Class::MOP::Class destroy's the namespace for
392 # the metaclass's class, causing much havoc.
393 Class::MOP::store_metaclass_by_name( $self->name, $self );
394 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
397 # In the more complex case, we share a common ancestor with our
398 # superclass's metaclass, but each metaclass (ours and the parent's)
399 # has a different set of roles applied. We reconcile this by first
400 # reinitializing into the parent class, and _then_ applying our own
402 sub _all_metaclasses_differ_by_roles_only {
403 my ($self, $super_meta) = @_;
406 [ ref $self, ref $super_meta ],
407 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
410 next if $pair->[0] eq $pair->[1];
412 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
413 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
416 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
418 return unless $common_ancestor;
421 unless _is_role_only_subclass_of(
425 && _is_role_only_subclass_of(
434 # This, and some other functions, could be called as methods, but
435 # they're not for two reasons. One, we just end up ignoring the first
436 # argument, because we can't call these directly on one of the real
437 # arguments, because one of them could be a Class::MOP::Class object
438 # and not a Moose::Meta::Class. Second, only a completely insane
439 # person would attempt to subclass this stuff!
440 sub _find_common_ancestor {
441 my ($meta1, $meta2) = @_;
443 # FIXME? This doesn't account for multiple inheritance (not sure
444 # if it needs to though). For example, is somewhere in $meta1's
445 # history it inherits from both ClassA and ClassB, and $meta2
446 # inherits from ClassB & ClassA, does it matter? And what crazy
447 # fool would do that anyway?
449 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
451 return first { $meta1_parents{$_} } $meta2->linearized_isa;
454 sub _is_role_only_subclass_of {
455 my ($meta, $ancestor) = @_;
457 return 1 if $meta->name eq $ancestor;
459 my @roles = _all_roles_until( $meta, $ancestor );
461 my %role_packages = map { $_->name => 1 } @roles;
463 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
465 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
467 for my $method ( $meta->get_all_methods() ) {
468 next if $method->name eq 'meta';
469 next if $method->can('associated_attribute');
472 if $role_packages{ $method->original_package_name }
473 || $shared_ancestors{ $method->original_package_name };
478 # FIXME - this really isn't right. Just because an attribute is
479 # defined in a role doesn't mean it isn't _also_ defined in the
481 for my $attr ( $meta->get_all_attributes ) {
482 next if $shared_ancestors{ $attr->associated_class->name };
484 next if any { $_->has_attribute( $attr->name ) } @roles;
495 return _all_roles_until($meta);
498 sub _all_roles_until {
499 my ($meta, $stop_at_class) = @_;
501 return unless $meta->can('calculate_all_roles');
503 my @roles = $meta->calculate_all_roles;
505 for my $class ( $meta->linearized_isa ) {
506 last if $stop_at_class && $stop_at_class eq $class;
508 my $meta = Class::MOP::Class->initialize($class);
509 last unless $meta->can('calculate_all_roles');
511 push @roles, $meta->calculate_all_roles;
517 sub _reconcile_role_differences {
518 my ($self, $super_meta) = @_;
520 my $self_meta = Class::MOP::class_of($self);
524 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
525 $roles{metaclass_roles} = \@roles;
528 for my $thing (@MetaClassTypes) {
529 my $name = $self->$thing();
531 my $thing_meta = Class::MOP::Class->initialize($name);
533 my @roles = map { $_->name } _all_roles($thing_meta)
536 $roles{ $thing . '_roles' } = \@roles;
539 $self->_reinitialize_with($super_meta);
541 Moose::Util::MetaRole::apply_metaclass_roles(
542 for_class => $self->name,
549 sub _process_attribute {
550 my ( $self, $name, @args ) = @_;
552 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
554 if (($name || '') =~ /^\+(.*)/) {
555 return $self->_process_inherited_attribute($1, @args);
558 return $self->_process_new_attribute($name, @args);
562 sub _process_new_attribute {
563 my ( $self, $name, @args ) = @_;
565 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
568 sub _process_inherited_attribute {
569 my ($self, $attr_name, %options) = @_;
570 my $inherited_attr = $self->find_attribute_by_name($attr_name);
571 (defined $inherited_attr)
572 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
573 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
574 return $inherited_attr->clone_and_inherit_options(%options);
578 # kind of a kludge to handle Class::MOP::Attributes
579 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
583 ## -------------------------------------------------
588 my ( $self, @args ) = @_;
589 local $error_level = ($error_level || 0) + 1;
590 $self->raise_error($self->create_error(@args));
594 my ( $self, @args ) = @_;
599 my ( $self, @args ) = @_;
603 local $error_level = ($error_level || 0 ) + 1;
605 if ( @args % 2 == 1 ) {
606 unshift @args, "message";
609 my %args = ( metaclass => $self, last_error => $@, @args );
611 $args{depth} += $error_level;
613 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
615 Class::MOP::load_class($class);
618 Carp::caller_info($args{depth}),
631 Moose::Meta::Class - The Moose metaclass
635 This class is a subclass of L<Class::MOP::Class> that provides
636 additional Moose-specific functionality.
638 To really understand this class, you will need to start with the
639 L<Class::MOP::Class> documentation. This class can be understood as a
640 set of additional features on top of the basic feature provided by
645 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
651 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
653 This overrides the parent's method in order to provide its own
654 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
655 C<method_metaclass> options.
657 These all default to the appropriate Moose class.
659 =item B<< Moose::Meta::Class->create($package_name, %options) >>
661 This overrides the parent's method in order to accept a C<roles>
662 option. This should be an array reference containing one more roles
665 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
667 =item B<< Moose::Meta::Class->create_anon_class >>
669 This overrides the parent's method to accept a C<roles> option, just
672 It also accepts a C<cache> option. If this is true, then the anonymous
673 class will be cached based on its superclasses and roles. If an
674 existing anonymous class in the cache has the same superclasses and
675 roles, it will be reused.
677 my $metaclass = Moose::Meta::Class->create_anon_class(
678 superclasses => ['Foo'],
679 roles => [qw/Some Roles Go Here/],
683 =item B<< $metaclass->make_immutable(%options) >>
685 This overrides the parent's method to add a few options. Specifically,
686 it uses the Moose-specific constructor and destructor classes, and
687 enables inlining the destructor.
689 Also, since Moose always inlines attributes, it sets the
690 C<inline_accessors> option to false.
692 =item B<< $metaclass->new_object(%params) >>
694 This overrides the parent's method in order to add support for
697 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
699 This adds an C<override> method modifier to the package.
701 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
703 This adds an C<augment> method modifier to the package.
705 =item B<< $metaclass->calculate_all_roles >>
707 This will return a unique array of C<Moose::Meta::Role> instances
708 which are attached to this class.
710 =item B<< $metaclass->add_role($role) >>
712 This takes a L<Moose::Meta::Role> object, and adds it to the class's
713 list of roles. This I<does not> actually apply the role to the class.
715 =item B<< $metaclass->role_applications >>
717 Returns a list of L<Moose::Meta::Role::Application::ToClass>
718 objects, which contain the arguments to role application.
720 =item B<< $metaclass->add_role_application($application) >>
722 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
723 adds it to the class's list of role applications. This I<does not>
724 actually apply any role to the class; it is only for tracking role
727 =item B<< $metaclass->does_role($role_name) >>
729 This returns a boolean indicating whether or not the class does the
730 specified role. This tests both the class and its parents.
732 =item B<< $metaclass->excludes_role($role_name) >>
734 A class excludes a role if it has already composed a role which
735 excludes the named role. This tests both the class and its parents.
737 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
739 This overrides the parent's method in order to allow the parameters to
740 be provided as a hash reference.
742 =item B<< $metaclass->constructor_class ($class_name) >>
744 =item B<< $metaclass->destructor_class ($class_name) >>
746 These are the names of classes used when making a class
747 immutable. These default to L<Moose::Meta::Method::Constructor> and
748 L<Moose::Meta::Method::Destructor> respectively. These accessors are
749 read-write, so you can use them to change the class name.
751 =item B<< $metaclass->error_class($class_name) >>
753 The name of the class used to throw errors. This defaults to
754 L<Moose::Error::Default>, which generates an error with a stacktrace
755 just like C<Carp::confess>.
757 =item B<< $metaclass->throw_error($message, %extra) >>
759 Throws the error created by C<create_error> using C<raise_error>
765 All complex software has bugs lurking in it, and this module is no
766 exception. If you find a bug please either email me, or add the bug
771 Stevan Little E<lt>stevan@iinteractive.comE<gt>
773 =head1 COPYRIGHT AND LICENSE
775 Copyright 2006-2009 by Infinity Interactive, Inc.
777 L<http://www.iinteractive.com>
779 This library is free software; you can redistribute it and/or modify
780 it under the same terms as Perl itself.