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.87';
15 $VERSION = eval $VERSION;
16 our $AUTHORITY = 'cpan:STEVAN';
18 use Moose::Meta::Method::Overridden;
19 use Moose::Meta::Method::Augmented;
20 use Moose::Meta::Class::Immutable::Trait;
21 use Moose::Meta::Method::Constructor;
22 use Moose::Meta::Method::Destructor;
24 use base 'Class::MOP::Class';
26 __PACKAGE__->meta->add_attribute('roles' => (
31 __PACKAGE__->meta->add_attribute('role_applications' => (
32 reader => '_get_role_applications',
36 __PACKAGE__->meta->add_attribute(
37 Class::MOP::Attribute->new('immutable_trait' => (
38 accessor => "immutable_trait",
39 default => 'Moose::Meta::Class::Immutable::Trait',
43 __PACKAGE__->meta->add_attribute('constructor_class' => (
44 accessor => 'constructor_class',
45 default => 'Moose::Meta::Method::Constructor',
48 __PACKAGE__->meta->add_attribute('destructor_class' => (
49 accessor => 'destructor_class',
50 default => 'Moose::Meta::Method::Destructor',
53 __PACKAGE__->meta->add_attribute('error_class' => (
54 accessor => 'error_class',
55 default => 'Moose::Error::Default',
61 return Class::MOP::get_metaclass_by_name($pkg)
62 || $class->SUPER::initialize($pkg,
63 'attribute_metaclass' => 'Moose::Meta::Attribute',
64 'method_metaclass' => 'Moose::Meta::Method',
65 'instance_metaclass' => 'Moose::Meta::Instance',
70 sub _immutable_options {
71 my ( $self, @args ) = @_;
73 $self->SUPER::_immutable_options(
74 inline_destructor => 1,
76 # Moose always does this when an attribute is created
77 inline_accessors => 0,
84 my ($self, $package_name, %options) = @_;
86 (ref $options{roles} eq 'ARRAY')
87 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
88 if exists $options{roles};
89 my $roles = delete $options{roles};
91 my $class = $self->SUPER::create($package_name, %options);
94 Moose::Util::apply_all_roles( $class, @$roles );
100 sub _check_metaclass_compatibility {
103 if ( my @supers = $self->superclasses ) {
104 $self->_fix_metaclass_incompatibility(@supers);
107 $self->SUPER::_check_metaclass_compatibility(@_);
112 sub create_anon_class {
113 my ($self, %options) = @_;
115 my $cache_ok = delete $options{cache};
117 # something like Super::Class|Super::Class::2=Role|Role::1
118 my $cache_key = join '=' => (
119 join('|', @{$options{superclasses} || []}),
120 join('|', sort @{$options{roles} || []}),
123 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
124 return $ANON_CLASSES{$cache_key};
127 my $new_class = $self->SUPER::create_anon_class(%options);
129 $ANON_CLASSES{$cache_key} = $new_class
136 my ($self, $role) = @_;
137 (blessed($role) && $role->isa('Moose::Meta::Role'))
138 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
139 push @{$self->roles} => $role;
142 sub role_applications {
145 return @{$self->_get_role_applications};
148 sub add_role_application {
149 my ($self, $application) = @_;
150 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
151 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
152 push @{$self->_get_role_applications} => $application;
155 sub calculate_all_roles {
158 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
162 my ($self, $role_name) = @_;
165 || $self->throw_error("You must supply a role name to look for");
167 foreach my $class ($self->class_precedence_list) {
168 my $meta = Class::MOP::class_of($class);
169 # when a Moose metaclass is itself extended with a role,
170 # this check needs to be done since some items in the
171 # class_precedence_list might in fact be Class::MOP
173 next unless $meta && $meta->can('roles');
174 foreach my $role (@{$meta->roles}) {
175 return 1 if $role->does_role($role_name);
182 my ($self, $role_name) = @_;
185 || $self->throw_error("You must supply a role name to look for");
187 foreach my $class ($self->class_precedence_list) {
188 my $meta = Class::MOP::class_of($class);
189 # when a Moose metaclass is itself extended with a role,
190 # this check needs to be done since some items in the
191 # class_precedence_list might in fact be Class::MOP
193 next unless $meta && $meta->can('roles');
194 foreach my $role (@{$meta->roles}) {
195 return 1 if $role->excludes_role($role_name);
203 my $params = @_ == 1 ? $_[0] : {@_};
204 my $self = $class->SUPER::new_object($params);
206 foreach my $attr ( $class->get_all_attributes() ) {
208 next unless $attr->can('has_trigger') && $attr->has_trigger;
210 my $init_arg = $attr->init_arg;
212 next unless defined $init_arg;
214 next unless exists $params->{$init_arg};
220 ? $attr->get_read_method_ref->($self)
221 : $params->{$init_arg}
232 foreach my $super (@supers) {
233 Class::MOP::load_class($super);
234 my $meta = Class::MOP::class_of($super);
235 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
236 if $meta && $meta->isa('Moose::Meta::Role')
238 return $self->SUPER::superclasses(@supers);
241 ### ---------------------------------------------
246 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
248 : $self->_process_attribute(@_));
249 $self->SUPER::add_attribute($attr);
250 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
251 # 'bare' and doesn't implement this method
252 if ($attr->can('_check_associated_methods')) {
253 $attr->_check_associated_methods;
258 sub add_override_method_modifier {
259 my ($self, $name, $method, $_super_package) = @_;
261 (!$self->has_method($name))
262 || $self->throw_error("Cannot add an override method if a local method is already present");
264 $self->add_method($name => Moose::Meta::Method::Overridden->new(
267 package => $_super_package, # need this for roles
272 sub add_augment_method_modifier {
273 my ($self, $name, $method) = @_;
274 (!$self->has_method($name))
275 || $self->throw_error("Cannot add an augment method if a local method is already present");
277 $self->add_method($name => Moose::Meta::Method::Augmented->new(
284 ## Private Utility methods ...
286 sub _find_next_method_by_name_which_is_not_overridden {
287 my ($self, $name) = @_;
288 foreach my $method ($self->find_all_methods_by_name($name)) {
289 return $method->{code}
290 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
295 sub _fix_metaclass_incompatibility {
296 my ($self, @superclasses) = @_;
298 foreach my $super (@superclasses) {
299 my $meta = Class::MOP::Class->initialize($super);
301 my @all_supers = $meta->linearized_isa;
304 my @super_metas_to_fix = ($meta);
306 # We need to check & fix the immediate superclass. If its @ISA
307 # contains a class without a metaclass instance, followed by a
308 # class _with_ a metaclass instance, init a metaclass instance
309 # for classes without one and fix compat up to and including
310 # the class which was already initialized.
311 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
313 push @super_metas_to_fix,
314 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
317 foreach my $super_meta (@super_metas_to_fix) {
318 $self->_fix_one_incompatible_metaclass($super_meta);
323 sub _fix_one_incompatible_metaclass {
324 my ($self, $meta) = @_;
326 return if $self->_superclass_meta_is_compatible($meta);
328 unless ( $self->is_pristine ) {
330 "Cannot attempt to reinitialize metaclass for "
332 . ", it isn't pristine" );
335 $self->_reconcile_with_superclass_meta($meta);
338 sub _superclass_meta_is_compatible {
339 my ($self, $super_meta) = @_;
341 next unless $super_meta->isa("Class::MOP::Class");
344 = $super_meta->is_immutable
345 ? $super_meta->get_mutable_metaclass_name
349 if $self->isa($super_meta_name)
351 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
354 # I don't want to have to type this >1 time
356 qw( attribute_metaclass
358 wrapped_method_metaclass
364 sub _reconcile_with_superclass_meta {
365 my ($self, $super_meta) = @_;
368 = $super_meta->is_immutable
369 ? $super_meta->get_mutable_metaclass_name
372 my $self_metaclass = ref $self;
374 # If neither of these is true we have a more serious
375 # incompatibility that we just cannot fix (yet?).
376 if ( $super_meta_name->isa( ref $self )
377 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
378 $self->_reinitialize_with($super_meta);
380 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
381 $self->_reconcile_role_differences($super_meta);
385 sub _reinitialize_with {
386 my ( $self, $new_meta ) = @_;
388 my $new_self = $new_meta->reinitialize(
390 attribute_metaclass => $new_meta->attribute_metaclass,
391 method_metaclass => $new_meta->method_metaclass,
392 instance_metaclass => $new_meta->instance_metaclass,
395 $new_self->$_( $new_meta->$_ )
396 for qw( constructor_class destructor_class error_class );
400 bless $self, ref $new_self;
402 # We need to replace the cached metaclass instance or else when it
403 # goes out of scope Class::MOP::Class destroy's the namespace for
404 # the metaclass's class, causing much havoc.
405 Class::MOP::store_metaclass_by_name( $self->name, $self );
406 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
409 # In the more complex case, we share a common ancestor with our
410 # superclass's metaclass, but each metaclass (ours and the parent's)
411 # has a different set of roles applied. We reconcile this by first
412 # reinitializing into the parent class, and _then_ applying our own
414 sub _all_metaclasses_differ_by_roles_only {
415 my ($self, $super_meta) = @_;
418 [ ref $self, ref $super_meta ],
419 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
422 next if $pair->[0] eq $pair->[1];
424 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
425 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
428 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
430 return unless $common_ancestor;
433 unless _is_role_only_subclass_of(
437 && _is_role_only_subclass_of(
446 # This, and some other functions, could be called as methods, but
447 # they're not for two reasons. One, we just end up ignoring the first
448 # argument, because we can't call these directly on one of the real
449 # arguments, because one of them could be a Class::MOP::Class object
450 # and not a Moose::Meta::Class. Second, only a completely insane
451 # person would attempt to subclass this stuff!
452 sub _find_common_ancestor {
453 my ($meta1, $meta2) = @_;
455 # FIXME? This doesn't account for multiple inheritance (not sure
456 # if it needs to though). For example, is somewhere in $meta1's
457 # history it inherits from both ClassA and ClassB, and $meta2
458 # inherits from ClassB & ClassA, does it matter? And what crazy
459 # fool would do that anyway?
461 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
463 return first { $meta1_parents{$_} } $meta2->linearized_isa;
466 sub _is_role_only_subclass_of {
467 my ($meta, $ancestor) = @_;
469 return 1 if $meta->name eq $ancestor;
471 my @roles = _all_roles_until( $meta, $ancestor );
473 my %role_packages = map { $_->name => 1 } @roles;
475 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
477 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
479 for my $method ( $meta->get_all_methods() ) {
480 next if $method->name eq 'meta';
481 next if $method->can('associated_attribute');
484 if $role_packages{ $method->original_package_name }
485 || $shared_ancestors{ $method->original_package_name };
490 # FIXME - this really isn't right. Just because an attribute is
491 # defined in a role doesn't mean it isn't _also_ defined in the
493 for my $attr ( $meta->get_all_attributes ) {
494 next if $shared_ancestors{ $attr->associated_class->name };
496 next if any { $_->has_attribute( $attr->name ) } @roles;
507 return _all_roles_until($meta);
510 sub _all_roles_until {
511 my ($meta, $stop_at_class) = @_;
513 return unless $meta->can('calculate_all_roles');
515 my @roles = $meta->calculate_all_roles;
517 for my $class ( $meta->linearized_isa ) {
518 last if $stop_at_class && $stop_at_class eq $class;
520 my $meta = Class::MOP::Class->initialize($class);
521 last unless $meta->can('calculate_all_roles');
523 push @roles, $meta->calculate_all_roles;
529 sub _reconcile_role_differences {
530 my ($self, $super_meta) = @_;
532 my $self_meta = Class::MOP::class_of($self);
536 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
537 $roles{metaclass_roles} = \@roles;
540 for my $thing (@MetaClassTypes) {
541 my $name = $self->$thing();
543 my $thing_meta = Class::MOP::Class->initialize($name);
545 my @roles = map { $_->name } _all_roles($thing_meta)
548 $roles{ $thing . '_roles' } = \@roles;
551 $self->_reinitialize_with($super_meta);
553 Moose::Util::MetaRole::apply_metaclass_roles(
554 for_class => $self->name,
561 sub _process_attribute {
562 my ( $self, $name, @args ) = @_;
564 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
566 if (($name || '') =~ /^\+(.*)/) {
567 return $self->_process_inherited_attribute($1, @args);
570 return $self->_process_new_attribute($name, @args);
574 sub _process_new_attribute {
575 my ( $self, $name, @args ) = @_;
577 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
580 sub _process_inherited_attribute {
581 my ($self, $attr_name, %options) = @_;
582 my $inherited_attr = $self->find_attribute_by_name($attr_name);
583 (defined $inherited_attr)
584 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
585 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
586 return $inherited_attr->clone_and_inherit_options(%options);
590 # kind of a kludge to handle Class::MOP::Attributes
591 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
595 ## -------------------------------------------------
600 my ( $self, @args ) = @_;
601 local $error_level = ($error_level || 0) + 1;
602 $self->raise_error($self->create_error(@args));
606 my ( $self, @args ) = @_;
611 my ( $self, @args ) = @_;
613 require Moose::Error::Default;
616 local $error_level = ($error_level || 0 ) + 1;
618 if ( @args % 2 == 1 ) {
619 unshift @args, "message";
622 my %args = ( metaclass => $self, last_error => $@, @args );
624 $args{depth} += $error_level;
626 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
628 Class::MOP::load_class($class);
631 Carp::caller_info($args{depth}),
644 Moose::Meta::Class - The Moose metaclass
648 This class is a subclass of L<Class::MOP::Class> that provides
649 additional Moose-specific functionality.
651 To really understand this class, you will need to start with the
652 L<Class::MOP::Class> documentation. This class can be understood as a
653 set of additional features on top of the basic feature provided by
658 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
664 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
666 This overrides the parent's method in order to provide its own
667 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
668 C<method_metaclass> options.
670 These all default to the appropriate Moose class.
672 =item B<< Moose::Meta::Class->create($package_name, %options) >>
674 This overrides the parent's method in order to accept a C<roles>
675 option. This should be an array reference containing one more roles
678 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
680 =item B<< Moose::Meta::Class->create_anon_class >>
682 This overrides the parent's method to accept a C<roles> option, just
685 It also accepts a C<cache> option. If this is true, then the anonymous
686 class will be cached based on its superclasses and roles. If an
687 existing anonymous class in the cache has the same superclasses and
688 roles, it will be reused.
690 my $metaclass = Moose::Meta::Class->create_anon_class(
691 superclasses => ['Foo'],
692 roles => [qw/Some Roles Go Here/],
696 =item B<< $metaclass->make_immutable(%options) >>
698 This overrides the parent's method to add a few options. Specifically,
699 it uses the Moose-specific constructor and destructor classes, and
700 enables inlining the destructor.
702 Also, since Moose always inlines attributes, it sets the
703 C<inline_accessors> option to false.
705 =item B<< $metaclass->new_object(%params) >>
707 This overrides the parent's method in order to add support for
710 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
712 This adds an C<override> method modifier to the package.
714 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
716 This adds an C<augment> method modifier to the package.
718 =item B<< $metaclass->calculate_all_roles >>
720 This will return a unique array of C<Moose::Meta::Role> instances
721 which are attached to this class.
723 =item B<< $metaclass->add_role($role) >>
725 This takes a L<Moose::Meta::Role> object, and adds it to the class's
726 list of roles. This I<does not> actually apply the role to the class.
728 =item B<< $metaclass->role_applications >>
730 Returns a list of L<Moose::Meta::Role::Application::ToClass>
731 objects, which contain the arguments to role application.
733 =item B<< $metaclass->add_role_application($application) >>
735 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
736 adds it to the class's list of role applications. This I<does not>
737 actually apply any role to the class; it is only for tracking role
740 =item B<< $metaclass->does_role($role_name) >>
742 This returns a boolean indicating whether or not the class does the
743 specified role. This tests both the class and its parents.
745 =item B<< $metaclass->excludes_role($role_name) >>
747 A class excludes a role if it has already composed a role which
748 excludes the named role. This tests both the class and its parents.
750 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
752 This overrides the parent's method in order to allow the parameters to
753 be provided as a hash reference.
755 =item B<< $metaclass->constructor_class ($class_name) >>
757 =item B<< $metaclass->destructor_class ($class_name) >>
759 These are the names of classes used when making a class
760 immutable. These default to L<Moose::Meta::Method::Constructor> and
761 L<Moose::Meta::Method::Destructor> respectively. These accessors are
762 read-write, so you can use them to change the class name.
764 =item B<< $metaclass->error_class($class_name) >>
766 The name of the class used to throw errors. This defaults to
767 L<Moose::Error::Default>, which generates an error with a stacktrace
768 just like C<Carp::confess>.
770 =item B<< $metaclass->throw_error($message, %extra) >>
772 Throws the error created by C<create_error> using C<raise_error>
778 All complex software has bugs lurking in it, and this module is no
779 exception. If you find a bug please either email me, or add the bug
784 Stevan Little E<lt>stevan@iinteractive.comE<gt>
786 =head1 COPYRIGHT AND LICENSE
788 Copyright 2006-2009 by Infinity Interactive, Inc.
790 L<http://www.iinteractive.com>
792 This library is free software; you can redistribute it and/or modify
793 it under the same terms as Perl itself.