2 package Moose::Meta::Class;
10 use List::Util qw( first );
11 use List::MoreUtils qw( any all uniq );
12 use Scalar::Util 'weaken', 'blessed';
14 our $VERSION = '0.75';
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' => (
33 __PACKAGE__->meta->add_attribute(
34 Class::MOP::Attribute->new('immutable_trait' => (
35 accessor => "immutable_trait",
36 default => 'Moose::Meta::Class::Immutable::Trait',
40 __PACKAGE__->meta->add_attribute('constructor_class' => (
41 accessor => 'constructor_class',
42 default => 'Moose::Meta::Method::Constructor',
45 __PACKAGE__->meta->add_attribute('destructor_class' => (
46 accessor => 'destructor_class',
47 default => 'Moose::Meta::Method::Destructor',
50 __PACKAGE__->meta->add_attribute('error_class' => (
51 accessor => 'error_class',
52 default => 'Moose::Error::Default',
58 return Class::MOP::get_metaclass_by_name($pkg)
59 || $class->SUPER::initialize($pkg,
60 'attribute_metaclass' => 'Moose::Meta::Attribute',
61 'method_metaclass' => 'Moose::Meta::Method',
62 'instance_metaclass' => 'Moose::Meta::Instance',
67 sub _immutable_options {
68 my ( $self, @args ) = @_;
70 $self->SUPER::_immutable_options(
71 inline_destructor => 1,
73 # Moose always does this when an attribute is created
74 inline_accessors => 0,
81 my ($self, $package_name, %options) = @_;
83 (ref $options{roles} eq 'ARRAY')
84 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
85 if exists $options{roles};
86 my $roles = delete $options{roles};
88 my $class = $self->SUPER::create($package_name, %options);
91 Moose::Util::apply_all_roles( $class, @$roles );
97 sub _check_metaclass_compatibility {
100 if ( my @supers = $self->superclasses ) {
101 $self->_fix_metaclass_incompatibility(@supers);
104 $self->SUPER::_check_metaclass_compatibility(@_);
109 sub create_anon_class {
110 my ($self, %options) = @_;
112 my $cache_ok = delete $options{cache};
114 # something like Super::Class|Super::Class::2=Role|Role::1
115 my $cache_key = join '=' => (
116 join('|', @{$options{superclasses} || []}),
117 join('|', sort @{$options{roles} || []}),
120 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
121 return $ANON_CLASSES{$cache_key};
124 my $new_class = $self->SUPER::create_anon_class(%options);
126 $ANON_CLASSES{$cache_key} = $new_class
133 my ($self, $role) = @_;
134 (blessed($role) && $role->isa('Moose::Meta::Role'))
135 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
136 push @{$self->roles} => $role;
139 sub calculate_all_roles {
142 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
146 my ($self, $role_name) = @_;
149 || $self->throw_error("You must supply a role name to look for");
151 foreach my $class ($self->class_precedence_list) {
152 my $meta = Class::MOP::class_of($class);
153 # when a Moose metaclass is itself extended with a role,
154 # this check needs to be done since some items in the
155 # class_precedence_list might in fact be Class::MOP
157 next unless $meta && $meta->can('roles');
158 foreach my $role (@{$meta->roles}) {
159 return 1 if $role->does_role($role_name);
166 my ($self, $role_name) = @_;
169 || $self->throw_error("You must supply a role name to look for");
171 foreach my $class ($self->class_precedence_list) {
172 my $meta = Class::MOP::class_of($class);
173 # when a Moose metaclass is itself extended with a role,
174 # this check needs to be done since some items in the
175 # class_precedence_list might in fact be Class::MOP
177 next unless $meta && $meta->can('roles');
178 foreach my $role (@{$meta->roles}) {
179 return 1 if $role->excludes_role($role_name);
187 my $params = @_ == 1 ? $_[0] : {@_};
188 my $self = $class->SUPER::new_object($params);
190 foreach my $attr ( $class->get_all_attributes() ) {
192 next unless $attr->can('has_trigger') && $attr->has_trigger;
194 my $init_arg = $attr->init_arg;
196 next unless defined $init_arg;
198 next unless exists $params->{$init_arg};
204 ? $attr->get_read_method_ref->($self)
205 : $params->{$init_arg}
213 sub _construct_instance {
215 my $params = @_ == 1 ? $_[0] : {@_};
216 my $meta_instance = $class->get_meta_instance;
218 # the code below is almost certainly incorrect
219 # but this is foreign inheritance, so we might
220 # have to kludge it in the end.
221 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
222 foreach my $attr ($class->get_all_attributes()) {
223 $attr->initialize_instance_slot($meta_instance, $instance, $params);
231 foreach my $super (@supers) {
232 my $meta = Class::MOP::load_class($super);
233 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
234 if $meta && $meta->isa('Moose::Meta::Role')
236 return $self->SUPER::superclasses(@supers);
239 ### ---------------------------------------------
243 $self->SUPER::add_attribute(
244 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
246 : $self->_process_attribute(@_))
250 sub add_override_method_modifier {
251 my ($self, $name, $method, $_super_package) = @_;
253 (!$self->has_method($name))
254 || $self->throw_error("Cannot add an override method if a local method is already present");
256 $self->add_method($name => Moose::Meta::Method::Overridden->new(
259 package => $_super_package, # need this for roles
264 sub add_augment_method_modifier {
265 my ($self, $name, $method) = @_;
266 (!$self->has_method($name))
267 || $self->throw_error("Cannot add an augment method if a local method is already present");
269 $self->add_method($name => Moose::Meta::Method::Augmented->new(
276 ## Private Utility methods ...
278 sub _find_next_method_by_name_which_is_not_overridden {
279 my ($self, $name) = @_;
280 foreach my $method ($self->find_all_methods_by_name($name)) {
281 return $method->{code}
282 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
287 sub _fix_metaclass_incompatibility {
288 my ($self, @superclasses) = @_;
290 foreach my $super (@superclasses) {
291 next if $self->_superclass_meta_is_compatible($super);
293 unless ( $self->is_pristine ) {
295 "Cannot attempt to reinitialize metaclass for "
297 . ", it isn't pristine" );
300 $self->_reconcile_with_superclass_meta($super);
304 sub _superclass_meta_is_compatible {
305 my ($self, $super) = @_;
307 my $super_meta = Class::MOP::Class->initialize($super)
310 next unless $super_meta->isa("Class::MOP::Class");
313 = $super_meta->is_immutable
314 ? $super_meta->get_mutable_metaclass_name
318 if $self->isa($super_meta_name)
320 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
323 # I don't want to have to type this >1 time
325 qw( attribute_metaclass method_metaclass instance_metaclass
326 constructor_class destructor_class error_class );
328 sub _reconcile_with_superclass_meta {
329 my ($self, $super) = @_;
331 my $super_meta = Class::MOP::class_of($super);
334 = $super_meta->is_immutable
335 ? $super_meta->get_mutable_metaclass_name
338 my $self_metaclass = ref $self;
340 # If neither of these is true we have a more serious
341 # incompatibility that we just cannot fix (yet?).
342 if ( $super_meta_name->isa( ref $self )
343 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
344 $self->_reinitialize_with($super_meta);
346 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
347 $self->_reconcile_role_differences($super_meta);
351 sub _reinitialize_with {
352 my ( $self, $new_meta ) = @_;
354 my $new_self = $new_meta->reinitialize(
356 attribute_metaclass => $new_meta->attribute_metaclass,
357 method_metaclass => $new_meta->method_metaclass,
358 instance_metaclass => $new_meta->instance_metaclass,
361 $new_self->$_( $new_meta->$_ )
362 for qw( constructor_class destructor_class error_class );
366 bless $self, ref $new_self;
368 # We need to replace the cached metaclass instance or else when it
369 # goes out of scope Class::MOP::Class destroy's the namespace for
370 # the metaclass's class, causing much havoc.
371 Class::MOP::store_metaclass_by_name( $self->name, $self );
372 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
375 # In the more complex case, we share a common ancestor with our
376 # superclass's metaclass, but each metaclass (ours and the parent's)
377 # has a different set of roles applied. We reconcile this by first
378 # reinitializing into the parent class, and _then_ applying our own
380 sub _all_metaclasses_differ_by_roles_only {
381 my ($self, $super_meta) = @_;
384 [ ref $self, ref $super_meta ],
385 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
388 next if $pair->[0] eq $pair->[1];
390 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
391 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
394 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
396 return unless $common_ancestor;
399 unless _is_role_only_subclass_of(
403 && _is_role_only_subclass_of(
412 # This, and some other functions, could be called as methods, but
413 # they're not for two reasons. One, we just end up ignoring the first
414 # argument, because we can't call these directly on one of the real
415 # arguments, because one of them could be a Class::MOP::Class object
416 # and not a Moose::Meta::Class. Second, only a completely insane
417 # person would attempt to subclass this stuff!
418 sub _find_common_ancestor {
419 my ($meta1, $meta2) = @_;
421 # FIXME? This doesn't account for multiple inheritance (not sure
422 # if it needs to though). For example, is somewhere in $meta1's
423 # history it inherits from both ClassA and ClassB, and $meta2
424 # inherits from ClassB & ClassA, does it matter? And what crazy
425 # fool would do that anyway?
427 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
429 return first { $meta1_parents{$_} } $meta2->linearized_isa;
432 sub _is_role_only_subclass_of {
433 my ($meta, $ancestor) = @_;
435 return 1 if $meta->name eq $ancestor;
437 my @roles = _all_roles_until( $meta, $ancestor );
439 my %role_packages = map { $_->name => 1 } @roles;
441 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
443 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
445 for my $method ( $meta->get_all_methods() ) {
446 next if $method->name eq 'meta';
447 next if $method->can('associated_attribute');
450 if $role_packages{ $method->original_package_name }
451 || $shared_ancestors{ $method->original_package_name };
456 # FIXME - this really isn't right. Just because an attribute is
457 # defined in a role doesn't mean it isn't _also_ defined in the
459 for my $attr ( $meta->get_all_attributes ) {
460 next if $shared_ancestors{ $attr->associated_class->name };
462 next if any { $_->has_attribute( $attr->name ) } @roles;
473 return _all_roles_until($meta);
476 sub _all_roles_until {
477 my ($meta, $stop_at_class) = @_;
479 return unless $meta->can('calculate_all_roles');
481 my @roles = $meta->calculate_all_roles;
483 for my $class ( $meta->linearized_isa ) {
484 last if $stop_at_class && $stop_at_class eq $class;
486 my $meta = Class::MOP::Class->initialize($class);
487 last unless $meta->can('calculate_all_roles');
489 push @roles, $meta->calculate_all_roles;
495 sub _reconcile_role_differences {
496 my ($self, $super_meta) = @_;
498 my $self_meta = Class::MOP::class_of($self);
502 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
503 $roles{metaclass_roles} = \@roles;
506 for my $thing (@MetaClassTypes) {
507 my $name = $self->$thing();
509 my $thing_meta = Class::MOP::Class->initialize($name);
511 my @roles = map { $_->name } _all_roles($thing_meta)
514 $roles{ $thing . '_roles' } = \@roles;
517 $self->_reinitialize_with($super_meta);
519 Moose::Util::MetaRole::apply_metaclass_roles(
520 for_class => $self->name,
527 sub _process_attribute {
528 my ( $self, $name, @args ) = @_;
530 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
532 if (($name || '') =~ /^\+(.*)/) {
533 return $self->_process_inherited_attribute($1, @args);
536 return $self->_process_new_attribute($name, @args);
540 sub _process_new_attribute {
541 my ( $self, $name, @args ) = @_;
543 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
546 sub _process_inherited_attribute {
547 my ($self, $attr_name, %options) = @_;
548 my $inherited_attr = $self->find_attribute_by_name($attr_name);
549 (defined $inherited_attr)
550 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
551 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
552 return $inherited_attr->clone_and_inherit_options(%options);
556 # kind of a kludge to handle Class::MOP::Attributes
557 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
561 ## -------------------------------------------------
566 my ( $self, @args ) = @_;
567 local $error_level = ($error_level || 0) + 1;
568 $self->raise_error($self->create_error(@args));
572 my ( $self, @args ) = @_;
577 my ( $self, @args ) = @_;
581 local $error_level = ($error_level || 0 ) + 1;
583 if ( @args % 2 == 1 ) {
584 unshift @args, "message";
587 my %args = ( metaclass => $self, last_error => $@, @args );
589 $args{depth} += $error_level;
591 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
593 Class::MOP::load_class($class);
596 Carp::caller_info($args{depth}),
609 Moose::Meta::Class - The Moose metaclass
613 This class is a subclass of L<Class::MOP::Class> that provides
614 additional Moose-specific functionality.
616 To really understand this class, you will need to start with the
617 L<Class::MOP::Class> documentation. This class can be understood as a
618 set of additional features on top of the basic feature provided by
623 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
629 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
631 This overrides the parent's method in order to provide its own
632 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
633 C<method_metaclass> options.
635 These all default to the appropriate Moose class.
637 =item B<< Moose::Meta::Class->create($package_name, %options) >>
639 This overrides the parent's method in order to accept a C<roles>
640 option. This should be an array reference containing one more roles
643 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
645 =item B<< Moose::Meta::Class->create_anon_class >>
647 This overrides the parent's method to accept a C<roles> option, just
650 It also accepts a C<cache> option. If this is true, then the anonymous
651 class will be cached based on its superclasses and roles. If an
652 existing anonymous class in the cache has the same superclasses and
653 roles, it will be reused.
655 my $metaclass = Moose::Meta::Class->create_anon_class(
656 superclasses => ['Foo'],
657 roles => [qw/Some Roles Go Here/],
661 =item B<< $metaclass->make_immutable(%options) >>
663 This overrides the parent's method to add a few options. Specifically,
664 it uses the Moose-specific constructor and destructor classes, and
665 enables inlining the destructor.
667 Also, since Moose always inlines attributes, it sets the
668 C<inline_accessors> option to false.
670 =item B<< $metaclass->new_object(%params) >>
672 This overrides the parent's method in order to add support for
675 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
677 This adds an C<override> method modifier to the package.
679 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
681 This adds an C<augment> method modifier to the package.
683 =item B<< $metaclass->calculate_all_roles >>
685 This will return a unique array of C<Moose::Meta::Role> instances
686 which are attached to this class.
688 =item B<< $metaclass->add_role($role) >>
690 This takes a L<Moose::Meta::Role> object, and adds it to the class's
691 list of roles. This I<does not> actually apply the role to the class.
693 =item B<< $metaclass->does_role($role_name) >>
695 This returns a boolean indicating whether or not the class does the
696 specified role. This tests both the class and its parents.
698 =item B<< $metaclass->excludes_role($role_name) >>
700 A class excludes a role if it has already composed a role which
701 excludes the named role. This tests both the class and its parents.
703 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
705 This overrides the parent's method in order to allow the parameters to
706 be provided as a hash reference.
708 =item B<< $metaclass->constructor_class ($class_name) >>
710 =item B<< $metaclass->destructor_class ($class_name) >>
712 These are the names of classes used when making a class
713 immutable. These default to L<Moose::Meta::Method::Constructor> and
714 L<Moose::Meta::Method::Destructor> respectively. These accessors are
715 read-write, so you can use them to change the class name.
717 =item B<< $metaclass->error_class($class_name) >>
719 The name of the class used to throw errors. This defaults to
720 L<Moose::Error::Default>, which generates an error with a stacktrace
721 just like C<Carp::confess>.
723 =item B<< $metaclass->throw_error($message, %extra) >>
725 Throws the error created by C<create_error> using C<raise_error>
731 All complex software has bugs lurking in it, and this module is no
732 exception. If you find a bug please either email me, or add the bug
737 Stevan Little E<lt>stevan@iinteractive.comE<gt>
739 =head1 COPYRIGHT AND LICENSE
741 Copyright 2006-2009 by Infinity Interactive, Inc.
743 L<http://www.iinteractive.com>
745 This library is free software; you can redistribute it and/or modify
746 it under the same terms as Perl itself.