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.83';
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 ### ---------------------------------------------
246 $self->SUPER::add_attribute(
247 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
249 : $self->_process_attribute(@_))
253 sub add_override_method_modifier {
254 my ($self, $name, $method, $_super_package) = @_;
256 (!$self->has_method($name))
257 || $self->throw_error("Cannot add an override method if a local method is already present");
259 $self->add_method($name => Moose::Meta::Method::Overridden->new(
262 package => $_super_package, # need this for roles
267 sub add_augment_method_modifier {
268 my ($self, $name, $method) = @_;
269 (!$self->has_method($name))
270 || $self->throw_error("Cannot add an augment method if a local method is already present");
272 $self->add_method($name => Moose::Meta::Method::Augmented->new(
279 ## Private Utility methods ...
281 sub _find_next_method_by_name_which_is_not_overridden {
282 my ($self, $name) = @_;
283 foreach my $method ($self->find_all_methods_by_name($name)) {
284 return $method->{code}
285 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
290 sub _fix_metaclass_incompatibility {
291 my ($self, @superclasses) = @_;
293 foreach my $super (@superclasses) {
294 my $meta = Class::MOP::Class->initialize($super);
296 my @all_supers = $meta->linearized_isa;
299 my @super_metas_to_fix = ($meta);
301 # We need to check & fix the immediate superclass. If its @ISA
302 # contains a class without a metaclass instance, followed by a
303 # class _with_ a metaclass instance, init a metaclass instance
304 # for classes without one and fix compat up to and including
305 # the class which was already initialized.
306 my $idx = first_index { Class::MOP::class_of($_) } @all_supers;
308 push @super_metas_to_fix,
309 map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ]
312 foreach my $super_meta (@super_metas_to_fix) {
313 $self->_fix_one_incompatible_metaclass($super_meta);
318 sub _fix_one_incompatible_metaclass {
319 my ($self, $meta) = @_;
321 return if $self->_superclass_meta_is_compatible($meta);
323 unless ( $self->is_pristine ) {
325 "Cannot attempt to reinitialize metaclass for "
327 . ", it isn't pristine" );
330 $self->_reconcile_with_superclass_meta($meta);
333 sub _superclass_meta_is_compatible {
334 my ($self, $super_meta) = @_;
336 next unless $super_meta->isa("Class::MOP::Class");
339 = $super_meta->is_immutable
340 ? $super_meta->get_mutable_metaclass_name
344 if $self->isa($super_meta_name)
346 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
349 # I don't want to have to type this >1 time
351 qw( attribute_metaclass
353 wrapped_method_metaclass
359 sub _reconcile_with_superclass_meta {
360 my ($self, $super_meta) = @_;
363 = $super_meta->is_immutable
364 ? $super_meta->get_mutable_metaclass_name
367 my $self_metaclass = ref $self;
369 # If neither of these is true we have a more serious
370 # incompatibility that we just cannot fix (yet?).
371 if ( $super_meta_name->isa( ref $self )
372 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
373 $self->_reinitialize_with($super_meta);
375 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
376 $self->_reconcile_role_differences($super_meta);
380 sub _reinitialize_with {
381 my ( $self, $new_meta ) = @_;
383 my $new_self = $new_meta->reinitialize(
385 attribute_metaclass => $new_meta->attribute_metaclass,
386 method_metaclass => $new_meta->method_metaclass,
387 instance_metaclass => $new_meta->instance_metaclass,
390 $new_self->$_( $new_meta->$_ )
391 for qw( constructor_class destructor_class error_class );
395 bless $self, ref $new_self;
397 # We need to replace the cached metaclass instance or else when it
398 # goes out of scope Class::MOP::Class destroy's the namespace for
399 # the metaclass's class, causing much havoc.
400 Class::MOP::store_metaclass_by_name( $self->name, $self );
401 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
404 # In the more complex case, we share a common ancestor with our
405 # superclass's metaclass, but each metaclass (ours and the parent's)
406 # has a different set of roles applied. We reconcile this by first
407 # reinitializing into the parent class, and _then_ applying our own
409 sub _all_metaclasses_differ_by_roles_only {
410 my ($self, $super_meta) = @_;
413 [ ref $self, ref $super_meta ],
414 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
417 next if $pair->[0] eq $pair->[1];
419 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
420 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
423 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
425 return unless $common_ancestor;
428 unless _is_role_only_subclass_of(
432 && _is_role_only_subclass_of(
441 # This, and some other functions, could be called as methods, but
442 # they're not for two reasons. One, we just end up ignoring the first
443 # argument, because we can't call these directly on one of the real
444 # arguments, because one of them could be a Class::MOP::Class object
445 # and not a Moose::Meta::Class. Second, only a completely insane
446 # person would attempt to subclass this stuff!
447 sub _find_common_ancestor {
448 my ($meta1, $meta2) = @_;
450 # FIXME? This doesn't account for multiple inheritance (not sure
451 # if it needs to though). For example, is somewhere in $meta1's
452 # history it inherits from both ClassA and ClassB, and $meta2
453 # inherits from ClassB & ClassA, does it matter? And what crazy
454 # fool would do that anyway?
456 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
458 return first { $meta1_parents{$_} } $meta2->linearized_isa;
461 sub _is_role_only_subclass_of {
462 my ($meta, $ancestor) = @_;
464 return 1 if $meta->name eq $ancestor;
466 my @roles = _all_roles_until( $meta, $ancestor );
468 my %role_packages = map { $_->name => 1 } @roles;
470 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
472 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
474 for my $method ( $meta->get_all_methods() ) {
475 next if $method->name eq 'meta';
476 next if $method->can('associated_attribute');
479 if $role_packages{ $method->original_package_name }
480 || $shared_ancestors{ $method->original_package_name };
485 # FIXME - this really isn't right. Just because an attribute is
486 # defined in a role doesn't mean it isn't _also_ defined in the
488 for my $attr ( $meta->get_all_attributes ) {
489 next if $shared_ancestors{ $attr->associated_class->name };
491 next if any { $_->has_attribute( $attr->name ) } @roles;
502 return _all_roles_until($meta);
505 sub _all_roles_until {
506 my ($meta, $stop_at_class) = @_;
508 return unless $meta->can('calculate_all_roles');
510 my @roles = $meta->calculate_all_roles;
512 for my $class ( $meta->linearized_isa ) {
513 last if $stop_at_class && $stop_at_class eq $class;
515 my $meta = Class::MOP::Class->initialize($class);
516 last unless $meta->can('calculate_all_roles');
518 push @roles, $meta->calculate_all_roles;
524 sub _reconcile_role_differences {
525 my ($self, $super_meta) = @_;
527 my $self_meta = Class::MOP::class_of($self);
531 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
532 $roles{metaclass_roles} = \@roles;
535 for my $thing (@MetaClassTypes) {
536 my $name = $self->$thing();
538 my $thing_meta = Class::MOP::Class->initialize($name);
540 my @roles = map { $_->name } _all_roles($thing_meta)
543 $roles{ $thing . '_roles' } = \@roles;
546 $self->_reinitialize_with($super_meta);
548 Moose::Util::MetaRole::apply_metaclass_roles(
549 for_class => $self->name,
556 sub _process_attribute {
557 my ( $self, $name, @args ) = @_;
559 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
561 if (($name || '') =~ /^\+(.*)/) {
562 return $self->_process_inherited_attribute($1, @args);
565 return $self->_process_new_attribute($name, @args);
569 sub _process_new_attribute {
570 my ( $self, $name, @args ) = @_;
572 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
575 sub _process_inherited_attribute {
576 my ($self, $attr_name, %options) = @_;
577 my $inherited_attr = $self->find_attribute_by_name($attr_name);
578 (defined $inherited_attr)
579 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
580 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
581 return $inherited_attr->clone_and_inherit_options(%options);
585 # kind of a kludge to handle Class::MOP::Attributes
586 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
590 ## -------------------------------------------------
595 my ( $self, @args ) = @_;
596 local $error_level = ($error_level || 0) + 1;
597 $self->raise_error($self->create_error(@args));
601 my ( $self, @args ) = @_;
606 my ( $self, @args ) = @_;
610 local $error_level = ($error_level || 0 ) + 1;
612 if ( @args % 2 == 1 ) {
613 unshift @args, "message";
616 my %args = ( metaclass => $self, last_error => $@, @args );
618 $args{depth} += $error_level;
620 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
622 Class::MOP::load_class($class);
625 Carp::caller_info($args{depth}),
638 Moose::Meta::Class - The Moose metaclass
642 This class is a subclass of L<Class::MOP::Class> that provides
643 additional Moose-specific functionality.
645 To really understand this class, you will need to start with the
646 L<Class::MOP::Class> documentation. This class can be understood as a
647 set of additional features on top of the basic feature provided by
652 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
658 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
660 This overrides the parent's method in order to provide its own
661 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
662 C<method_metaclass> options.
664 These all default to the appropriate Moose class.
666 =item B<< Moose::Meta::Class->create($package_name, %options) >>
668 This overrides the parent's method in order to accept a C<roles>
669 option. This should be an array reference containing one more roles
672 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
674 =item B<< Moose::Meta::Class->create_anon_class >>
676 This overrides the parent's method to accept a C<roles> option, just
679 It also accepts a C<cache> option. If this is true, then the anonymous
680 class will be cached based on its superclasses and roles. If an
681 existing anonymous class in the cache has the same superclasses and
682 roles, it will be reused.
684 my $metaclass = Moose::Meta::Class->create_anon_class(
685 superclasses => ['Foo'],
686 roles => [qw/Some Roles Go Here/],
690 =item B<< $metaclass->make_immutable(%options) >>
692 This overrides the parent's method to add a few options. Specifically,
693 it uses the Moose-specific constructor and destructor classes, and
694 enables inlining the destructor.
696 Also, since Moose always inlines attributes, it sets the
697 C<inline_accessors> option to false.
699 =item B<< $metaclass->new_object(%params) >>
701 This overrides the parent's method in order to add support for
704 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
706 This adds an C<override> method modifier to the package.
708 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
710 This adds an C<augment> method modifier to the package.
712 =item B<< $metaclass->calculate_all_roles >>
714 This will return a unique array of C<Moose::Meta::Role> instances
715 which are attached to this class.
717 =item B<< $metaclass->add_role($role) >>
719 This takes a L<Moose::Meta::Role> object, and adds it to the class's
720 list of roles. This I<does not> actually apply the role to the class.
722 =item B<< $metaclass->role_applications >>
724 Returns a list of L<Moose::Meta::Role::Application::ToClass>
725 objects, which contain the arguments to role application.
727 =item B<< $metaclass->add_role_application($application) >>
729 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
730 adds it to the class's list of role applications. This I<does not>
731 actually apply any role to the class; it is only for tracking role
734 =item B<< $metaclass->does_role($role_name) >>
736 This returns a boolean indicating whether or not the class does the
737 specified role. This tests both the class and its parents.
739 =item B<< $metaclass->excludes_role($role_name) >>
741 A class excludes a role if it has already composed a role which
742 excludes the named role. This tests both the class and its parents.
744 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
746 This overrides the parent's method in order to allow the parameters to
747 be provided as a hash reference.
749 =item B<< $metaclass->constructor_class ($class_name) >>
751 =item B<< $metaclass->destructor_class ($class_name) >>
753 These are the names of classes used when making a class
754 immutable. These default to L<Moose::Meta::Method::Constructor> and
755 L<Moose::Meta::Method::Destructor> respectively. These accessors are
756 read-write, so you can use them to change the class name.
758 =item B<< $metaclass->error_class($class_name) >>
760 The name of the class used to throw errors. This defaults to
761 L<Moose::Error::Default>, which generates an error with a stacktrace
762 just like C<Carp::confess>.
764 =item B<< $metaclass->throw_error($message, %extra) >>
766 Throws the error created by C<create_error> using C<raise_error>
772 All complex software has bugs lurking in it, and this module is no
773 exception. If you find a bug please either email me, or add the bug
778 Stevan Little E<lt>stevan@iinteractive.comE<gt>
780 =head1 COPYRIGHT AND LICENSE
782 Copyright 2006-2009 by Infinity Interactive, Inc.
784 L<http://www.iinteractive.com>
786 This library is free software; you can redistribute it and/or modify
787 it under the same terms as Perl itself.