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.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 my $meta = Class::MOP::Class->initialize($super);
310 my @all_supers = $meta->linearized_isa;
313 my @super_metas_to_fix = ($meta);
315 # We need to check & fix the immediate superclass. If its @ISA
316 # contains a class without a metaclass instance, followed by a
317 # class _with_ a metaclass instance, init a metaclass instance
318 # for classes without one and fix compat up to and including
319 # the class which was already initialized.
320 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
322 push @super_metas_to_fix,
323 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
326 foreach my $super_meta (@super_metas_to_fix) {
327 $self->_fix_one_incompatible_metaclass($super_meta);
332 sub _fix_one_incompatible_metaclass {
333 my ($self, $meta) = @_;
335 return if $self->_superclass_meta_is_compatible($meta);
337 unless ( $self->is_pristine ) {
339 "Cannot attempt to reinitialize metaclass for "
341 . ", it isn't pristine" );
344 $self->_reconcile_with_superclass_meta($meta);
347 sub _superclass_meta_is_compatible {
348 my ($self, $super_meta) = @_;
350 next unless $super_meta->isa("Class::MOP::Class");
353 = $super_meta->is_immutable
354 ? $super_meta->get_mutable_metaclass_name
358 if $self->isa($super_meta_name)
360 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
363 # I don't want to have to type this >1 time
365 qw( attribute_metaclass
367 wrapped_method_metaclass
373 sub _reconcile_with_superclass_meta {
374 my ($self, $super_meta) = @_;
377 = $super_meta->is_immutable
378 ? $super_meta->get_mutable_metaclass_name
381 my $self_metaclass = ref $self;
383 # If neither of these is true we have a more serious
384 # incompatibility that we just cannot fix (yet?).
385 if ( $super_meta_name->isa( ref $self )
386 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
387 $self->_reinitialize_with($super_meta);
389 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
390 $self->_reconcile_role_differences($super_meta);
394 sub _reinitialize_with {
395 my ( $self, $new_meta ) = @_;
397 my $new_self = $new_meta->reinitialize(
399 attribute_metaclass => $new_meta->attribute_metaclass,
400 method_metaclass => $new_meta->method_metaclass,
401 instance_metaclass => $new_meta->instance_metaclass,
404 $new_self->$_( $new_meta->$_ )
405 for qw( constructor_class destructor_class error_class );
409 bless $self, ref $new_self;
411 # We need to replace the cached metaclass instance or else when it
412 # goes out of scope Class::MOP::Class destroy's the namespace for
413 # the metaclass's class, causing much havoc.
414 Class::MOP::store_metaclass_by_name( $self->name, $self );
415 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
418 # In the more complex case, we share a common ancestor with our
419 # superclass's metaclass, but each metaclass (ours and the parent's)
420 # has a different set of roles applied. We reconcile this by first
421 # reinitializing into the parent class, and _then_ applying our own
423 sub _all_metaclasses_differ_by_roles_only {
424 my ($self, $super_meta) = @_;
427 [ ref $self, ref $super_meta ],
428 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
431 next if $pair->[0] eq $pair->[1];
433 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
434 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
437 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
439 return unless $common_ancestor;
442 unless _is_role_only_subclass_of(
446 && _is_role_only_subclass_of(
455 # This, and some other functions, could be called as methods, but
456 # they're not for two reasons. One, we just end up ignoring the first
457 # argument, because we can't call these directly on one of the real
458 # arguments, because one of them could be a Class::MOP::Class object
459 # and not a Moose::Meta::Class. Second, only a completely insane
460 # person would attempt to subclass this stuff!
461 sub _find_common_ancestor {
462 my ($meta1, $meta2) = @_;
464 # FIXME? This doesn't account for multiple inheritance (not sure
465 # if it needs to though). For example, is somewhere in $meta1's
466 # history it inherits from both ClassA and ClassB, and $meta2
467 # inherits from ClassB & ClassA, does it matter? And what crazy
468 # fool would do that anyway?
470 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
472 return first { $meta1_parents{$_} } $meta2->linearized_isa;
475 sub _is_role_only_subclass_of {
476 my ($meta, $ancestor) = @_;
478 return 1 if $meta->name eq $ancestor;
480 my @roles = _all_roles_until( $meta, $ancestor );
482 my %role_packages = map { $_->name => 1 } @roles;
484 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
486 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
488 for my $method ( $meta->get_all_methods() ) {
489 next if $method->name eq 'meta';
490 next if $method->can('associated_attribute');
493 if $role_packages{ $method->original_package_name }
494 || $shared_ancestors{ $method->original_package_name };
499 # FIXME - this really isn't right. Just because an attribute is
500 # defined in a role doesn't mean it isn't _also_ defined in the
502 for my $attr ( $meta->get_all_attributes ) {
503 next if $shared_ancestors{ $attr->associated_class->name };
505 next if any { $_->has_attribute( $attr->name ) } @roles;
516 return _all_roles_until($meta);
519 sub _all_roles_until {
520 my ($meta, $stop_at_class) = @_;
522 return unless $meta->can('calculate_all_roles');
524 my @roles = $meta->calculate_all_roles;
526 for my $class ( $meta->linearized_isa ) {
527 last if $stop_at_class && $stop_at_class eq $class;
529 my $meta = Class::MOP::Class->initialize($class);
530 last unless $meta->can('calculate_all_roles');
532 push @roles, $meta->calculate_all_roles;
538 sub _reconcile_role_differences {
539 my ($self, $super_meta) = @_;
541 my $self_meta = Class::MOP::class_of($self);
545 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
546 $roles{metaclass_roles} = \@roles;
549 for my $thing (@MetaClassTypes) {
550 my $name = $self->$thing();
552 my $thing_meta = Class::MOP::Class->initialize($name);
554 my @roles = map { $_->name } _all_roles($thing_meta)
557 $roles{ $thing . '_roles' } = \@roles;
560 $self->_reinitialize_with($super_meta);
562 Moose::Util::MetaRole::apply_metaclass_roles(
563 for_class => $self->name,
570 sub _process_attribute {
571 my ( $self, $name, @args ) = @_;
573 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
575 if (($name || '') =~ /^\+(.*)/) {
576 return $self->_process_inherited_attribute($1, @args);
579 return $self->_process_new_attribute($name, @args);
583 sub _process_new_attribute {
584 my ( $self, $name, @args ) = @_;
586 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
589 sub _process_inherited_attribute {
590 my ($self, $attr_name, %options) = @_;
591 my $inherited_attr = $self->find_attribute_by_name($attr_name);
592 (defined $inherited_attr)
593 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
594 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
595 return $inherited_attr->clone_and_inherit_options(%options);
599 # kind of a kludge to handle Class::MOP::Attributes
600 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
604 ## -------------------------------------------------
609 my ( $self, @args ) = @_;
610 local $error_level = ($error_level || 0) + 1;
611 $self->raise_error($self->create_error(@args));
615 my ( $self, @args ) = @_;
620 my ( $self, @args ) = @_;
624 local $error_level = ($error_level || 0 ) + 1;
626 if ( @args % 2 == 1 ) {
627 unshift @args, "message";
630 my %args = ( metaclass => $self, last_error => $@, @args );
632 $args{depth} += $error_level;
634 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
636 Class::MOP::load_class($class);
639 Carp::caller_info($args{depth}),
652 Moose::Meta::Class - The Moose metaclass
656 This class is a subclass of L<Class::MOP::Class> that provides
657 additional Moose-specific functionality.
659 To really understand this class, you will need to start with the
660 L<Class::MOP::Class> documentation. This class can be understood as a
661 set of additional features on top of the basic feature provided by
666 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
672 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
674 This overrides the parent's method in order to provide its own
675 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
676 C<method_metaclass> options.
678 These all default to the appropriate Moose class.
680 =item B<< Moose::Meta::Class->create($package_name, %options) >>
682 This overrides the parent's method in order to accept a C<roles>
683 option. This should be an array reference containing one more roles
686 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
688 =item B<< Moose::Meta::Class->create_anon_class >>
690 This overrides the parent's method to accept a C<roles> option, just
693 It also accepts a C<cache> option. If this is true, then the anonymous
694 class will be cached based on its superclasses and roles. If an
695 existing anonymous class in the cache has the same superclasses and
696 roles, it will be reused.
698 my $metaclass = Moose::Meta::Class->create_anon_class(
699 superclasses => ['Foo'],
700 roles => [qw/Some Roles Go Here/],
704 =item B<< $metaclass->make_immutable(%options) >>
706 This overrides the parent's method to add a few options. Specifically,
707 it uses the Moose-specific constructor and destructor classes, and
708 enables inlining the destructor.
710 Also, since Moose always inlines attributes, it sets the
711 C<inline_accessors> option to false.
713 =item B<< $metaclass->new_object(%params) >>
715 This overrides the parent's method in order to add support for
718 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
720 This adds an C<override> method modifier to the package.
722 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
724 This adds an C<augment> method modifier to the package.
726 =item B<< $metaclass->calculate_all_roles >>
728 This will return a unique array of C<Moose::Meta::Role> instances
729 which are attached to this class.
731 =item B<< $metaclass->add_role($role) >>
733 This takes a L<Moose::Meta::Role> object, and adds it to the class's
734 list of roles. This I<does not> actually apply the role to the class.
736 =item B<< $metaclass->role_applications >>
738 Returns a list of L<Moose::Meta::Role::Application::ToClass>
739 objects, which contain the arguments to role application.
741 =item B<< $metaclass->add_role_application($application) >>
743 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
744 adds it to the class's list of role applications. This I<does not>
745 actually apply any role to the class; it is only for tracking role
748 =item B<< $metaclass->does_role($role_name) >>
750 This returns a boolean indicating whether or not the class does the
751 specified role. This tests both the class and its parents.
753 =item B<< $metaclass->excludes_role($role_name) >>
755 A class excludes a role if it has already composed a role which
756 excludes the named role. This tests both the class and its parents.
758 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
760 This overrides the parent's method in order to allow the parameters to
761 be provided as a hash reference.
763 =item B<< $metaclass->constructor_class ($class_name) >>
765 =item B<< $metaclass->destructor_class ($class_name) >>
767 These are the names of classes used when making a class
768 immutable. These default to L<Moose::Meta::Method::Constructor> and
769 L<Moose::Meta::Method::Destructor> respectively. These accessors are
770 read-write, so you can use them to change the class name.
772 =item B<< $metaclass->error_class($class_name) >>
774 The name of the class used to throw errors. This defaults to
775 L<Moose::Error::Default>, which generates an error with a stacktrace
776 just like C<Carp::confess>.
778 =item B<< $metaclass->throw_error($message, %extra) >>
780 Throws the error created by C<create_error> using C<raise_error>
786 All complex software has bugs lurking in it, and this module is no
787 exception. If you find a bug please either email me, or add the bug
792 Stevan Little E<lt>stevan@iinteractive.comE<gt>
794 =head1 COPYRIGHT AND LICENSE
796 Copyright 2006-2009 by Infinity Interactive, Inc.
798 L<http://www.iinteractive.com>
800 This library is free software; you can redistribute it and/or modify
801 it under the same terms as Perl itself.