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;
156 # This can happen when a base class role is applied via
157 # Moose::Util::MetaRole::apply_base_class_roles. The parent is an
158 # anon class and is still mutable, but that's okay.
159 next if $meta->is_anon_class;
161 Carp::cluck( "Calling make_immutable on "
163 . ", which has a mutable ancestor ($superclass)" );
168 $self->SUPER::make_immutable(@_);
171 sub role_applications {
174 return @{$self->_get_role_applications};
177 sub add_role_application {
178 my ($self, $application) = @_;
179 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
180 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
181 push @{$self->_get_role_applications} => $application;
184 sub calculate_all_roles {
187 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
191 my ($self, $role_name) = @_;
194 || $self->throw_error("You must supply a role name to look for");
196 foreach my $class ($self->class_precedence_list) {
197 my $meta = Class::MOP::class_of($class);
198 # when a Moose metaclass is itself extended with a role,
199 # this check needs to be done since some items in the
200 # class_precedence_list might in fact be Class::MOP
202 next unless $meta && $meta->can('roles');
203 foreach my $role (@{$meta->roles}) {
204 return 1 if $role->does_role($role_name);
211 my ($self, $role_name) = @_;
214 || $self->throw_error("You must supply a role name to look for");
216 foreach my $class ($self->class_precedence_list) {
217 my $meta = Class::MOP::class_of($class);
218 # when a Moose metaclass is itself extended with a role,
219 # this check needs to be done since some items in the
220 # class_precedence_list might in fact be Class::MOP
222 next unless $meta && $meta->can('roles');
223 foreach my $role (@{$meta->roles}) {
224 return 1 if $role->excludes_role($role_name);
232 my $params = @_ == 1 ? $_[0] : {@_};
233 my $self = $class->SUPER::new_object($params);
235 foreach my $attr ( $class->get_all_attributes() ) {
237 next unless $attr->can('has_trigger') && $attr->has_trigger;
239 my $init_arg = $attr->init_arg;
241 next unless defined $init_arg;
243 next unless exists $params->{$init_arg};
249 ? $attr->get_read_method_ref->($self)
250 : $params->{$init_arg}
261 foreach my $super (@supers) {
262 Class::MOP::load_class($super);
263 my $meta = Class::MOP::class_of($super);
264 $self->throw_error("You cannot inherit from a Moose Role ($super)")
265 if $meta && $meta->isa('Moose::Meta::Role')
267 return $self->SUPER::superclasses(@supers);
270 ### ---------------------------------------------
275 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
277 : $self->_process_attribute(@_));
278 $self->SUPER::add_attribute($attr);
279 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
280 # 'bare' and doesn't implement this method
281 if ($attr->can('_check_associated_methods')) {
282 $attr->_check_associated_methods;
287 sub add_override_method_modifier {
288 my ($self, $name, $method, $_super_package) = @_;
290 (!$self->has_method($name))
291 || $self->throw_error("Cannot add an override method if a local method is already present");
293 $self->add_method($name => Moose::Meta::Method::Overridden->new(
296 package => $_super_package, # need this for roles
301 sub add_augment_method_modifier {
302 my ($self, $name, $method) = @_;
303 (!$self->has_method($name))
304 || $self->throw_error("Cannot add an augment method if a local method is already present");
306 $self->add_method($name => Moose::Meta::Method::Augmented->new(
313 ## Private Utility methods ...
315 sub _find_next_method_by_name_which_is_not_overridden {
316 my ($self, $name) = @_;
317 foreach my $method ($self->find_all_methods_by_name($name)) {
318 return $method->{code}
319 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
324 sub _fix_metaclass_incompatibility {
325 my ($self, @superclasses) = @_;
327 foreach my $super (@superclasses) {
328 my $meta = Class::MOP::Class->initialize($super);
330 my @all_supers = $meta->linearized_isa;
333 my @super_metas_to_fix = ($meta);
335 # We need to check & fix the immediate superclass. If its @ISA
336 # contains a class without a metaclass instance, followed by a
337 # class _with_ a metaclass instance, init a metaclass instance
338 # for classes without one and fix compat up to and including
339 # the class which was already initialized.
340 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
342 push @super_metas_to_fix,
343 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
346 foreach my $super_meta (@super_metas_to_fix) {
347 $self->_fix_one_incompatible_metaclass($super_meta);
352 sub _fix_one_incompatible_metaclass {
353 my ($self, $meta) = @_;
355 return if $self->_superclass_meta_is_compatible($meta);
357 unless ( $self->is_pristine ) {
359 "Cannot attempt to reinitialize metaclass for "
361 . ", it isn't pristine" );
364 $self->_reconcile_with_superclass_meta($meta);
367 sub _superclass_meta_is_compatible {
368 my ($self, $super_meta) = @_;
370 next unless $super_meta->isa("Class::MOP::Class");
373 = $super_meta->is_immutable
374 ? $super_meta->get_mutable_metaclass_name
378 if $self->isa($super_meta_name)
380 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
383 # I don't want to have to type this >1 time
385 qw( attribute_metaclass
387 wrapped_method_metaclass
393 sub _reconcile_with_superclass_meta {
394 my ($self, $super_meta) = @_;
397 = $super_meta->is_immutable
398 ? $super_meta->get_mutable_metaclass_name
401 my $self_metaclass = ref $self;
403 # If neither of these is true we have a more serious
404 # incompatibility that we just cannot fix (yet?).
405 if ( $super_meta_name->isa( ref $self )
406 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
407 $self->_reinitialize_with($super_meta);
409 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
410 $self->_reconcile_role_differences($super_meta);
414 sub _reinitialize_with {
415 my ( $self, $new_meta ) = @_;
417 my $new_self = $new_meta->reinitialize(
419 attribute_metaclass => $new_meta->attribute_metaclass,
420 method_metaclass => $new_meta->method_metaclass,
421 instance_metaclass => $new_meta->instance_metaclass,
424 $new_self->$_( $new_meta->$_ )
425 for qw( constructor_class destructor_class error_class );
429 bless $self, ref $new_self;
431 # We need to replace the cached metaclass instance or else when it
432 # goes out of scope Class::MOP::Class destroy's the namespace for
433 # the metaclass's class, causing much havoc.
434 Class::MOP::store_metaclass_by_name( $self->name, $self );
435 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
438 # In the more complex case, we share a common ancestor with our
439 # superclass's metaclass, but each metaclass (ours and the parent's)
440 # has a different set of roles applied. We reconcile this by first
441 # reinitializing into the parent class, and _then_ applying our own
443 sub _all_metaclasses_differ_by_roles_only {
444 my ($self, $super_meta) = @_;
447 [ ref $self, ref $super_meta ],
448 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
451 next if $pair->[0] eq $pair->[1];
453 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
454 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
457 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
459 return unless $common_ancestor;
462 unless _is_role_only_subclass_of(
466 && _is_role_only_subclass_of(
475 # This, and some other functions, could be called as methods, but
476 # they're not for two reasons. One, we just end up ignoring the first
477 # argument, because we can't call these directly on one of the real
478 # arguments, because one of them could be a Class::MOP::Class object
479 # and not a Moose::Meta::Class. Second, only a completely insane
480 # person would attempt to subclass this stuff!
481 sub _find_common_ancestor {
482 my ($meta1, $meta2) = @_;
484 # FIXME? This doesn't account for multiple inheritance (not sure
485 # if it needs to though). For example, is somewhere in $meta1's
486 # history it inherits from both ClassA and ClassB, and $meta2
487 # inherits from ClassB & ClassA, does it matter? And what crazy
488 # fool would do that anyway?
490 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
492 return first { $meta1_parents{$_} } $meta2->linearized_isa;
495 sub _is_role_only_subclass_of {
496 my ($meta, $ancestor) = @_;
498 return 1 if $meta->name eq $ancestor;
500 my @roles = _all_roles_until( $meta, $ancestor );
502 my %role_packages = map { $_->name => 1 } @roles;
504 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
506 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
508 for my $method ( $meta->get_all_methods() ) {
509 next if $method->name eq 'meta';
510 next if $method->can('associated_attribute');
513 if $role_packages{ $method->original_package_name }
514 || $shared_ancestors{ $method->original_package_name };
519 # FIXME - this really isn't right. Just because an attribute is
520 # defined in a role doesn't mean it isn't _also_ defined in the
522 for my $attr ( $meta->get_all_attributes ) {
523 next if $shared_ancestors{ $attr->associated_class->name };
525 next if any { $_->has_attribute( $attr->name ) } @roles;
536 return _all_roles_until($meta);
539 sub _all_roles_until {
540 my ($meta, $stop_at_class) = @_;
542 return unless $meta->can('calculate_all_roles');
544 my @roles = $meta->calculate_all_roles;
546 for my $class ( $meta->linearized_isa ) {
547 last if $stop_at_class && $stop_at_class eq $class;
549 my $meta = Class::MOP::Class->initialize($class);
550 last unless $meta->can('calculate_all_roles');
552 push @roles, $meta->calculate_all_roles;
558 sub _reconcile_role_differences {
559 my ($self, $super_meta) = @_;
561 my $self_meta = Class::MOP::class_of($self);
565 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
566 $roles{metaclass_roles} = \@roles;
569 for my $thing (@MetaClassTypes) {
570 my $name = $self->$thing();
572 my $thing_meta = Class::MOP::Class->initialize($name);
574 my @roles = map { $_->name } _all_roles($thing_meta)
577 $roles{ $thing . '_roles' } = \@roles;
580 $self->_reinitialize_with($super_meta);
582 Moose::Util::MetaRole::apply_metaclass_roles(
583 for_class => $self->name,
590 sub _process_attribute {
591 my ( $self, $name, @args ) = @_;
593 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
595 if (($name || '') =~ /^\+(.*)/) {
596 return $self->_process_inherited_attribute($1, @args);
599 return $self->_process_new_attribute($name, @args);
603 sub _process_new_attribute {
604 my ( $self, $name, @args ) = @_;
606 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
609 sub _process_inherited_attribute {
610 my ($self, $attr_name, %options) = @_;
611 my $inherited_attr = $self->find_attribute_by_name($attr_name);
612 (defined $inherited_attr)
613 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
614 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
615 return $inherited_attr->clone_and_inherit_options(%options);
619 # kind of a kludge to handle Class::MOP::Attributes
620 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
624 ## -------------------------------------------------
629 my ( $self, @args ) = @_;
630 local $error_level = ($error_level || 0) + 1;
631 $self->raise_error($self->create_error(@args));
635 my ( $self, @args ) = @_;
640 my ( $self, @args ) = @_;
644 local $error_level = ($error_level || 0 ) + 1;
646 if ( @args % 2 == 1 ) {
647 unshift @args, "message";
650 my %args = ( metaclass => $self, last_error => $@, @args );
652 $args{depth} += $error_level;
654 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
656 Class::MOP::load_class($class);
659 Carp::caller_info($args{depth}),
672 Moose::Meta::Class - The Moose metaclass
676 This class is a subclass of L<Class::MOP::Class> that provides
677 additional Moose-specific functionality.
679 To really understand this class, you will need to start with the
680 L<Class::MOP::Class> documentation. This class can be understood as a
681 set of additional features on top of the basic feature provided by
686 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
692 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
694 This overrides the parent's method in order to provide its own
695 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
696 C<method_metaclass> options.
698 These all default to the appropriate Moose class.
700 =item B<< Moose::Meta::Class->create($package_name, %options) >>
702 This overrides the parent's method in order to accept a C<roles>
703 option. This should be an array reference containing one more roles
704 that the class does, each optionally followed by a hashref of options.
706 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
708 =item B<< Moose::Meta::Class->create_anon_class >>
710 This overrides the parent's method to accept a C<roles> option, just
713 It also accepts a C<cache> option. If this is true, then the anonymous
714 class will be cached based on its superclasses and roles. If an
715 existing anonymous class in the cache has the same superclasses and
716 roles, it will be reused.
718 my $metaclass = Moose::Meta::Class->create_anon_class(
719 superclasses => ['Foo'],
720 roles => [qw/Some Roles Go Here/],
724 =item B<< $metaclass->make_immutable(%options) >>
726 This overrides the parent's method to add a few options. Specifically,
727 it uses the Moose-specific constructor and destructor classes, and
728 enables inlining the destructor.
730 Also, since Moose always inlines attributes, it sets the
731 C<inline_accessors> option to false.
733 =item B<< $metaclass->new_object(%params) >>
735 This overrides the parent's method in order to add support for
738 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
740 This adds an C<override> method modifier to the package.
742 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
744 This adds an C<augment> method modifier to the package.
746 =item B<< $metaclass->calculate_all_roles >>
748 This will return a unique array of C<Moose::Meta::Role> instances
749 which are attached to this class.
751 =item B<< $metaclass->add_role($role) >>
753 This takes a L<Moose::Meta::Role> object, and adds it to the class's
754 list of roles. This I<does not> actually apply the role to the class.
756 =item B<< $metaclass->role_applications >>
758 Returns a list of L<Moose::Meta::Role::Application::ToClass>
759 objects, which contain the arguments to role application.
761 =item B<< $metaclass->add_role_application($application) >>
763 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
764 adds it to the class's list of role applications. This I<does not>
765 actually apply any role to the class; it is only for tracking role
768 =item B<< $metaclass->does_role($role_name) >>
770 This returns a boolean indicating whether or not the class does the
771 specified role. This tests both the class and its parents.
773 =item B<< $metaclass->excludes_role($role_name) >>
775 A class excludes a role if it has already composed a role which
776 excludes the named role. This tests both the class and its parents.
778 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
780 This overrides the parent's method in order to allow the parameters to
781 be provided as a hash reference.
783 =item B<< $metaclass->constructor_class ($class_name) >>
785 =item B<< $metaclass->destructor_class ($class_name) >>
787 These are the names of classes used when making a class
788 immutable. These default to L<Moose::Meta::Method::Constructor> and
789 L<Moose::Meta::Method::Destructor> respectively. These accessors are
790 read-write, so you can use them to change the class name.
792 =item B<< $metaclass->error_class($class_name) >>
794 The name of the class used to throw errors. This defaults to
795 L<Moose::Error::Default>, which generates an error with a stacktrace
796 just like C<Carp::confess>.
798 =item B<< $metaclass->throw_error($message, %extra) >>
800 Throws the error created by C<create_error> using C<raise_error>
806 All complex software has bugs lurking in it, and this module is no
807 exception. If you find a bug please either email me, or add the bug
812 Stevan Little E<lt>stevan@iinteractive.comE<gt>
814 =head1 COPYRIGHT AND LICENSE
816 Copyright 2006-2009 by Infinity Interactive, Inc.
818 L<http://www.iinteractive.com>
820 This library is free software; you can redistribute it and/or modify
821 it under the same terms as Perl itself.