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;
150 for my $superclass (@superclasses) {
151 my $meta = Class::MOP::class_of($superclass);
152 next unless $meta && $meta->isa('Moose::Meta::Class');
153 next unless $meta->is_mutable;
154 Carp::cluck( "Calling make_immutable on "
156 . ", which has a mutable ancestor ($superclass)" );
160 $self->SUPER::make_immutable(@_);
163 sub role_applications {
166 return @{$self->_get_role_applications};
169 sub add_role_application {
170 my ($self, $application) = @_;
171 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
172 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
173 push @{$self->_get_role_applications} => $application;
176 sub calculate_all_roles {
179 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
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->does_role($role_name);
203 my ($self, $role_name) = @_;
206 || $self->throw_error("You must supply a role name to look for");
208 foreach my $class ($self->class_precedence_list) {
209 my $meta = Class::MOP::class_of($class);
210 # when a Moose metaclass is itself extended with a role,
211 # this check needs to be done since some items in the
212 # class_precedence_list might in fact be Class::MOP
214 next unless $meta && $meta->can('roles');
215 foreach my $role (@{$meta->roles}) {
216 return 1 if $role->excludes_role($role_name);
224 my $params = @_ == 1 ? $_[0] : {@_};
225 my $self = $class->SUPER::new_object($params);
227 foreach my $attr ( $class->get_all_attributes() ) {
229 next unless $attr->can('has_trigger') && $attr->has_trigger;
231 my $init_arg = $attr->init_arg;
233 next unless defined $init_arg;
235 next unless exists $params->{$init_arg};
241 ? $attr->get_read_method_ref->($self)
242 : $params->{$init_arg}
253 foreach my $super (@supers) {
254 Class::MOP::load_class($super);
255 my $meta = Class::MOP::class_of($super);
256 $self->throw_error("You cannot inherit from a Moose Role ($super)")
257 if $meta && $meta->isa('Moose::Meta::Role')
259 return $self->SUPER::superclasses(@supers);
262 ### ---------------------------------------------
267 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
269 : $self->_process_attribute(@_));
270 $self->SUPER::add_attribute($attr);
271 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
272 # 'bare' and doesn't implement this method
273 if ($attr->can('_check_associated_methods')) {
274 $attr->_check_associated_methods;
279 sub add_override_method_modifier {
280 my ($self, $name, $method, $_super_package) = @_;
282 (!$self->has_method($name))
283 || $self->throw_error("Cannot add an override method if a local method is already present");
285 $self->add_method($name => Moose::Meta::Method::Overridden->new(
288 package => $_super_package, # need this for roles
293 sub add_augment_method_modifier {
294 my ($self, $name, $method) = @_;
295 (!$self->has_method($name))
296 || $self->throw_error("Cannot add an augment method if a local method is already present");
298 $self->add_method($name => Moose::Meta::Method::Augmented->new(
305 ## Private Utility methods ...
307 sub _find_next_method_by_name_which_is_not_overridden {
308 my ($self, $name) = @_;
309 foreach my $method ($self->find_all_methods_by_name($name)) {
310 return $method->{code}
311 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
316 sub _fix_metaclass_incompatibility {
317 my ($self, @superclasses) = @_;
319 foreach my $super (@superclasses) {
320 my $meta = Class::MOP::Class->initialize($super);
322 my @all_supers = $meta->linearized_isa;
325 my @super_metas_to_fix = ($meta);
327 # We need to check & fix the immediate superclass. If its @ISA
328 # contains a class without a metaclass instance, followed by a
329 # class _with_ a metaclass instance, init a metaclass instance
330 # for classes without one and fix compat up to and including
331 # the class which was already initialized.
332 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
334 push @super_metas_to_fix,
335 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
338 foreach my $super_meta (@super_metas_to_fix) {
339 $self->_fix_one_incompatible_metaclass($super_meta);
344 sub _fix_one_incompatible_metaclass {
345 my ($self, $meta) = @_;
347 return if $self->_superclass_meta_is_compatible($meta);
349 unless ( $self->is_pristine ) {
351 "Cannot attempt to reinitialize metaclass for "
353 . ", it isn't pristine" );
356 $self->_reconcile_with_superclass_meta($meta);
359 sub _superclass_meta_is_compatible {
360 my ($self, $super_meta) = @_;
362 next unless $super_meta->isa("Class::MOP::Class");
365 = $super_meta->is_immutable
366 ? $super_meta->get_mutable_metaclass_name
370 if $self->isa($super_meta_name)
372 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
375 # I don't want to have to type this >1 time
377 qw( attribute_metaclass
379 wrapped_method_metaclass
385 sub _reconcile_with_superclass_meta {
386 my ($self, $super_meta) = @_;
389 = $super_meta->is_immutable
390 ? $super_meta->get_mutable_metaclass_name
393 my $self_metaclass = ref $self;
395 # If neither of these is true we have a more serious
396 # incompatibility that we just cannot fix (yet?).
397 if ( $super_meta_name->isa( ref $self )
398 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
399 $self->_reinitialize_with($super_meta);
401 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
402 $self->_reconcile_role_differences($super_meta);
406 sub _reinitialize_with {
407 my ( $self, $new_meta ) = @_;
409 my $new_self = $new_meta->reinitialize(
411 attribute_metaclass => $new_meta->attribute_metaclass,
412 method_metaclass => $new_meta->method_metaclass,
413 instance_metaclass => $new_meta->instance_metaclass,
416 $new_self->$_( $new_meta->$_ )
417 for qw( constructor_class destructor_class error_class );
421 bless $self, ref $new_self;
423 # We need to replace the cached metaclass instance or else when it
424 # goes out of scope Class::MOP::Class destroy's the namespace for
425 # the metaclass's class, causing much havoc.
426 Class::MOP::store_metaclass_by_name( $self->name, $self );
427 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
430 # In the more complex case, we share a common ancestor with our
431 # superclass's metaclass, but each metaclass (ours and the parent's)
432 # has a different set of roles applied. We reconcile this by first
433 # reinitializing into the parent class, and _then_ applying our own
435 sub _all_metaclasses_differ_by_roles_only {
436 my ($self, $super_meta) = @_;
439 [ ref $self, ref $super_meta ],
440 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
443 next if $pair->[0] eq $pair->[1];
445 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
446 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
449 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
451 return unless $common_ancestor;
454 unless _is_role_only_subclass_of(
458 && _is_role_only_subclass_of(
467 # This, and some other functions, could be called as methods, but
468 # they're not for two reasons. One, we just end up ignoring the first
469 # argument, because we can't call these directly on one of the real
470 # arguments, because one of them could be a Class::MOP::Class object
471 # and not a Moose::Meta::Class. Second, only a completely insane
472 # person would attempt to subclass this stuff!
473 sub _find_common_ancestor {
474 my ($meta1, $meta2) = @_;
476 # FIXME? This doesn't account for multiple inheritance (not sure
477 # if it needs to though). For example, is somewhere in $meta1's
478 # history it inherits from both ClassA and ClassB, and $meta2
479 # inherits from ClassB & ClassA, does it matter? And what crazy
480 # fool would do that anyway?
482 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
484 return first { $meta1_parents{$_} } $meta2->linearized_isa;
487 sub _is_role_only_subclass_of {
488 my ($meta, $ancestor) = @_;
490 return 1 if $meta->name eq $ancestor;
492 my @roles = _all_roles_until( $meta, $ancestor );
494 my %role_packages = map { $_->name => 1 } @roles;
496 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
498 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
500 for my $method ( $meta->get_all_methods() ) {
501 next if $method->name eq 'meta';
502 next if $method->can('associated_attribute');
505 if $role_packages{ $method->original_package_name }
506 || $shared_ancestors{ $method->original_package_name };
511 # FIXME - this really isn't right. Just because an attribute is
512 # defined in a role doesn't mean it isn't _also_ defined in the
514 for my $attr ( $meta->get_all_attributes ) {
515 next if $shared_ancestors{ $attr->associated_class->name };
517 next if any { $_->has_attribute( $attr->name ) } @roles;
528 return _all_roles_until($meta);
531 sub _all_roles_until {
532 my ($meta, $stop_at_class) = @_;
534 return unless $meta->can('calculate_all_roles');
536 my @roles = $meta->calculate_all_roles;
538 for my $class ( $meta->linearized_isa ) {
539 last if $stop_at_class && $stop_at_class eq $class;
541 my $meta = Class::MOP::Class->initialize($class);
542 last unless $meta->can('calculate_all_roles');
544 push @roles, $meta->calculate_all_roles;
550 sub _reconcile_role_differences {
551 my ($self, $super_meta) = @_;
553 my $self_meta = Class::MOP::class_of($self);
557 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
558 $roles{metaclass_roles} = \@roles;
561 for my $thing (@MetaClassTypes) {
562 my $name = $self->$thing();
564 my $thing_meta = Class::MOP::Class->initialize($name);
566 my @roles = map { $_->name } _all_roles($thing_meta)
569 $roles{ $thing . '_roles' } = \@roles;
572 $self->_reinitialize_with($super_meta);
574 Moose::Util::MetaRole::apply_metaclass_roles(
575 for_class => $self->name,
582 sub _process_attribute {
583 my ( $self, $name, @args ) = @_;
585 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
587 if (($name || '') =~ /^\+(.*)/) {
588 return $self->_process_inherited_attribute($1, @args);
591 return $self->_process_new_attribute($name, @args);
595 sub _process_new_attribute {
596 my ( $self, $name, @args ) = @_;
598 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
601 sub _process_inherited_attribute {
602 my ($self, $attr_name, %options) = @_;
603 my $inherited_attr = $self->find_attribute_by_name($attr_name);
604 (defined $inherited_attr)
605 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
606 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
607 return $inherited_attr->clone_and_inherit_options(%options);
611 # kind of a kludge to handle Class::MOP::Attributes
612 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
616 ## -------------------------------------------------
621 my ( $self, @args ) = @_;
622 local $error_level = ($error_level || 0) + 1;
623 $self->raise_error($self->create_error(@args));
627 my ( $self, @args ) = @_;
632 my ( $self, @args ) = @_;
636 local $error_level = ($error_level || 0 ) + 1;
638 if ( @args % 2 == 1 ) {
639 unshift @args, "message";
642 my %args = ( metaclass => $self, last_error => $@, @args );
644 $args{depth} += $error_level;
646 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
648 Class::MOP::load_class($class);
651 Carp::caller_info($args{depth}),
664 Moose::Meta::Class - The Moose metaclass
668 This class is a subclass of L<Class::MOP::Class> that provides
669 additional Moose-specific functionality.
671 To really understand this class, you will need to start with the
672 L<Class::MOP::Class> documentation. This class can be understood as a
673 set of additional features on top of the basic feature provided by
678 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
684 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
686 This overrides the parent's method in order to provide its own
687 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
688 C<method_metaclass> options.
690 These all default to the appropriate Moose class.
692 =item B<< Moose::Meta::Class->create($package_name, %options) >>
694 This overrides the parent's method in order to accept a C<roles>
695 option. This should be an array reference containing one more roles
696 that the class does, each optionally followed by a hashref of options.
698 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
700 =item B<< Moose::Meta::Class->create_anon_class >>
702 This overrides the parent's method to accept a C<roles> option, just
705 It also accepts a C<cache> option. If this is true, then the anonymous
706 class will be cached based on its superclasses and roles. If an
707 existing anonymous class in the cache has the same superclasses and
708 roles, it will be reused.
710 my $metaclass = Moose::Meta::Class->create_anon_class(
711 superclasses => ['Foo'],
712 roles => [qw/Some Roles Go Here/],
716 =item B<< $metaclass->make_immutable(%options) >>
718 This overrides the parent's method to add a few options. Specifically,
719 it uses the Moose-specific constructor and destructor classes, and
720 enables inlining the destructor.
722 Also, since Moose always inlines attributes, it sets the
723 C<inline_accessors> option to false.
725 =item B<< $metaclass->new_object(%params) >>
727 This overrides the parent's method in order to add support for
730 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
732 This adds an C<override> method modifier to the package.
734 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
736 This adds an C<augment> method modifier to the package.
738 =item B<< $metaclass->calculate_all_roles >>
740 This will return a unique array of C<Moose::Meta::Role> instances
741 which are attached to this class.
743 =item B<< $metaclass->add_role($role) >>
745 This takes a L<Moose::Meta::Role> object, and adds it to the class's
746 list of roles. This I<does not> actually apply the role to the class.
748 =item B<< $metaclass->role_applications >>
750 Returns a list of L<Moose::Meta::Role::Application::ToClass>
751 objects, which contain the arguments to role application.
753 =item B<< $metaclass->add_role_application($application) >>
755 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
756 adds it to the class's list of role applications. This I<does not>
757 actually apply any role to the class; it is only for tracking role
760 =item B<< $metaclass->does_role($role_name) >>
762 This returns a boolean indicating whether or not the class does the
763 specified role. This tests both the class and its parents.
765 =item B<< $metaclass->excludes_role($role_name) >>
767 A class excludes a role if it has already composed a role which
768 excludes the named role. This tests both the class and its parents.
770 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
772 This overrides the parent's method in order to allow the parameters to
773 be provided as a hash reference.
775 =item B<< $metaclass->constructor_class ($class_name) >>
777 =item B<< $metaclass->destructor_class ($class_name) >>
779 These are the names of classes used when making a class
780 immutable. These default to L<Moose::Meta::Method::Constructor> and
781 L<Moose::Meta::Method::Destructor> respectively. These accessors are
782 read-write, so you can use them to change the class name.
784 =item B<< $metaclass->error_class($class_name) >>
786 The name of the class used to throw errors. This defaults to
787 L<Moose::Error::Default>, which generates an error with a stacktrace
788 just like C<Carp::confess>.
790 =item B<< $metaclass->throw_error($message, %extra) >>
792 Throws the error created by C<create_error> using C<raise_error>
798 All complex software has bugs lurking in it, and this module is no
799 exception. If you find a bug please either email me, or add the bug
804 Stevan Little E<lt>stevan@iinteractive.comE<gt>
806 =head1 COPYRIGHT AND LICENSE
808 Copyright 2006-2009 by Infinity Interactive, Inc.
810 L<http://www.iinteractive.com>
812 This library is free software; you can redistribute it and/or modify
813 it under the same terms as Perl itself.