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.96';
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};
119 = _anon_cache_key( $options{superclasses}, $options{roles} );
121 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
122 return $ANON_CLASSES{$cache_key};
125 my $new_class = $self->SUPER::create_anon_class(%options);
127 $ANON_CLASSES{$cache_key} = $new_class
133 sub _anon_cache_key {
134 # Makes something like Super::Class|Super::Class::2=Role|Role::1
136 join( '|', @{ $_[0] || [] } ),
137 join( '|', sort @{ $_[1] || [] } ),
145 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
149 my %existing_classes;
151 %existing_classes = map { $_ => $meta->$_() } qw(
154 wrapped_method_metaclass
161 $cache_key = _anon_cache_key(
162 [ $meta->superclasses ],
163 [ map { $_->name } @{ $meta->roles } ],
164 ) if $meta->is_anon_class;
167 my $new_meta = $self->SUPER::reinitialize(
173 return $new_meta unless defined $cache_key;
175 my $new_cache_key = _anon_cache_key(
176 [ $meta->superclasses ],
177 [ map { $_->name } @{ $meta->roles } ],
180 delete $ANON_CLASSES{$cache_key};
181 $ANON_CLASSES{$new_cache_key} = $new_meta;
187 my ($self, $role) = @_;
188 (blessed($role) && $role->isa('Moose::Meta::Role'))
189 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
190 push @{$self->roles} => $role;
193 sub role_applications {
196 return @{$self->_get_role_applications};
199 sub add_role_application {
200 my ($self, $application) = @_;
201 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
202 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
203 push @{$self->_get_role_applications} => $application;
206 sub calculate_all_roles {
209 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
213 my ($self, $role_name) = @_;
216 || $self->throw_error("You must supply a role name to look for");
218 foreach my $class ($self->class_precedence_list) {
219 my $meta = Class::MOP::class_of($class);
220 # when a Moose metaclass is itself extended with a role,
221 # this check needs to be done since some items in the
222 # class_precedence_list might in fact be Class::MOP
224 next unless $meta && $meta->can('roles');
225 foreach my $role (@{$meta->roles}) {
226 return 1 if $role->does_role($role_name);
233 my ($self, $role_name) = @_;
236 || $self->throw_error("You must supply a role name to look for");
238 foreach my $class ($self->class_precedence_list) {
239 my $meta = Class::MOP::class_of($class);
240 # when a Moose metaclass is itself extended with a role,
241 # this check needs to be done since some items in the
242 # class_precedence_list might in fact be Class::MOP
244 next unless $meta && $meta->can('roles');
245 foreach my $role (@{$meta->roles}) {
246 return 1 if $role->excludes_role($role_name);
254 my $params = @_ == 1 ? $_[0] : {@_};
255 my $self = $class->SUPER::new_object($params);
257 foreach my $attr ( $class->get_all_attributes() ) {
259 next unless $attr->can('has_trigger') && $attr->has_trigger;
261 my $init_arg = $attr->init_arg;
263 next unless defined $init_arg;
265 next unless exists $params->{$init_arg};
271 ? $attr->get_read_method_ref->($self)
272 : $params->{$init_arg}
283 foreach my $super (@supers) {
284 Class::MOP::load_class($super);
285 my $meta = Class::MOP::class_of($super);
286 $self->throw_error("You cannot inherit from a Moose Role ($super)")
287 if $meta && $meta->isa('Moose::Meta::Role')
289 return $self->SUPER::superclasses(@supers);
292 ### ---------------------------------------------
297 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
299 : $self->_process_attribute(@_));
300 $self->SUPER::add_attribute($attr);
301 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
302 # 'bare' and doesn't implement this method
303 if ($attr->can('_check_associated_methods')) {
304 $attr->_check_associated_methods;
309 sub add_override_method_modifier {
310 my ($self, $name, $method, $_super_package) = @_;
312 (!$self->has_method($name))
313 || $self->throw_error("Cannot add an override method if a local method is already present");
315 $self->add_method($name => Moose::Meta::Method::Overridden->new(
318 package => $_super_package, # need this for roles
323 sub add_augment_method_modifier {
324 my ($self, $name, $method) = @_;
325 (!$self->has_method($name))
326 || $self->throw_error("Cannot add an augment method if a local method is already present");
328 $self->add_method($name => Moose::Meta::Method::Augmented->new(
335 ## Private Utility methods ...
337 sub _find_next_method_by_name_which_is_not_overridden {
338 my ($self, $name) = @_;
339 foreach my $method ($self->find_all_methods_by_name($name)) {
340 return $method->{code}
341 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
346 sub _fix_metaclass_incompatibility {
347 my ($self, @superclasses) = @_;
349 $self->_fix_one_incompatible_metaclass($_)
350 for map { Moose::Meta::Class->initialize($_) } @superclasses;
353 sub _fix_one_incompatible_metaclass {
354 my ($self, $meta) = @_;
356 return if $self->_superclass_meta_is_compatible($meta);
358 unless ( $self->is_pristine ) {
360 "Cannot attempt to reinitialize metaclass for "
362 . ", it isn't pristine" );
365 $self->_reconcile_with_superclass_meta($meta);
368 sub _superclass_meta_is_compatible {
369 my ($self, $super_meta) = @_;
371 next unless $super_meta->isa("Class::MOP::Class");
374 = $super_meta->is_immutable
375 ? $super_meta->_get_mutable_metaclass_name
379 if $self->isa($super_meta_name)
381 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
384 # I don't want to have to type this >1 time
386 qw( attribute_metaclass
388 wrapped_method_metaclass
394 sub _reconcile_with_superclass_meta {
395 my ($self, $super_meta) = @_;
398 = $super_meta->is_immutable
399 ? $super_meta->_get_mutable_metaclass_name
402 my $self_metaclass = ref $self;
404 # If neither of these is true we have a more serious
405 # incompatibility that we just cannot fix (yet?).
406 if ( $super_meta_name->isa( ref $self )
407 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
408 $self->_reinitialize_with($super_meta);
410 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
411 $self->_reconcile_role_differences($super_meta);
415 sub _reinitialize_with {
416 my ( $self, $new_meta ) = @_;
418 my $new_self = $new_meta->reinitialize(
420 attribute_metaclass => $new_meta->attribute_metaclass,
421 method_metaclass => $new_meta->method_metaclass,
422 instance_metaclass => $new_meta->instance_metaclass,
425 $new_self->$_( $new_meta->$_ )
426 for qw( constructor_class destructor_class error_class );
430 bless $self, ref $new_self;
432 # We need to replace the cached metaclass instance or else when it
433 # goes out of scope Class::MOP::Class destroy's the namespace for
434 # the metaclass's class, causing much havoc.
435 Class::MOP::store_metaclass_by_name( $self->name, $self );
436 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
439 # In the more complex case, we share a common ancestor with our
440 # superclass's metaclass, but each metaclass (ours and the parent's)
441 # has a different set of roles applied. We reconcile this by first
442 # reinitializing into the parent class, and _then_ applying our own
444 sub _all_metaclasses_differ_by_roles_only {
445 my ($self, $super_meta) = @_;
448 [ ref $self, ref $super_meta ],
449 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
452 next if $pair->[0] eq $pair->[1];
454 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
455 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
458 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
460 return unless $common_ancestor;
463 unless _is_role_only_subclass_of(
467 && _is_role_only_subclass_of(
476 # This, and some other functions, could be called as methods, but
477 # they're not for two reasons. One, we just end up ignoring the first
478 # argument, because we can't call these directly on one of the real
479 # arguments, because one of them could be a Class::MOP::Class object
480 # and not a Moose::Meta::Class. Second, only a completely insane
481 # person would attempt to subclass this stuff!
482 sub _find_common_ancestor {
483 my ($meta1, $meta2) = @_;
485 # FIXME? This doesn't account for multiple inheritance (not sure
486 # if it needs to though). For example, is somewhere in $meta1's
487 # history it inherits from both ClassA and ClassB, and $meta2
488 # inherits from ClassB & ClassA, does it matter? And what crazy
489 # fool would do that anyway?
491 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
493 return first { $meta1_parents{$_} } $meta2->linearized_isa;
496 sub _is_role_only_subclass_of {
497 my ($meta, $ancestor) = @_;
499 return 1 if $meta->name eq $ancestor;
501 my @roles = _all_roles_until( $meta, $ancestor );
503 my %role_packages = map { $_->name => 1 } @roles;
505 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
507 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
509 for my $method ( $meta->get_all_methods() ) {
510 next if $method->name eq 'meta';
511 next if $method->can('associated_attribute');
514 if $role_packages{ $method->original_package_name }
515 || $shared_ancestors{ $method->original_package_name };
520 # FIXME - this really isn't right. Just because an attribute is
521 # defined in a role doesn't mean it isn't _also_ defined in the
523 for my $attr ( $meta->get_all_attributes ) {
524 next if $shared_ancestors{ $attr->associated_class->name };
526 next if any { $_->has_attribute( $attr->name ) } @roles;
537 return _all_roles_until($meta);
540 sub _all_roles_until {
541 my ($meta, $stop_at_class) = @_;
543 return unless $meta->can('calculate_all_roles');
545 my @roles = $meta->calculate_all_roles;
547 for my $class ( $meta->linearized_isa ) {
548 last if $stop_at_class && $stop_at_class eq $class;
550 my $meta = Class::MOP::Class->initialize($class);
551 last unless $meta->can('calculate_all_roles');
553 push @roles, $meta->calculate_all_roles;
559 sub _reconcile_role_differences {
560 my ($self, $super_meta) = @_;
562 my $self_meta = Class::MOP::class_of($self);
566 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
567 $roles{metaclass_roles} = \@roles;
570 for my $thing (@MetaClassTypes) {
571 my $name = $self->$thing();
573 my $thing_meta = Class::MOP::Class->initialize($name);
575 my @roles = map { $_->name } _all_roles($thing_meta)
578 $roles{ $thing . '_roles' } = \@roles;
581 $self->_reinitialize_with($super_meta);
583 Moose::Util::MetaRole::apply_metaclass_roles(
584 for_class => $self->name,
591 sub _process_attribute {
592 my ( $self, $name, @args ) = @_;
594 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
596 if (($name || '') =~ /^\+(.*)/) {
597 return $self->_process_inherited_attribute($1, @args);
600 return $self->_process_new_attribute($name, @args);
604 sub _process_new_attribute {
605 my ( $self, $name, @args ) = @_;
607 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
610 sub _process_inherited_attribute {
611 my ($self, $attr_name, %options) = @_;
612 my $inherited_attr = $self->find_attribute_by_name($attr_name);
613 (defined $inherited_attr)
614 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
615 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
616 return $inherited_attr->clone_and_inherit_options(%options);
620 # kind of a kludge to handle Class::MOP::Attributes
621 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
625 ## -------------------------------------------------
630 my ( $self, @args ) = @_;
631 local $error_level = ($error_level || 0) + 1;
632 $self->raise_error($self->create_error(@args));
636 my ( $self, @args ) = @_;
641 my ( $self, @args ) = @_;
645 local $error_level = ($error_level || 0 ) + 1;
647 if ( @args % 2 == 1 ) {
648 unshift @args, "message";
651 my %args = ( metaclass => $self, last_error => $@, @args );
653 $args{depth} += $error_level;
655 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
657 Class::MOP::load_class($class);
660 Carp::caller_info($args{depth}),
673 Moose::Meta::Class - The Moose metaclass
677 This class is a subclass of L<Class::MOP::Class> that provides
678 additional Moose-specific functionality.
680 To really understand this class, you will need to start with the
681 L<Class::MOP::Class> documentation. This class can be understood as a
682 set of additional features on top of the basic feature provided by
687 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
693 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
695 This overrides the parent's method in order to provide its own
696 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
697 C<method_metaclass> options.
699 These all default to the appropriate Moose class.
701 =item B<< Moose::Meta::Class->create($package_name, %options) >>
703 This overrides the parent's method in order to accept a C<roles>
704 option. This should be an array reference containing roles
705 that the class does, each optionally followed by a hashref of options
706 (C<-excludes> and C<-alias>).
708 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
710 =item B<< Moose::Meta::Class->create_anon_class >>
712 This overrides the parent's method to accept a C<roles> option, just
715 It also accepts a C<cache> option. If this is true, then the anonymous
716 class will be cached based on its superclasses and roles. If an
717 existing anonymous class in the cache has the same superclasses and
718 roles, it will be reused.
720 my $metaclass = Moose::Meta::Class->create_anon_class(
721 superclasses => ['Foo'],
722 roles => [qw/Some Roles Go Here/],
726 =item B<< $metaclass->make_immutable(%options) >>
728 This overrides the parent's method to add a few options. Specifically,
729 it uses the Moose-specific constructor and destructor classes, and
730 enables inlining the destructor.
732 Also, since Moose always inlines attributes, it sets the
733 C<inline_accessors> option to false.
735 =item B<< $metaclass->new_object(%params) >>
737 This overrides the parent's method in order to add support for
740 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
742 This adds an C<override> method modifier to the package.
744 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
746 This adds an C<augment> method modifier to the package.
748 =item B<< $metaclass->calculate_all_roles >>
750 This will return a unique array of C<Moose::Meta::Role> instances
751 which are attached to this class.
753 =item B<< $metaclass->add_role($role) >>
755 This takes a L<Moose::Meta::Role> object, and adds it to the class's
756 list of roles. This I<does not> actually apply the role to the class.
758 =item B<< $metaclass->role_applications >>
760 Returns a list of L<Moose::Meta::Role::Application::ToClass>
761 objects, which contain the arguments to role application.
763 =item B<< $metaclass->add_role_application($application) >>
765 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
766 adds it to the class's list of role applications. This I<does not>
767 actually apply any role to the class; it is only for tracking role
770 =item B<< $metaclass->does_role($role) >>
772 This returns a boolean indicating whether or not the class does the specified
773 role. The role provided can be either a role name or a L<Moose::Meta::Role>
774 object. This tests both the class and its parents.
776 =item B<< $metaclass->excludes_role($role_name) >>
778 A class excludes a role if it has already composed a role which
779 excludes the named role. This tests both the class and its parents.
781 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
783 This overrides the parent's method in order to allow the parameters to
784 be provided as a hash reference.
786 =item B<< $metaclass->constructor_class ($class_name) >>
788 =item B<< $metaclass->destructor_class ($class_name) >>
790 These are the names of classes used when making a class
791 immutable. These default to L<Moose::Meta::Method::Constructor> and
792 L<Moose::Meta::Method::Destructor> respectively. These accessors are
793 read-write, so you can use them to change the class name.
795 =item B<< $metaclass->error_class($class_name) >>
797 The name of the class used to throw errors. This defaults to
798 L<Moose::Error::Default>, which generates an error with a stacktrace
799 just like C<Carp::confess>.
801 =item B<< $metaclass->throw_error($message, %extra) >>
803 Throws the error created by C<create_error> using C<raise_error>
809 See L<Moose/BUGS> for details on reporting bugs.
813 Stevan Little E<lt>stevan@iinteractive.comE<gt>
815 =head1 COPYRIGHT AND LICENSE
817 Copyright 2006-2010 by Infinity Interactive, Inc.
819 L<http://www.iinteractive.com>
821 This library is free software; you can redistribute it and/or modify
822 it under the same terms as Perl itself.