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.72';
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;
22 use base 'Class::MOP::Class';
24 __PACKAGE__->meta->add_attribute('roles' => (
29 __PACKAGE__->meta->add_attribute('constructor_class' => (
30 accessor => 'constructor_class',
31 default => 'Moose::Meta::Method::Constructor',
34 __PACKAGE__->meta->add_attribute('destructor_class' => (
35 accessor => 'destructor_class',
36 default => 'Moose::Meta::Method::Destructor',
39 __PACKAGE__->meta->add_attribute('error_class' => (
40 accessor => 'error_class',
41 default => 'Moose::Error::Default',
48 return Class::MOP::get_metaclass_by_name($pkg)
49 || $class->SUPER::initialize($pkg,
50 'attribute_metaclass' => 'Moose::Meta::Attribute',
51 'method_metaclass' => 'Moose::Meta::Method',
52 'instance_metaclass' => 'Moose::Meta::Instance',
58 my ($self, $package_name, %options) = @_;
60 (ref $options{roles} eq 'ARRAY')
61 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
62 if exists $options{roles};
63 my $roles = delete $options{roles};
65 my $class = $self->SUPER::create($package_name, %options);
68 Moose::Util::apply_all_roles( $class, @$roles );
74 sub check_metaclass_compatibility {
77 if ( my @supers = $self->superclasses ) {
78 $self->_fix_metaclass_incompatibility(@supers);
81 $self->SUPER::check_metaclass_compatibility(@_);
86 sub create_anon_class {
87 my ($self, %options) = @_;
89 my $cache_ok = delete $options{cache};
91 # something like Super::Class|Super::Class::2=Role|Role::1
92 my $cache_key = join '=' => (
93 join('|', @{$options{superclasses} || []}),
94 join('|', sort @{$options{roles} || []}),
97 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
98 return $ANON_CLASSES{$cache_key};
101 my $new_class = $self->SUPER::create_anon_class(%options);
103 $ANON_CLASSES{$cache_key} = $new_class
110 my ($self, $role) = @_;
111 (blessed($role) && $role->isa('Moose::Meta::Role'))
112 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
113 push @{$self->roles} => $role;
116 sub calculate_all_roles {
119 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
123 my ($self, $role_name) = @_;
125 || $self->throw_error("You must supply a role name to look for");
126 foreach my $class ($self->class_precedence_list) {
127 next unless $class->can('meta') && $class->meta->can('roles');
128 foreach my $role (@{$class->meta->roles}) {
129 return 1 if $role->does_role($role_name);
136 my ($self, $role_name) = @_;
138 || $self->throw_error("You must supply a role name to look for");
139 foreach my $class ($self->class_precedence_list) {
140 next unless $class->can('meta');
142 # in the pretty rare instance when a Moose metaclass
143 # is itself extended with a role, this check needs to
144 # be done since some items in the class_precedence_list
145 # might in fact be Class::MOP based still.
146 next unless $class->meta->can('roles');
147 foreach my $role (@{$class->meta->roles}) {
148 return 1 if $role->excludes_role($role_name);
156 my $params = @_ == 1 ? $_[0] : {@_};
157 my $self = $class->SUPER::new_object($params);
159 foreach my $attr ( $class->compute_all_applicable_attributes() ) {
161 next unless $attr->can('has_trigger') && $attr->has_trigger;
163 my $init_arg = $attr->init_arg;
165 next unless defined $init_arg;
167 next unless exists $params->{$init_arg};
173 ? $attr->get_read_method_ref->($self)
174 : $params->{$init_arg}
183 sub construct_instance {
185 my $params = @_ == 1 ? $_[0] : {@_};
186 my $meta_instance = $class->get_meta_instance;
188 # the code below is almost certainly incorrect
189 # but this is foreign inheritance, so we might
190 # have to kludge it in the end.
191 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
192 foreach my $attr ($class->compute_all_applicable_attributes()) {
193 $attr->initialize_instance_slot($meta_instance, $instance, $params);
198 ### ---------------------------------------------
202 $self->SUPER::add_attribute(
203 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
205 : $self->_process_attribute(@_))
209 sub add_override_method_modifier {
210 my ($self, $name, $method, $_super_package) = @_;
212 (!$self->has_method($name))
213 || $self->throw_error("Cannot add an override method if a local method is already present");
215 $self->add_method($name => Moose::Meta::Method::Overridden->new(
218 package => $_super_package, # need this for roles
223 sub add_augment_method_modifier {
224 my ($self, $name, $method) = @_;
225 (!$self->has_method($name))
226 || $self->throw_error("Cannot add an augment method if a local method is already present");
228 $self->add_method($name => Moose::Meta::Method::Augmented->new(
235 ## Private Utility methods ...
237 sub _find_next_method_by_name_which_is_not_overridden {
238 my ($self, $name) = @_;
239 foreach my $method ($self->find_all_methods_by_name($name)) {
240 return $method->{code}
241 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
246 sub _fix_metaclass_incompatibility {
247 my ($self, @superclasses) = @_;
249 foreach my $super (@superclasses) {
250 next if $self->_superclass_meta_is_compatible($super);
252 unless ( $self->is_pristine ) {
254 "Cannot attempt to reinitialize metaclass for "
256 . ", it isn't pristine" );
259 $self->_reconcile_with_superclass_meta($super);
263 sub _superclass_meta_is_compatible {
264 my ($self, $super) = @_;
266 my $super_meta = Class::MOP::Class->initialize($super)
269 next unless $super_meta->isa("Class::MOP::Class");
272 = $super_meta->is_immutable
273 ? $super_meta->get_mutable_metaclass_name
277 if $self->isa($super_meta_name)
279 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
282 # I don't want to have to type this >1 time
284 qw( attribute_metaclass method_metaclass instance_metaclass
285 constructor_class destructor_class error_class );
287 sub _reconcile_with_superclass_meta {
288 my ($self, $super) = @_;
290 my $super_meta = $super->meta;
293 = $super_meta->is_immutable
294 ? $super_meta->get_mutable_metaclass_name
297 my $self_metaclass = ref $self;
299 # If neither of these is true we have a more serious
300 # incompatibility that we just cannot fix (yet?).
301 if ( $super_meta_name->isa( ref $self )
302 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
303 $self->_reinitialize_with($super_meta);
305 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
306 $self->_reconcile_role_differences($super_meta);
310 sub _reinitialize_with {
311 my ( $self, $new_meta ) = @_;
313 my $new_self = $new_meta->reinitialize(
315 attribute_metaclass => $new_meta->attribute_metaclass,
316 method_metaclass => $new_meta->method_metaclass,
317 instance_metaclass => $new_meta->instance_metaclass,
320 $new_self->$_( $new_meta->$_ )
321 for qw( constructor_class destructor_class error_class );
325 bless $self, ref $new_self;
327 # We need to replace the cached metaclass instance or else when it
328 # goes out of scope Class::MOP::Class destroy's the namespace for
329 # the metaclass's class, causing much havoc.
330 Class::MOP::store_metaclass_by_name( $self->name, $self );
331 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
334 # In the more complex case, we share a common ancestor with our
335 # superclass's metaclass, but each metaclass (ours and the parent's)
336 # has a different set of roles applied. We reconcile this by first
337 # reinitializing into the parent class, and _then_ applying our own
339 sub _all_metaclasses_differ_by_roles_only {
340 my ($self, $super_meta) = @_;
343 [ ref $self, ref $super_meta ],
344 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
347 next if $pair->[0] eq $pair->[1];
349 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
350 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
353 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
355 return unless $common_ancestor;
358 unless _is_role_only_subclass_of(
362 && _is_role_only_subclass_of(
371 # This, and some other functions, could be called as methods, but
372 # they're not for two reasons. One, we just end up ignoring the first
373 # argument, because we can't call these directly on one of the real
374 # arguments, because one of them could be a Class::MOP::Class object
375 # and not a Moose::Meta::Class. Second, only a completely insane
376 # person would attempt to subclass this stuff!
377 sub _find_common_ancestor {
378 my ($meta1, $meta2) = @_;
380 # FIXME? This doesn't account for multiple inheritance (not sure
381 # if it needs to though). For example, is somewhere in $meta1's
382 # history it inherits from both ClassA and ClassB, and $meta
383 # inherits from ClassB & ClassA, does it matter? And what crazy
384 # fool would do that anyway?
386 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
388 return first { $meta1_parents{$_} } $meta2->linearized_isa;
391 sub _is_role_only_subclass_of {
392 my ($meta, $ancestor) = @_;
394 return 1 if $meta->name eq $ancestor;
396 my @roles = _all_roles_until( $meta, $ancestor );
398 my %role_packages = map { $_->name => 1 } @roles;
400 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
402 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
404 for my $method ( $meta->get_all_methods() ) {
405 next if $method->name eq 'meta';
406 next if $method->can('associated_attribute');
409 if $role_packages{ $method->original_package_name }
410 || $shared_ancestors{ $method->original_package_name };
415 # FIXME - this really isn't right. Just because an attribute is
416 # defined in a role doesn't mean it isn't _also_ defined in the
418 for my $attr ( $meta->get_all_attributes ) {
419 next if $shared_ancestors{ $attr->associated_class->name };
421 next if any { $_->has_attribute( $attr->name ) } @roles;
432 return _all_roles_until($meta);
435 sub _all_roles_until {
436 my ($meta, $stop_at_class) = @_;
438 return unless $meta->can('calculate_all_roles');
440 my @roles = $meta->calculate_all_roles;
442 for my $class ( $meta->linearized_isa ) {
443 last if $stop_at_class && $stop_at_class eq $class;
445 my $meta = Class::MOP::Class->initialize($class);
446 last unless $meta->can('calculate_all_roles');
448 push @roles, $meta->calculate_all_roles;
454 sub _reconcile_role_differences {
455 my ($self, $super_meta) = @_;
457 my $self_meta = $self->meta;
461 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
462 $roles{metaclass_roles} = \@roles;
465 for my $thing (@MetaClassTypes) {
466 my $name = $self->$thing();
468 my $thing_meta = Class::MOP::Class->initialize($name);
470 my @roles = map { $_->name } _all_roles($thing_meta)
473 $roles{ $thing . '_roles' } = \@roles;
476 $self->_reinitialize_with($super_meta);
478 Moose::Util::MetaRole::apply_metaclass_roles(
479 for_class => $self->name,
487 # this was crap anyway, see
488 # Moose::Util::apply_all_roles
490 sub _apply_all_roles {
491 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
494 sub _process_attribute {
495 my ( $self, $name, @args ) = @_;
497 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
499 if (($name || '') =~ /^\+(.*)/) {
500 return $self->_process_inherited_attribute($1, @args);
503 return $self->_process_new_attribute($name, @args);
507 sub _process_new_attribute {
508 my ( $self, $name, @args ) = @_;
510 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
513 sub _process_inherited_attribute {
514 my ($self, $attr_name, %options) = @_;
515 my $inherited_attr = $self->find_attribute_by_name($attr_name);
516 (defined $inherited_attr)
517 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
518 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
519 return $inherited_attr->clone_and_inherit_options(%options);
523 # kind of a kludge to handle Class::MOP::Attributes
524 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
528 ## -------------------------------------------------
530 use Moose::Meta::Method::Constructor;
531 use Moose::Meta::Method::Destructor;
534 sub _default_immutable_transformer_options {
537 my %options = $self->SUPER::_default_immutable_transformer_options;
539 # We need to copy the references as we do not want to alter the
540 # superclass's references.
541 $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
542 $options{memoize} = {
543 %{ $options{memoize} },
544 calculate_all_roles => 'ARRAY',
549 constructor_class => $self->constructor_class,
550 destructor_class => $self->destructor_class,
551 inline_destructor => 1,
553 # Moose always does this when an attribute is created
554 inline_accessors => 0,
563 my ( $self, @args ) = @_;
564 local $error_level = ($error_level || 0) + 1;
565 $self->raise_error($self->create_error(@args));
569 my ( $self, @args ) = @_;
574 my ( $self, @args ) = @_;
578 local $error_level = ($error_level || 0 ) + 1;
580 if ( @args % 2 == 1 ) {
581 unshift @args, "message";
584 my %args = ( metaclass => $self, last_error => $@, @args );
586 $args{depth} += $error_level;
588 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
590 Class::MOP::load_class($class);
593 Carp::caller_info($args{depth}),
606 Moose::Meta::Class - The Moose metaclass
610 This is a subclass of L<Class::MOP::Class> with Moose specific
613 For the most part, the only time you will ever encounter an
614 instance of this class is if you are doing some serious deep
615 introspection. To really understand this class, you need to refer
616 to the L<Class::MOP::Class> documentation.
626 Overrides original to accept a list of roles to apply to
629 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
631 =item B<create_anon_class>
633 Overrides original to support roles and caching.
635 my $metaclass = Moose::Meta::Class->create_anon_class(
636 superclasses => ['Foo'],
637 roles => [qw/Some Roles Go Here/],
641 =item B<make_immutable>
643 Override original to add default options for inlining destructor
644 and altering the Constructor metaclass.
646 =item B<create_immutable_transformer>
648 Override original to lock C<add_role> and memoize C<calculate_all_roles>
652 We override this method to support the C<trigger> attribute option.
654 =item B<construct_instance>
656 This provides some Moose specific extensions to this method, you
657 almost never call this method directly unless you really know what
660 This method makes sure to handle the moose weak-ref, type-constraint
661 and type coercion features.
663 =item B<get_method_map>
665 This accommodates Moose::Meta::Role::Method instances, which are
666 aliased, instead of added, but still need to be counted as valid
669 =item B<add_override_method_modifier ($name, $method)>
671 This will create an C<override> method modifier for you, and install
674 =item B<add_augment_method_modifier ($name, $method)>
676 This will create an C<augment> method modifier for you, and install
679 =item B<calculate_all_roles>
683 This will return an array of C<Moose::Meta::Role> instances which are
684 attached to this class.
686 =item B<add_role ($role)>
688 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
689 to the list of associated roles.
691 =item B<does_role ($role_name)>
693 This will test if this class C<does> a given C<$role_name>. It will
694 not only check it's local roles, but ask them as well in order to
695 cascade down the role hierarchy.
697 =item B<excludes_role ($role_name)>
699 This will test if this class C<excludes> a given C<$role_name>. It will
700 not only check it's local roles, but ask them as well in order to
701 cascade down the role hierarchy.
703 =item B<add_attribute ($attr_name, %params|$params)>
705 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
706 support for taking the C<$params> as a HASH ref.
708 =item B<constructor_class ($class_name)>
710 =item B<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<error_class ($class_name)>
719 The name of the class used to throw errors. This default to
720 L<Moose::Error::Default>, which generates an error with a stacktrace
721 just like C<Carp::confess>.
723 =item B<check_metaclass_compatibility>
725 Moose overrides this method from C<Class::MOP::Class> and attempts to
726 fix some incompatibilities before doing the check.
728 =item B<throw_error $message, %extra>
730 Throws the error created by C<create_error> using C<raise_error>
732 =item B<create_error $message, %extra>
734 Creates an error message or object.
736 The default behavior is C<create_error_confess>.
738 If C<error_class> is set uses C<create_error_object>. Otherwise uses
739 C<error_builder> (a code reference or variant name), and calls the appropriate
740 C<create_error_$builder> method.
742 =item B<error_builder $builder_name>
744 Get or set the error builder. Defaults to C<confess>.
746 =item B<error_class $class_name>
748 Get or set the error class. This defaults to L<Moose::Error::Default>.
750 =item B<create_error_confess %args>
752 Creates an error using L<Carp/longmess>
754 =item B<create_error_croak %args>
756 Creates an error using L<Carp/shortmess>
758 =item B<create_error_object %args>
760 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
761 to support custom error objects for your meta class.
763 =item B<raise_error $error>
765 Dies with an error object or string.
771 All complex software has bugs lurking in it, and this module is no
772 exception. If you find a bug please either email me, or add the bug
777 Stevan Little E<lt>stevan@iinteractive.comE<gt>
779 =head1 COPYRIGHT AND LICENSE
781 Copyright 2006-2009 by Infinity Interactive, Inc.
783 L<http://www.iinteractive.com>
785 This library is free software; you can redistribute it and/or modify
786 it under the same terms as Perl itself.