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.77';
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
327 wrapped_method_metaclass
333 sub _reconcile_with_superclass_meta {
334 my ($self, $super) = @_;
336 my $super_meta = Class::MOP::class_of($super);
339 = $super_meta->is_immutable
340 ? $super_meta->get_mutable_metaclass_name
343 my $self_metaclass = ref $self;
345 # If neither of these is true we have a more serious
346 # incompatibility that we just cannot fix (yet?).
347 if ( $super_meta_name->isa( ref $self )
348 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
349 $self->_reinitialize_with($super_meta);
351 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
352 $self->_reconcile_role_differences($super_meta);
356 sub _reinitialize_with {
357 my ( $self, $new_meta ) = @_;
359 my $new_self = $new_meta->reinitialize(
361 attribute_metaclass => $new_meta->attribute_metaclass,
362 method_metaclass => $new_meta->method_metaclass,
363 instance_metaclass => $new_meta->instance_metaclass,
366 $new_self->$_( $new_meta->$_ )
367 for qw( constructor_class destructor_class error_class );
371 bless $self, ref $new_self;
373 # We need to replace the cached metaclass instance or else when it
374 # goes out of scope Class::MOP::Class destroy's the namespace for
375 # the metaclass's class, causing much havoc.
376 Class::MOP::store_metaclass_by_name( $self->name, $self );
377 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
380 # In the more complex case, we share a common ancestor with our
381 # superclass's metaclass, but each metaclass (ours and the parent's)
382 # has a different set of roles applied. We reconcile this by first
383 # reinitializing into the parent class, and _then_ applying our own
385 sub _all_metaclasses_differ_by_roles_only {
386 my ($self, $super_meta) = @_;
389 [ ref $self, ref $super_meta ],
390 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
393 next if $pair->[0] eq $pair->[1];
395 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
396 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
399 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
401 return unless $common_ancestor;
404 unless _is_role_only_subclass_of(
408 && _is_role_only_subclass_of(
417 # This, and some other functions, could be called as methods, but
418 # they're not for two reasons. One, we just end up ignoring the first
419 # argument, because we can't call these directly on one of the real
420 # arguments, because one of them could be a Class::MOP::Class object
421 # and not a Moose::Meta::Class. Second, only a completely insane
422 # person would attempt to subclass this stuff!
423 sub _find_common_ancestor {
424 my ($meta1, $meta2) = @_;
426 # FIXME? This doesn't account for multiple inheritance (not sure
427 # if it needs to though). For example, is somewhere in $meta1's
428 # history it inherits from both ClassA and ClassB, and $meta2
429 # inherits from ClassB & ClassA, does it matter? And what crazy
430 # fool would do that anyway?
432 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
434 return first { $meta1_parents{$_} } $meta2->linearized_isa;
437 sub _is_role_only_subclass_of {
438 my ($meta, $ancestor) = @_;
440 return 1 if $meta->name eq $ancestor;
442 my @roles = _all_roles_until( $meta, $ancestor );
444 my %role_packages = map { $_->name => 1 } @roles;
446 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
448 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
450 for my $method ( $meta->get_all_methods() ) {
451 next if $method->name eq 'meta';
452 next if $method->can('associated_attribute');
455 if $role_packages{ $method->original_package_name }
456 || $shared_ancestors{ $method->original_package_name };
461 # FIXME - this really isn't right. Just because an attribute is
462 # defined in a role doesn't mean it isn't _also_ defined in the
464 for my $attr ( $meta->get_all_attributes ) {
465 next if $shared_ancestors{ $attr->associated_class->name };
467 next if any { $_->has_attribute( $attr->name ) } @roles;
478 return _all_roles_until($meta);
481 sub _all_roles_until {
482 my ($meta, $stop_at_class) = @_;
484 return unless $meta->can('calculate_all_roles');
486 my @roles = $meta->calculate_all_roles;
488 for my $class ( $meta->linearized_isa ) {
489 last if $stop_at_class && $stop_at_class eq $class;
491 my $meta = Class::MOP::Class->initialize($class);
492 last unless $meta->can('calculate_all_roles');
494 push @roles, $meta->calculate_all_roles;
500 sub _reconcile_role_differences {
501 my ($self, $super_meta) = @_;
503 my $self_meta = Class::MOP::class_of($self);
507 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
508 $roles{metaclass_roles} = \@roles;
511 for my $thing (@MetaClassTypes) {
512 my $name = $self->$thing();
514 my $thing_meta = Class::MOP::Class->initialize($name);
516 my @roles = map { $_->name } _all_roles($thing_meta)
519 $roles{ $thing . '_roles' } = \@roles;
522 $self->_reinitialize_with($super_meta);
524 Moose::Util::MetaRole::apply_metaclass_roles(
525 for_class => $self->name,
532 sub _process_attribute {
533 my ( $self, $name, @args ) = @_;
535 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
537 if (($name || '') =~ /^\+(.*)/) {
538 return $self->_process_inherited_attribute($1, @args);
541 return $self->_process_new_attribute($name, @args);
545 sub _process_new_attribute {
546 my ( $self, $name, @args ) = @_;
548 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
551 sub _process_inherited_attribute {
552 my ($self, $attr_name, %options) = @_;
553 my $inherited_attr = $self->find_attribute_by_name($attr_name);
554 (defined $inherited_attr)
555 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
556 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
557 return $inherited_attr->clone_and_inherit_options(%options);
561 # kind of a kludge to handle Class::MOP::Attributes
562 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
566 ## -------------------------------------------------
571 my ( $self, @args ) = @_;
572 local $error_level = ($error_level || 0) + 1;
573 $self->raise_error($self->create_error(@args));
577 my ( $self, @args ) = @_;
582 my ( $self, @args ) = @_;
586 local $error_level = ($error_level || 0 ) + 1;
588 if ( @args % 2 == 1 ) {
589 unshift @args, "message";
592 my %args = ( metaclass => $self, last_error => $@, @args );
594 $args{depth} += $error_level;
596 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
598 Class::MOP::load_class($class);
601 Carp::caller_info($args{depth}),
614 Moose::Meta::Class - The Moose metaclass
618 This class is a subclass of L<Class::MOP::Class> that provides
619 additional Moose-specific functionality.
621 To really understand this class, you will need to start with the
622 L<Class::MOP::Class> documentation. This class can be understood as a
623 set of additional features on top of the basic feature provided by
628 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
634 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
636 This overrides the parent's method in order to provide its own
637 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
638 C<method_metaclass> options.
640 These all default to the appropriate Moose class.
642 =item B<< Moose::Meta::Class->create($package_name, %options) >>
644 This overrides the parent's method in order to accept a C<roles>
645 option. This should be an array reference containing one more roles
648 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
650 =item B<< Moose::Meta::Class->create_anon_class >>
652 This overrides the parent's method to accept a C<roles> option, just
655 It also accepts a C<cache> option. If this is true, then the anonymous
656 class will be cached based on its superclasses and roles. If an
657 existing anonymous class in the cache has the same superclasses and
658 roles, it will be reused.
660 my $metaclass = Moose::Meta::Class->create_anon_class(
661 superclasses => ['Foo'],
662 roles => [qw/Some Roles Go Here/],
666 =item B<< $metaclass->make_immutable(%options) >>
668 This overrides the parent's method to add a few options. Specifically,
669 it uses the Moose-specific constructor and destructor classes, and
670 enables inlining the destructor.
672 Also, since Moose always inlines attributes, it sets the
673 C<inline_accessors> option to false.
675 =item B<< $metaclass->new_object(%params) >>
677 This overrides the parent's method in order to add support for
680 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
682 This adds an C<override> method modifier to the package.
684 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
686 This adds an C<augment> method modifier to the package.
688 =item B<< $metaclass->calculate_all_roles >>
690 This will return a unique array of C<Moose::Meta::Role> instances
691 which are attached to this class.
693 =item B<< $metaclass->add_role($role) >>
695 This takes a L<Moose::Meta::Role> object, and adds it to the class's
696 list of roles. This I<does not> actually apply the role to the class.
698 =item B<< $metaclass->does_role($role_name) >>
700 This returns a boolean indicating whether or not the class does the
701 specified role. This tests both the class and its parents.
703 =item B<< $metaclass->excludes_role($role_name) >>
705 A class excludes a role if it has already composed a role which
706 excludes the named role. This tests both the class and its parents.
708 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
710 This overrides the parent's method in order to allow the parameters to
711 be provided as a hash reference.
713 =item B<< $metaclass->constructor_class ($class_name) >>
715 =item B<< $metaclass->destructor_class ($class_name) >>
717 These are the names of classes used when making a class
718 immutable. These default to L<Moose::Meta::Method::Constructor> and
719 L<Moose::Meta::Method::Destructor> respectively. These accessors are
720 read-write, so you can use them to change the class name.
722 =item B<< $metaclass->error_class($class_name) >>
724 The name of the class used to throw errors. This defaults to
725 L<Moose::Error::Default>, which generates an error with a stacktrace
726 just like C<Carp::confess>.
728 =item B<< $metaclass->throw_error($message, %extra) >>
730 Throws the error created by C<create_error> using C<raise_error>
736 All complex software has bugs lurking in it, and this module is no
737 exception. If you find a bug please either email me, or add the bug
742 Stevan Little E<lt>stevan@iinteractive.comE<gt>
744 =head1 COPYRIGHT AND LICENSE
746 Copyright 2006-2009 by Infinity Interactive, Inc.
748 L<http://www.iinteractive.com>
750 This library is free software; you can redistribute it and/or modify
751 it under the same terms as Perl itself.