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.80';
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 Class::MOP::load_class($super);
250 my $meta = Class::MOP::class_of($super);
251 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
252 if $meta && $meta->isa('Moose::Meta::Role')
254 return $self->SUPER::superclasses(@supers);
257 ### ---------------------------------------------
261 $self->SUPER::add_attribute(
262 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
264 : $self->_process_attribute(@_))
268 sub add_override_method_modifier {
269 my ($self, $name, $method, $_super_package) = @_;
271 (!$self->has_method($name))
272 || $self->throw_error("Cannot add an override method if a local method is already present");
274 $self->add_method($name => Moose::Meta::Method::Overridden->new(
277 package => $_super_package, # need this for roles
282 sub add_augment_method_modifier {
283 my ($self, $name, $method) = @_;
284 (!$self->has_method($name))
285 || $self->throw_error("Cannot add an augment method if a local method is already present");
287 $self->add_method($name => Moose::Meta::Method::Augmented->new(
294 ## Private Utility methods ...
296 sub _find_next_method_by_name_which_is_not_overridden {
297 my ($self, $name) = @_;
298 foreach my $method ($self->find_all_methods_by_name($name)) {
299 return $method->{code}
300 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
305 sub _fix_metaclass_incompatibility {
306 my ($self, @superclasses) = @_;
308 foreach my $super (@superclasses) {
309 my $meta = Class::MOP::Class->initialize($super);
311 my @all_supers = $meta->linearized_isa;
314 my @super_metas_to_fix = ($meta);
316 # We need to check & fix the immediate superclass. If its @ISA
317 # contains a class without a metaclass instance, followed by a
318 # class _with_ a metaclass instance, init a metaclass instance
319 # for classes without one and fix compat up to and including
320 # the class which was already initialized.
321 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
323 push @super_metas_to_fix,
324 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
327 foreach my $super_meta (@super_metas_to_fix) {
328 $self->_fix_one_incompatible_metaclass($super_meta);
333 sub _fix_one_incompatible_metaclass {
334 my ($self, $meta) = @_;
336 return if $self->_superclass_meta_is_compatible($meta);
338 unless ( $self->is_pristine ) {
340 "Cannot attempt to reinitialize metaclass for "
342 . ", it isn't pristine" );
345 $self->_reconcile_with_superclass_meta($meta);
348 sub _superclass_meta_is_compatible {
349 my ($self, $super_meta) = @_;
351 next unless $super_meta->isa("Class::MOP::Class");
354 = $super_meta->is_immutable
355 ? $super_meta->get_mutable_metaclass_name
359 if $self->isa($super_meta_name)
361 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
364 # I don't want to have to type this >1 time
366 qw( attribute_metaclass
368 wrapped_method_metaclass
374 sub _reconcile_with_superclass_meta {
375 my ($self, $super_meta) = @_;
378 = $super_meta->is_immutable
379 ? $super_meta->get_mutable_metaclass_name
382 my $self_metaclass = ref $self;
384 # If neither of these is true we have a more serious
385 # incompatibility that we just cannot fix (yet?).
386 if ( $super_meta_name->isa( ref $self )
387 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
388 $self->_reinitialize_with($super_meta);
390 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
391 $self->_reconcile_role_differences($super_meta);
395 sub _reinitialize_with {
396 my ( $self, $new_meta ) = @_;
398 my $new_self = $new_meta->reinitialize(
400 attribute_metaclass => $new_meta->attribute_metaclass,
401 method_metaclass => $new_meta->method_metaclass,
402 instance_metaclass => $new_meta->instance_metaclass,
405 $new_self->$_( $new_meta->$_ )
406 for qw( constructor_class destructor_class error_class );
410 bless $self, ref $new_self;
412 # We need to replace the cached metaclass instance or else when it
413 # goes out of scope Class::MOP::Class destroy's the namespace for
414 # the metaclass's class, causing much havoc.
415 Class::MOP::store_metaclass_by_name( $self->name, $self );
416 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
419 # In the more complex case, we share a common ancestor with our
420 # superclass's metaclass, but each metaclass (ours and the parent's)
421 # has a different set of roles applied. We reconcile this by first
422 # reinitializing into the parent class, and _then_ applying our own
424 sub _all_metaclasses_differ_by_roles_only {
425 my ($self, $super_meta) = @_;
428 [ ref $self, ref $super_meta ],
429 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
432 next if $pair->[0] eq $pair->[1];
434 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
435 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
438 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
440 return unless $common_ancestor;
443 unless _is_role_only_subclass_of(
447 && _is_role_only_subclass_of(
456 # This, and some other functions, could be called as methods, but
457 # they're not for two reasons. One, we just end up ignoring the first
458 # argument, because we can't call these directly on one of the real
459 # arguments, because one of them could be a Class::MOP::Class object
460 # and not a Moose::Meta::Class. Second, only a completely insane
461 # person would attempt to subclass this stuff!
462 sub _find_common_ancestor {
463 my ($meta1, $meta2) = @_;
465 # FIXME? This doesn't account for multiple inheritance (not sure
466 # if it needs to though). For example, is somewhere in $meta1's
467 # history it inherits from both ClassA and ClassB, and $meta2
468 # inherits from ClassB & ClassA, does it matter? And what crazy
469 # fool would do that anyway?
471 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
473 return first { $meta1_parents{$_} } $meta2->linearized_isa;
476 sub _is_role_only_subclass_of {
477 my ($meta, $ancestor) = @_;
479 return 1 if $meta->name eq $ancestor;
481 my @roles = _all_roles_until( $meta, $ancestor );
483 my %role_packages = map { $_->name => 1 } @roles;
485 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
487 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
489 for my $method ( $meta->get_all_methods() ) {
490 next if $method->name eq 'meta';
491 next if $method->can('associated_attribute');
494 if $role_packages{ $method->original_package_name }
495 || $shared_ancestors{ $method->original_package_name };
500 # FIXME - this really isn't right. Just because an attribute is
501 # defined in a role doesn't mean it isn't _also_ defined in the
503 for my $attr ( $meta->get_all_attributes ) {
504 next if $shared_ancestors{ $attr->associated_class->name };
506 next if any { $_->has_attribute( $attr->name ) } @roles;
517 return _all_roles_until($meta);
520 sub _all_roles_until {
521 my ($meta, $stop_at_class) = @_;
523 return unless $meta->can('calculate_all_roles');
525 my @roles = $meta->calculate_all_roles;
527 for my $class ( $meta->linearized_isa ) {
528 last if $stop_at_class && $stop_at_class eq $class;
530 my $meta = Class::MOP::Class->initialize($class);
531 last unless $meta->can('calculate_all_roles');
533 push @roles, $meta->calculate_all_roles;
539 sub _reconcile_role_differences {
540 my ($self, $super_meta) = @_;
542 my $self_meta = Class::MOP::class_of($self);
546 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
547 $roles{metaclass_roles} = \@roles;
550 for my $thing (@MetaClassTypes) {
551 my $name = $self->$thing();
553 my $thing_meta = Class::MOP::Class->initialize($name);
555 my @roles = map { $_->name } _all_roles($thing_meta)
558 $roles{ $thing . '_roles' } = \@roles;
561 $self->_reinitialize_with($super_meta);
563 Moose::Util::MetaRole::apply_metaclass_roles(
564 for_class => $self->name,
571 sub _process_attribute {
572 my ( $self, $name, @args ) = @_;
574 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
576 if (($name || '') =~ /^\+(.*)/) {
577 return $self->_process_inherited_attribute($1, @args);
580 return $self->_process_new_attribute($name, @args);
584 sub _process_new_attribute {
585 my ( $self, $name, @args ) = @_;
587 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
590 sub _process_inherited_attribute {
591 my ($self, $attr_name, %options) = @_;
592 my $inherited_attr = $self->find_attribute_by_name($attr_name);
593 (defined $inherited_attr)
594 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
595 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
596 return $inherited_attr->clone_and_inherit_options(%options);
600 # kind of a kludge to handle Class::MOP::Attributes
601 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
605 ## -------------------------------------------------
610 my ( $self, @args ) = @_;
611 local $error_level = ($error_level || 0) + 1;
612 $self->raise_error($self->create_error(@args));
616 my ( $self, @args ) = @_;
621 my ( $self, @args ) = @_;
625 local $error_level = ($error_level || 0 ) + 1;
627 if ( @args % 2 == 1 ) {
628 unshift @args, "message";
631 my %args = ( metaclass => $self, last_error => $@, @args );
633 $args{depth} += $error_level;
635 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
637 Class::MOP::load_class($class);
640 Carp::caller_info($args{depth}),
653 Moose::Meta::Class - The Moose metaclass
657 This class is a subclass of L<Class::MOP::Class> that provides
658 additional Moose-specific functionality.
660 To really understand this class, you will need to start with the
661 L<Class::MOP::Class> documentation. This class can be understood as a
662 set of additional features on top of the basic feature provided by
667 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
673 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
675 This overrides the parent's method in order to provide its own
676 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
677 C<method_metaclass> options.
679 These all default to the appropriate Moose class.
681 =item B<< Moose::Meta::Class->create($package_name, %options) >>
683 This overrides the parent's method in order to accept a C<roles>
684 option. This should be an array reference containing one more roles
687 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
689 =item B<< Moose::Meta::Class->create_anon_class >>
691 This overrides the parent's method to accept a C<roles> option, just
694 It also accepts a C<cache> option. If this is true, then the anonymous
695 class will be cached based on its superclasses and roles. If an
696 existing anonymous class in the cache has the same superclasses and
697 roles, it will be reused.
699 my $metaclass = Moose::Meta::Class->create_anon_class(
700 superclasses => ['Foo'],
701 roles => [qw/Some Roles Go Here/],
705 =item B<< $metaclass->make_immutable(%options) >>
707 This overrides the parent's method to add a few options. Specifically,
708 it uses the Moose-specific constructor and destructor classes, and
709 enables inlining the destructor.
711 Also, since Moose always inlines attributes, it sets the
712 C<inline_accessors> option to false.
714 =item B<< $metaclass->new_object(%params) >>
716 This overrides the parent's method in order to add support for
719 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
721 This adds an C<override> method modifier to the package.
723 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
725 This adds an C<augment> method modifier to the package.
727 =item B<< $metaclass->calculate_all_roles >>
729 This will return a unique array of C<Moose::Meta::Role> instances
730 which are attached to this class.
732 =item B<< $metaclass->add_role($role) >>
734 This takes a L<Moose::Meta::Role> object, and adds it to the class's
735 list of roles. This I<does not> actually apply the role to the class.
737 =item B<< $metaclass->role_applications >>
739 Returns a list of L<Moose::Meta::Role::Application::ToClass>
740 objects, which contain the arguments to role application.
742 =item B<< $metaclass->add_role_application($application) >>
744 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
745 adds it to the class's list of role applications. This I<does not>
746 actually apply any role to the class; it is only for tracking role
749 =item B<< $metaclass->does_role($role_name) >>
751 This returns a boolean indicating whether or not the class does the
752 specified role. This tests both the class and its parents.
754 =item B<< $metaclass->excludes_role($role_name) >>
756 A class excludes a role if it has already composed a role which
757 excludes the named role. This tests both the class and its parents.
759 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
761 This overrides the parent's method in order to allow the parameters to
762 be provided as a hash reference.
764 =item B<< $metaclass->constructor_class ($class_name) >>
766 =item B<< $metaclass->destructor_class ($class_name) >>
768 These are the names of classes used when making a class
769 immutable. These default to L<Moose::Meta::Method::Constructor> and
770 L<Moose::Meta::Method::Destructor> respectively. These accessors are
771 read-write, so you can use them to change the class name.
773 =item B<< $metaclass->error_class($class_name) >>
775 The name of the class used to throw errors. This defaults to
776 L<Moose::Error::Default>, which generates an error with a stacktrace
777 just like C<Carp::confess>.
779 =item B<< $metaclass->throw_error($message, %extra) >>
781 Throws the error created by C<create_error> using C<raise_error>
787 All complex software has bugs lurking in it, and this module is no
788 exception. If you find a bug please either email me, or add the bug
793 Stevan Little E<lt>stevan@iinteractive.comE<gt>
795 =head1 COPYRIGHT AND LICENSE
797 Copyright 2006-2009 by Infinity Interactive, Inc.
799 L<http://www.iinteractive.com>
801 This library is free software; you can redistribute it and/or modify
802 it under the same terms as Perl itself.