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.89_01';
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;
146 # we do this for metaclasses way too often to do this check for them
147 if ( !$self->name->isa('Class::MOP::Object') ) {
148 my @superclasses = grep { $_ ne 'Moose::Object' && $_ ne $self->name }
149 $self->linearized_isa;
151 for my $superclass (@superclasses) {
152 my $meta = Class::MOP::class_of($superclass);
154 next unless $meta && $meta->isa('Moose::Meta::Class');
155 next unless $meta->is_mutable;
157 Carp::cluck( "Calling make_immutable on "
159 . ", which has a mutable ancestor ($superclass)" );
164 $self->SUPER::make_immutable(@_);
167 sub role_applications {
170 return @{$self->_get_role_applications};
173 sub add_role_application {
174 my ($self, $application) = @_;
175 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
176 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
177 push @{$self->_get_role_applications} => $application;
180 sub calculate_all_roles {
183 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
187 my ($self, $role_name) = @_;
190 || $self->throw_error("You must supply a role name to look for");
192 foreach my $class ($self->class_precedence_list) {
193 my $meta = Class::MOP::class_of($class);
194 # when a Moose metaclass is itself extended with a role,
195 # this check needs to be done since some items in the
196 # class_precedence_list might in fact be Class::MOP
198 next unless $meta && $meta->can('roles');
199 foreach my $role (@{$meta->roles}) {
200 return 1 if $role->does_role($role_name);
207 my ($self, $role_name) = @_;
210 || $self->throw_error("You must supply a role name to look for");
212 foreach my $class ($self->class_precedence_list) {
213 my $meta = Class::MOP::class_of($class);
214 # when a Moose metaclass is itself extended with a role,
215 # this check needs to be done since some items in the
216 # class_precedence_list might in fact be Class::MOP
218 next unless $meta && $meta->can('roles');
219 foreach my $role (@{$meta->roles}) {
220 return 1 if $role->excludes_role($role_name);
228 my $params = @_ == 1 ? $_[0] : {@_};
229 my $self = $class->SUPER::new_object($params);
231 foreach my $attr ( $class->get_all_attributes() ) {
233 next unless $attr->can('has_trigger') && $attr->has_trigger;
235 my $init_arg = $attr->init_arg;
237 next unless defined $init_arg;
239 next unless exists $params->{$init_arg};
245 ? $attr->get_read_method_ref->($self)
246 : $params->{$init_arg}
257 foreach my $super (@supers) {
258 Class::MOP::load_class($super);
259 my $meta = Class::MOP::class_of($super);
260 $self->throw_error("You cannot inherit from a Moose Role ($super)")
261 if $meta && $meta->isa('Moose::Meta::Role')
263 return $self->SUPER::superclasses(@supers);
266 ### ---------------------------------------------
271 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
273 : $self->_process_attribute(@_));
274 $self->SUPER::add_attribute($attr);
275 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
276 # 'bare' and doesn't implement this method
277 if ($attr->can('_check_associated_methods')) {
278 $attr->_check_associated_methods;
283 sub add_override_method_modifier {
284 my ($self, $name, $method, $_super_package) = @_;
286 (!$self->has_method($name))
287 || $self->throw_error("Cannot add an override method if a local method is already present");
289 $self->add_method($name => Moose::Meta::Method::Overridden->new(
292 package => $_super_package, # need this for roles
297 sub add_augment_method_modifier {
298 my ($self, $name, $method) = @_;
299 (!$self->has_method($name))
300 || $self->throw_error("Cannot add an augment method if a local method is already present");
302 $self->add_method($name => Moose::Meta::Method::Augmented->new(
309 ## Private Utility methods ...
311 sub _find_next_method_by_name_which_is_not_overridden {
312 my ($self, $name) = @_;
313 foreach my $method ($self->find_all_methods_by_name($name)) {
314 return $method->{code}
315 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
320 sub _fix_metaclass_incompatibility {
321 my ($self, @superclasses) = @_;
323 foreach my $super (@superclasses) {
324 my $meta = Class::MOP::Class->initialize($super);
326 my @all_supers = $meta->linearized_isa;
329 my @super_metas_to_fix = ($meta);
331 # We need to check & fix the immediate superclass. If its @ISA
332 # contains a class without a metaclass instance, followed by a
333 # class _with_ a metaclass instance, init a metaclass instance
334 # for classes without one and fix compat up to and including
335 # the class which was already initialized.
336 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
338 push @super_metas_to_fix,
339 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
342 foreach my $super_meta (@super_metas_to_fix) {
343 $self->_fix_one_incompatible_metaclass($super_meta);
348 sub _fix_one_incompatible_metaclass {
349 my ($self, $meta) = @_;
351 return if $self->_superclass_meta_is_compatible($meta);
353 unless ( $self->is_pristine ) {
355 "Cannot attempt to reinitialize metaclass for "
357 . ", it isn't pristine" );
360 $self->_reconcile_with_superclass_meta($meta);
363 sub _superclass_meta_is_compatible {
364 my ($self, $super_meta) = @_;
366 next unless $super_meta->isa("Class::MOP::Class");
369 = $super_meta->is_immutable
370 ? $super_meta->get_mutable_metaclass_name
374 if $self->isa($super_meta_name)
376 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
379 # I don't want to have to type this >1 time
381 qw( attribute_metaclass
383 wrapped_method_metaclass
389 sub _reconcile_with_superclass_meta {
390 my ($self, $super_meta) = @_;
393 = $super_meta->is_immutable
394 ? $super_meta->get_mutable_metaclass_name
397 my $self_metaclass = ref $self;
399 # If neither of these is true we have a more serious
400 # incompatibility that we just cannot fix (yet?).
401 if ( $super_meta_name->isa( ref $self )
402 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
403 $self->_reinitialize_with($super_meta);
405 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
406 $self->_reconcile_role_differences($super_meta);
410 sub _reinitialize_with {
411 my ( $self, $new_meta ) = @_;
413 my $new_self = $new_meta->reinitialize(
415 attribute_metaclass => $new_meta->attribute_metaclass,
416 method_metaclass => $new_meta->method_metaclass,
417 instance_metaclass => $new_meta->instance_metaclass,
420 $new_self->$_( $new_meta->$_ )
421 for qw( constructor_class destructor_class error_class );
425 bless $self, ref $new_self;
427 # We need to replace the cached metaclass instance or else when it
428 # goes out of scope Class::MOP::Class destroy's the namespace for
429 # the metaclass's class, causing much havoc.
430 Class::MOP::store_metaclass_by_name( $self->name, $self );
431 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
434 # In the more complex case, we share a common ancestor with our
435 # superclass's metaclass, but each metaclass (ours and the parent's)
436 # has a different set of roles applied. We reconcile this by first
437 # reinitializing into the parent class, and _then_ applying our own
439 sub _all_metaclasses_differ_by_roles_only {
440 my ($self, $super_meta) = @_;
443 [ ref $self, ref $super_meta ],
444 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
447 next if $pair->[0] eq $pair->[1];
449 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
450 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
453 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
455 return unless $common_ancestor;
458 unless _is_role_only_subclass_of(
462 && _is_role_only_subclass_of(
471 # This, and some other functions, could be called as methods, but
472 # they're not for two reasons. One, we just end up ignoring the first
473 # argument, because we can't call these directly on one of the real
474 # arguments, because one of them could be a Class::MOP::Class object
475 # and not a Moose::Meta::Class. Second, only a completely insane
476 # person would attempt to subclass this stuff!
477 sub _find_common_ancestor {
478 my ($meta1, $meta2) = @_;
480 # FIXME? This doesn't account for multiple inheritance (not sure
481 # if it needs to though). For example, is somewhere in $meta1's
482 # history it inherits from both ClassA and ClassB, and $meta2
483 # inherits from ClassB & ClassA, does it matter? And what crazy
484 # fool would do that anyway?
486 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
488 return first { $meta1_parents{$_} } $meta2->linearized_isa;
491 sub _is_role_only_subclass_of {
492 my ($meta, $ancestor) = @_;
494 return 1 if $meta->name eq $ancestor;
496 my @roles = _all_roles_until( $meta, $ancestor );
498 my %role_packages = map { $_->name => 1 } @roles;
500 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
502 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
504 for my $method ( $meta->get_all_methods() ) {
505 next if $method->name eq 'meta';
506 next if $method->can('associated_attribute');
509 if $role_packages{ $method->original_package_name }
510 || $shared_ancestors{ $method->original_package_name };
515 # FIXME - this really isn't right. Just because an attribute is
516 # defined in a role doesn't mean it isn't _also_ defined in the
518 for my $attr ( $meta->get_all_attributes ) {
519 next if $shared_ancestors{ $attr->associated_class->name };
521 next if any { $_->has_attribute( $attr->name ) } @roles;
532 return _all_roles_until($meta);
535 sub _all_roles_until {
536 my ($meta, $stop_at_class) = @_;
538 return unless $meta->can('calculate_all_roles');
540 my @roles = $meta->calculate_all_roles;
542 for my $class ( $meta->linearized_isa ) {
543 last if $stop_at_class && $stop_at_class eq $class;
545 my $meta = Class::MOP::Class->initialize($class);
546 last unless $meta->can('calculate_all_roles');
548 push @roles, $meta->calculate_all_roles;
554 sub _reconcile_role_differences {
555 my ($self, $super_meta) = @_;
557 my $self_meta = Class::MOP::class_of($self);
561 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
562 $roles{metaclass_roles} = \@roles;
565 for my $thing (@MetaClassTypes) {
566 my $name = $self->$thing();
568 my $thing_meta = Class::MOP::Class->initialize($name);
570 my @roles = map { $_->name } _all_roles($thing_meta)
573 $roles{ $thing . '_roles' } = \@roles;
576 $self->_reinitialize_with($super_meta);
578 Moose::Util::MetaRole::apply_metaclass_roles(
579 for_class => $self->name,
586 sub _process_attribute {
587 my ( $self, $name, @args ) = @_;
589 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
591 if (($name || '') =~ /^\+(.*)/) {
592 return $self->_process_inherited_attribute($1, @args);
595 return $self->_process_new_attribute($name, @args);
599 sub _process_new_attribute {
600 my ( $self, $name, @args ) = @_;
602 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
605 sub _process_inherited_attribute {
606 my ($self, $attr_name, %options) = @_;
607 my $inherited_attr = $self->find_attribute_by_name($attr_name);
608 (defined $inherited_attr)
609 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
610 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
611 return $inherited_attr->clone_and_inherit_options(%options);
615 # kind of a kludge to handle Class::MOP::Attributes
616 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
620 ## -------------------------------------------------
625 my ( $self, @args ) = @_;
626 local $error_level = ($error_level || 0) + 1;
627 $self->raise_error($self->create_error(@args));
631 my ( $self, @args ) = @_;
636 my ( $self, @args ) = @_;
640 local $error_level = ($error_level || 0 ) + 1;
642 if ( @args % 2 == 1 ) {
643 unshift @args, "message";
646 my %args = ( metaclass => $self, last_error => $@, @args );
648 $args{depth} += $error_level;
650 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
652 Class::MOP::load_class($class);
655 Carp::caller_info($args{depth}),
668 Moose::Meta::Class - The Moose metaclass
672 This class is a subclass of L<Class::MOP::Class> that provides
673 additional Moose-specific functionality.
675 To really understand this class, you will need to start with the
676 L<Class::MOP::Class> documentation. This class can be understood as a
677 set of additional features on top of the basic feature provided by
682 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
688 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
690 This overrides the parent's method in order to provide its own
691 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
692 C<method_metaclass> options.
694 These all default to the appropriate Moose class.
696 =item B<< Moose::Meta::Class->create($package_name, %options) >>
698 This overrides the parent's method in order to accept a C<roles>
699 option. This should be an array reference containing one more roles
700 that the class does, each optionally followed by a hashref of options.
702 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
704 =item B<< Moose::Meta::Class->create_anon_class >>
706 This overrides the parent's method to accept a C<roles> option, just
709 It also accepts a C<cache> option. If this is true, then the anonymous
710 class will be cached based on its superclasses and roles. If an
711 existing anonymous class in the cache has the same superclasses and
712 roles, it will be reused.
714 my $metaclass = Moose::Meta::Class->create_anon_class(
715 superclasses => ['Foo'],
716 roles => [qw/Some Roles Go Here/],
720 =item B<< $metaclass->make_immutable(%options) >>
722 This overrides the parent's method to add a few options. Specifically,
723 it uses the Moose-specific constructor and destructor classes, and
724 enables inlining the destructor.
726 Also, since Moose always inlines attributes, it sets the
727 C<inline_accessors> option to false.
729 =item B<< $metaclass->new_object(%params) >>
731 This overrides the parent's method in order to add support for
734 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
736 This adds an C<override> method modifier to the package.
738 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
740 This adds an C<augment> method modifier to the package.
742 =item B<< $metaclass->calculate_all_roles >>
744 This will return a unique array of C<Moose::Meta::Role> instances
745 which are attached to this class.
747 =item B<< $metaclass->add_role($role) >>
749 This takes a L<Moose::Meta::Role> object, and adds it to the class's
750 list of roles. This I<does not> actually apply the role to the class.
752 =item B<< $metaclass->role_applications >>
754 Returns a list of L<Moose::Meta::Role::Application::ToClass>
755 objects, which contain the arguments to role application.
757 =item B<< $metaclass->add_role_application($application) >>
759 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
760 adds it to the class's list of role applications. This I<does not>
761 actually apply any role to the class; it is only for tracking role
764 =item B<< $metaclass->does_role($role_name) >>
766 This returns a boolean indicating whether or not the class does the
767 specified role. This tests both the class and its parents.
769 =item B<< $metaclass->excludes_role($role_name) >>
771 A class excludes a role if it has already composed a role which
772 excludes the named role. This tests both the class and its parents.
774 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
776 This overrides the parent's method in order to allow the parameters to
777 be provided as a hash reference.
779 =item B<< $metaclass->constructor_class ($class_name) >>
781 =item B<< $metaclass->destructor_class ($class_name) >>
783 These are the names of classes used when making a class
784 immutable. These default to L<Moose::Meta::Method::Constructor> and
785 L<Moose::Meta::Method::Destructor> respectively. These accessors are
786 read-write, so you can use them to change the class name.
788 =item B<< $metaclass->error_class($class_name) >>
790 The name of the class used to throw errors. This defaults to
791 L<Moose::Error::Default>, which generates an error with a stacktrace
792 just like C<Carp::confess>.
794 =item B<< $metaclass->throw_error($message, %extra) >>
796 Throws the error created by C<create_error> using C<raise_error>
802 All complex software has bugs lurking in it, and this module is no
803 exception. If you find a bug please either email me, or add the bug
808 Stevan Little E<lt>stevan@iinteractive.comE<gt>
810 =head1 COPYRIGHT AND LICENSE
812 Copyright 2006-2009 by Infinity Interactive, Inc.
814 L<http://www.iinteractive.com>
816 This library is free software; you can redistribute it and/or modify
817 it under the same terms as Perl itself.