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.73_01';
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) = @_;
126 || $self->throw_error("You must supply a role name to look for");
128 foreach my $class ($self->class_precedence_list) {
129 my $meta = Class::MOP::class_of($class);
130 # when a Moose metaclass is itself extended with a role,
131 # this check needs to be done since some items in the
132 # class_precedence_list might in fact be Class::MOP
134 next unless $meta && $meta->can('roles');
135 foreach my $role (@{$meta->roles}) {
136 return 1 if $role->does_role($role_name);
143 my ($self, $role_name) = @_;
146 || $self->throw_error("You must supply a role name to look for");
148 foreach my $class ($self->class_precedence_list) {
149 my $meta = Class::MOP::class_of($class);
150 # when a Moose metaclass is itself extended with a role,
151 # this check needs to be done since some items in the
152 # class_precedence_list might in fact be Class::MOP
154 next unless $meta && $meta->can('roles');
155 foreach my $role (@{$meta->roles}) {
156 return 1 if $role->excludes_role($role_name);
164 my $params = @_ == 1 ? $_[0] : {@_};
165 my $self = $class->SUPER::new_object($params);
167 foreach my $attr ( $class->get_all_attributes() ) {
169 next unless $attr->can('has_trigger') && $attr->has_trigger;
171 my $init_arg = $attr->init_arg;
173 next unless defined $init_arg;
175 next unless exists $params->{$init_arg};
181 ? $attr->get_read_method_ref->($self)
182 : $params->{$init_arg}
190 sub _construct_instance {
192 my $params = @_ == 1 ? $_[0] : {@_};
193 my $meta_instance = $class->get_meta_instance;
195 # the code below is almost certainly incorrect
196 # but this is foreign inheritance, so we might
197 # have to kludge it in the end.
198 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
199 foreach my $attr ($class->get_all_attributes()) {
200 $attr->initialize_instance_slot($meta_instance, $instance, $params);
205 ### ---------------------------------------------
209 $self->SUPER::add_attribute(
210 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
212 : $self->_process_attribute(@_))
216 sub add_override_method_modifier {
217 my ($self, $name, $method, $_super_package) = @_;
219 (!$self->has_method($name))
220 || $self->throw_error("Cannot add an override method if a local method is already present");
222 $self->add_method($name => Moose::Meta::Method::Overridden->new(
225 package => $_super_package, # need this for roles
230 sub add_augment_method_modifier {
231 my ($self, $name, $method) = @_;
232 (!$self->has_method($name))
233 || $self->throw_error("Cannot add an augment method if a local method is already present");
235 $self->add_method($name => Moose::Meta::Method::Augmented->new(
242 ## Private Utility methods ...
244 sub _find_next_method_by_name_which_is_not_overridden {
245 my ($self, $name) = @_;
246 foreach my $method ($self->find_all_methods_by_name($name)) {
247 return $method->{code}
248 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
253 sub _fix_metaclass_incompatibility {
254 my ($self, @superclasses) = @_;
256 foreach my $super (@superclasses) {
257 next if $self->_superclass_meta_is_compatible($super);
259 unless ( $self->is_pristine ) {
261 "Cannot attempt to reinitialize metaclass for "
263 . ", it isn't pristine" );
266 $self->_reconcile_with_superclass_meta($super);
270 sub _superclass_meta_is_compatible {
271 my ($self, $super) = @_;
273 my $super_meta = Class::MOP::Class->initialize($super)
276 next unless $super_meta->isa("Class::MOP::Class");
279 = $super_meta->is_immutable
280 ? $super_meta->get_mutable_metaclass_name
284 if $self->isa($super_meta_name)
286 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
289 # I don't want to have to type this >1 time
291 qw( attribute_metaclass method_metaclass instance_metaclass
292 constructor_class destructor_class error_class );
294 sub _reconcile_with_superclass_meta {
295 my ($self, $super) = @_;
297 my $super_meta = Class::MOP::class_of($super);
300 = $super_meta->is_immutable
301 ? $super_meta->get_mutable_metaclass_name
304 my $self_metaclass = ref $self;
306 # If neither of these is true we have a more serious
307 # incompatibility that we just cannot fix (yet?).
308 if ( $super_meta_name->isa( ref $self )
309 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
310 $self->_reinitialize_with($super_meta);
312 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
313 $self->_reconcile_role_differences($super_meta);
317 sub _reinitialize_with {
318 my ( $self, $new_meta ) = @_;
320 my $new_self = $new_meta->reinitialize(
322 attribute_metaclass => $new_meta->attribute_metaclass,
323 method_metaclass => $new_meta->method_metaclass,
324 instance_metaclass => $new_meta->instance_metaclass,
327 $new_self->$_( $new_meta->$_ )
328 for qw( constructor_class destructor_class error_class );
332 bless $self, ref $new_self;
334 # We need to replace the cached metaclass instance or else when it
335 # goes out of scope Class::MOP::Class destroy's the namespace for
336 # the metaclass's class, causing much havoc.
337 Class::MOP::store_metaclass_by_name( $self->name, $self );
338 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
341 # In the more complex case, we share a common ancestor with our
342 # superclass's metaclass, but each metaclass (ours and the parent's)
343 # has a different set of roles applied. We reconcile this by first
344 # reinitializing into the parent class, and _then_ applying our own
346 sub _all_metaclasses_differ_by_roles_only {
347 my ($self, $super_meta) = @_;
350 [ ref $self, ref $super_meta ],
351 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
354 next if $pair->[0] eq $pair->[1];
356 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
357 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
360 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
362 return unless $common_ancestor;
365 unless _is_role_only_subclass_of(
369 && _is_role_only_subclass_of(
378 # This, and some other functions, could be called as methods, but
379 # they're not for two reasons. One, we just end up ignoring the first
380 # argument, because we can't call these directly on one of the real
381 # arguments, because one of them could be a Class::MOP::Class object
382 # and not a Moose::Meta::Class. Second, only a completely insane
383 # person would attempt to subclass this stuff!
384 sub _find_common_ancestor {
385 my ($meta1, $meta2) = @_;
387 # FIXME? This doesn't account for multiple inheritance (not sure
388 # if it needs to though). For example, is somewhere in $meta1's
389 # history it inherits from both ClassA and ClassB, and $meta2
390 # inherits from ClassB & ClassA, does it matter? And what crazy
391 # fool would do that anyway?
393 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
395 return first { $meta1_parents{$_} } $meta2->linearized_isa;
398 sub _is_role_only_subclass_of {
399 my ($meta, $ancestor) = @_;
401 return 1 if $meta->name eq $ancestor;
403 my @roles = _all_roles_until( $meta, $ancestor );
405 my %role_packages = map { $_->name => 1 } @roles;
407 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
409 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
411 for my $method ( $meta->get_all_methods() ) {
412 next if $method->name eq 'meta';
413 next if $method->can('associated_attribute');
416 if $role_packages{ $method->original_package_name }
417 || $shared_ancestors{ $method->original_package_name };
422 # FIXME - this really isn't right. Just because an attribute is
423 # defined in a role doesn't mean it isn't _also_ defined in the
425 for my $attr ( $meta->get_all_attributes ) {
426 next if $shared_ancestors{ $attr->associated_class->name };
428 next if any { $_->has_attribute( $attr->name ) } @roles;
439 return _all_roles_until($meta);
442 sub _all_roles_until {
443 my ($meta, $stop_at_class) = @_;
445 return unless $meta->can('calculate_all_roles');
447 my @roles = $meta->calculate_all_roles;
449 for my $class ( $meta->linearized_isa ) {
450 last if $stop_at_class && $stop_at_class eq $class;
452 my $meta = Class::MOP::Class->initialize($class);
453 last unless $meta->can('calculate_all_roles');
455 push @roles, $meta->calculate_all_roles;
461 sub _reconcile_role_differences {
462 my ($self, $super_meta) = @_;
464 my $self_meta = Class::MOP::class_of($self);
468 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
469 $roles{metaclass_roles} = \@roles;
472 for my $thing (@MetaClassTypes) {
473 my $name = $self->$thing();
475 my $thing_meta = Class::MOP::Class->initialize($name);
477 my @roles = map { $_->name } _all_roles($thing_meta)
480 $roles{ $thing . '_roles' } = \@roles;
483 $self->_reinitialize_with($super_meta);
485 Moose::Util::MetaRole::apply_metaclass_roles(
486 for_class => $self->name,
494 # this was crap anyway, see
495 # Moose::Util::apply_all_roles
497 sub _apply_all_roles {
498 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
501 sub _process_attribute {
502 my ( $self, $name, @args ) = @_;
504 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
506 if (($name || '') =~ /^\+(.*)/) {
507 return $self->_process_inherited_attribute($1, @args);
510 return $self->_process_new_attribute($name, @args);
514 sub _process_new_attribute {
515 my ( $self, $name, @args ) = @_;
517 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
520 sub _process_inherited_attribute {
521 my ($self, $attr_name, %options) = @_;
522 my $inherited_attr = $self->find_attribute_by_name($attr_name);
523 (defined $inherited_attr)
524 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
525 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
526 return $inherited_attr->clone_and_inherit_options(%options);
530 # kind of a kludge to handle Class::MOP::Attributes
531 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
535 ## -------------------------------------------------
537 use Moose::Meta::Method::Constructor;
538 use Moose::Meta::Method::Destructor;
541 sub _default_immutable_transformer_options {
544 my %options = $self->SUPER::_default_immutable_transformer_options;
546 # We need to copy the references as we do not want to alter the
547 # superclass's references.
548 $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
549 $options{memoize} = {
550 %{ $options{memoize} },
551 calculate_all_roles => 'ARRAY',
556 constructor_class => $self->constructor_class,
557 destructor_class => $self->destructor_class,
558 inline_destructor => 1,
560 # Moose always does this when an attribute is created
561 inline_accessors => 0,
570 my ( $self, @args ) = @_;
571 local $error_level = ($error_level || 0) + 1;
572 $self->raise_error($self->create_error(@args));
576 my ( $self, @args ) = @_;
581 my ( $self, @args ) = @_;
585 local $error_level = ($error_level || 0 ) + 1;
587 if ( @args % 2 == 1 ) {
588 unshift @args, "message";
591 my %args = ( metaclass => $self, last_error => $@, @args );
593 $args{depth} += $error_level;
595 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
597 Class::MOP::load_class($class);
600 Carp::caller_info($args{depth}),
613 Moose::Meta::Class - The Moose metaclass
617 This class is a subclass of L<Class::MOP::Class> that provides
618 additional Moose-specific functionality.
620 To really understand this class, you will need to start with the
621 L<Class::MOP::Class> documentation. This class can be understood as a
622 set of additional features on top of the basic feature provided by
627 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
633 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
635 This overrides the parent's method in order to provide its own
636 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
637 C<method_metaclass> options.
639 These all default to the appropriate Moose class.
641 =item B<< Moose::Meta::Class->create($package_name, %options) >>
643 This overrides the parent's method in order to accept a C<roles>
644 option. This should be an array reference containing one more roles
647 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
649 =item B<< Moose::Meta::Class->create_anon_class >>
651 This overrides the parent's method to accept a C<roles> option, just
654 It also accepts a C<cache> option. If this is true, then the anonymous
655 class will be cached based on its superclasses and roles. If an
656 existing anonymous class in the cache has the same superclasses and
657 roles, it will be reused.
659 my $metaclass = Moose::Meta::Class->create_anon_class(
660 superclasses => ['Foo'],
661 roles => [qw/Some Roles Go Here/],
665 =item B<< $metaclass->make_immutable(%options) >>
667 This overrides the parent's method to add a few options. Specifically,
668 it uses the Moose-specific constructor and destructor classes, and
669 enables inlining the destructor.
671 Also, since Moose always inlines attributes, it sets the
672 C<inline_accessors> option to false.
674 =item B<< $metaclass->new_object(%params) >>
676 This overrides the parent's method in order to add support for
679 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
681 This adds an C<override> method modifier to the package.
683 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
685 This adds an C<augment> method modifier to the package.
687 =item B<< $metaclass->calculate_all_roles >>
689 This will return a unique array of C<Moose::Meta::Role> instances
690 which are attached to this class.
692 =item B<< $metaclass->add_role($role) >>
694 This takes a L<Moose::Meta::Role> object, and adds it to the class's
695 list of roles. This I<does not> actually apply the role to the class.
697 =item B<< $metaclass->does_role($role_name) >>
699 This returns a boolean indicating whether or not the class does the
700 specified role. This tests both the class and its parents.
702 =item B<< $metaclass->excludes_role($role_name) >>
704 A class excludes a role if it has already composed a role which
705 excludes the named role. This tests both the class and its parents.
707 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
709 This overrides the parent's method in order to allow the parameters to
710 be provided as a hash reference.
712 =item B<< $metaclass->constructor_class ($class_name) >>
714 =item B<< $metaclass->destructor_class ($class_name) >>
716 These are the names of classes used when making a class
717 immutable. These default to L<Moose::Meta::Method::Constructor> and
718 L<Moose::Meta::Method::Destructor> respectively. These accessors are
719 read-write, so you can use them to change the class name.
721 =item B<< $metaclass->error_class($class_name) >>
723 The name of the class used to throw errors. This defaults to
724 L<Moose::Error::Default>, which generates an error with a stacktrace
725 just like C<Carp::confess>.
727 =item B<< $metaclass->throw_error($message, %extra) >>
729 Throws the error created by C<create_error> using C<raise_error>
735 All complex software has bugs lurking in it, and this module is no
736 exception. If you find a bug please either email me, or add the bug
741 Stevan Little E<lt>stevan@iinteractive.comE<gt>
743 =head1 COPYRIGHT AND LICENSE
745 Copyright 2006-2009 by Infinity Interactive, Inc.
747 L<http://www.iinteractive.com>
749 This library is free software; you can redistribute it and/or modify
750 it under the same terms as Perl itself.