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.85';
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}
233 foreach my $super (@supers) {
234 Class::MOP::load_class($super);
235 my $meta = Class::MOP::class_of($super);
236 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
237 if $meta && $meta->isa('Moose::Meta::Role')
239 return $self->SUPER::superclasses(@supers);
242 ### ---------------------------------------------
247 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
249 : $self->_process_attribute(@_));
250 $self->SUPER::add_attribute($attr);
251 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
252 # 'bare' and doesn't implement this method
253 if ($attr->can('_check_associated_methods')) {
254 $attr->_check_associated_methods;
259 sub add_override_method_modifier {
260 my ($self, $name, $method, $_super_package) = @_;
262 (!$self->has_method($name))
263 || $self->throw_error("Cannot add an override method if a local method is already present");
265 $self->add_method($name => Moose::Meta::Method::Overridden->new(
268 package => $_super_package, # need this for roles
273 sub add_augment_method_modifier {
274 my ($self, $name, $method) = @_;
275 (!$self->has_method($name))
276 || $self->throw_error("Cannot add an augment method if a local method is already present");
278 $self->add_method($name => Moose::Meta::Method::Augmented->new(
285 ## Private Utility methods ...
287 sub _find_next_method_by_name_which_is_not_overridden {
288 my ($self, $name) = @_;
289 foreach my $method ($self->find_all_methods_by_name($name)) {
290 return $method->{code}
291 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
296 sub _fix_metaclass_incompatibility {
297 my ($self, @superclasses) = @_;
299 foreach my $super (@superclasses) {
300 my $meta = Class::MOP::Class->initialize($super);
302 my @all_supers = $meta->linearized_isa;
305 my @super_metas_to_fix = ($meta);
307 # We need to check & fix the immediate superclass. If its @ISA
308 # contains a class without a metaclass instance, followed by a
309 # class _with_ a metaclass instance, init a metaclass instance
310 # for classes without one and fix compat up to and including
311 # the class which was already initialized.
312 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
314 push @super_metas_to_fix,
315 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
318 foreach my $super_meta (@super_metas_to_fix) {
319 $self->_fix_one_incompatible_metaclass($super_meta);
324 sub _fix_one_incompatible_metaclass {
325 my ($self, $meta) = @_;
327 return if $self->_superclass_meta_is_compatible($meta);
329 unless ( $self->is_pristine ) {
331 "Cannot attempt to reinitialize metaclass for "
333 . ", it isn't pristine" );
336 $self->_reconcile_with_superclass_meta($meta);
339 sub _superclass_meta_is_compatible {
340 my ($self, $super_meta) = @_;
342 next unless $super_meta->isa("Class::MOP::Class");
345 = $super_meta->is_immutable
346 ? $super_meta->get_mutable_metaclass_name
350 if $self->isa($super_meta_name)
352 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
355 # I don't want to have to type this >1 time
357 qw( attribute_metaclass
359 wrapped_method_metaclass
365 sub _reconcile_with_superclass_meta {
366 my ($self, $super_meta) = @_;
369 = $super_meta->is_immutable
370 ? $super_meta->get_mutable_metaclass_name
373 my $self_metaclass = ref $self;
375 # If neither of these is true we have a more serious
376 # incompatibility that we just cannot fix (yet?).
377 if ( $super_meta_name->isa( ref $self )
378 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
379 $self->_reinitialize_with($super_meta);
381 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
382 $self->_reconcile_role_differences($super_meta);
386 sub _reinitialize_with {
387 my ( $self, $new_meta ) = @_;
389 my $new_self = $new_meta->reinitialize(
391 attribute_metaclass => $new_meta->attribute_metaclass,
392 method_metaclass => $new_meta->method_metaclass,
393 instance_metaclass => $new_meta->instance_metaclass,
396 $new_self->$_( $new_meta->$_ )
397 for qw( constructor_class destructor_class error_class );
401 bless $self, ref $new_self;
403 # We need to replace the cached metaclass instance or else when it
404 # goes out of scope Class::MOP::Class destroy's the namespace for
405 # the metaclass's class, causing much havoc.
406 Class::MOP::store_metaclass_by_name( $self->name, $self );
407 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
410 # In the more complex case, we share a common ancestor with our
411 # superclass's metaclass, but each metaclass (ours and the parent's)
412 # has a different set of roles applied. We reconcile this by first
413 # reinitializing into the parent class, and _then_ applying our own
415 sub _all_metaclasses_differ_by_roles_only {
416 my ($self, $super_meta) = @_;
419 [ ref $self, ref $super_meta ],
420 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
423 next if $pair->[0] eq $pair->[1];
425 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
426 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
429 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
431 return unless $common_ancestor;
434 unless _is_role_only_subclass_of(
438 && _is_role_only_subclass_of(
447 # This, and some other functions, could be called as methods, but
448 # they're not for two reasons. One, we just end up ignoring the first
449 # argument, because we can't call these directly on one of the real
450 # arguments, because one of them could be a Class::MOP::Class object
451 # and not a Moose::Meta::Class. Second, only a completely insane
452 # person would attempt to subclass this stuff!
453 sub _find_common_ancestor {
454 my ($meta1, $meta2) = @_;
456 # FIXME? This doesn't account for multiple inheritance (not sure
457 # if it needs to though). For example, is somewhere in $meta1's
458 # history it inherits from both ClassA and ClassB, and $meta2
459 # inherits from ClassB & ClassA, does it matter? And what crazy
460 # fool would do that anyway?
462 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
464 return first { $meta1_parents{$_} } $meta2->linearized_isa;
467 sub _is_role_only_subclass_of {
468 my ($meta, $ancestor) = @_;
470 return 1 if $meta->name eq $ancestor;
472 my @roles = _all_roles_until( $meta, $ancestor );
474 my %role_packages = map { $_->name => 1 } @roles;
476 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
478 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
480 for my $method ( $meta->get_all_methods() ) {
481 next if $method->name eq 'meta';
482 next if $method->can('associated_attribute');
485 if $role_packages{ $method->original_package_name }
486 || $shared_ancestors{ $method->original_package_name };
491 # FIXME - this really isn't right. Just because an attribute is
492 # defined in a role doesn't mean it isn't _also_ defined in the
494 for my $attr ( $meta->get_all_attributes ) {
495 next if $shared_ancestors{ $attr->associated_class->name };
497 next if any { $_->has_attribute( $attr->name ) } @roles;
508 return _all_roles_until($meta);
511 sub _all_roles_until {
512 my ($meta, $stop_at_class) = @_;
514 return unless $meta->can('calculate_all_roles');
516 my @roles = $meta->calculate_all_roles;
518 for my $class ( $meta->linearized_isa ) {
519 last if $stop_at_class && $stop_at_class eq $class;
521 my $meta = Class::MOP::Class->initialize($class);
522 last unless $meta->can('calculate_all_roles');
524 push @roles, $meta->calculate_all_roles;
530 sub _reconcile_role_differences {
531 my ($self, $super_meta) = @_;
533 my $self_meta = Class::MOP::class_of($self);
537 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
538 $roles{metaclass_roles} = \@roles;
541 for my $thing (@MetaClassTypes) {
542 my $name = $self->$thing();
544 my $thing_meta = Class::MOP::Class->initialize($name);
546 my @roles = map { $_->name } _all_roles($thing_meta)
549 $roles{ $thing . '_roles' } = \@roles;
552 $self->_reinitialize_with($super_meta);
554 Moose::Util::MetaRole::apply_metaclass_roles(
555 for_class => $self->name,
562 sub _process_attribute {
563 my ( $self, $name, @args ) = @_;
565 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
567 if (($name || '') =~ /^\+(.*)/) {
568 return $self->_process_inherited_attribute($1, @args);
571 return $self->_process_new_attribute($name, @args);
575 sub _process_new_attribute {
576 my ( $self, $name, @args ) = @_;
578 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
581 sub _process_inherited_attribute {
582 my ($self, $attr_name, %options) = @_;
583 my $inherited_attr = $self->find_attribute_by_name($attr_name);
584 (defined $inherited_attr)
585 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
586 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
587 return $inherited_attr->clone_and_inherit_options(%options);
591 # kind of a kludge to handle Class::MOP::Attributes
592 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
596 ## -------------------------------------------------
601 my ( $self, @args ) = @_;
602 local $error_level = ($error_level || 0) + 1;
603 $self->raise_error($self->create_error(@args));
607 my ( $self, @args ) = @_;
612 my ( $self, @args ) = @_;
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.