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;
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);
208 foreach my $super (@supers) {
209 my $meta = Class::MOP::load_class($super);
210 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
211 if $meta && $meta->isa('Moose::Meta::Role')
213 return $self->SUPER::superclasses(@supers);
216 ### ---------------------------------------------
220 $self->SUPER::add_attribute(
221 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
223 : $self->_process_attribute(@_))
227 sub add_override_method_modifier {
228 my ($self, $name, $method, $_super_package) = @_;
230 (!$self->has_method($name))
231 || $self->throw_error("Cannot add an override method if a local method is already present");
233 $self->add_method($name => Moose::Meta::Method::Overridden->new(
236 package => $_super_package, # need this for roles
241 sub add_augment_method_modifier {
242 my ($self, $name, $method) = @_;
243 (!$self->has_method($name))
244 || $self->throw_error("Cannot add an augment method if a local method is already present");
246 $self->add_method($name => Moose::Meta::Method::Augmented->new(
253 ## Private Utility methods ...
255 sub _find_next_method_by_name_which_is_not_overridden {
256 my ($self, $name) = @_;
257 foreach my $method ($self->find_all_methods_by_name($name)) {
258 return $method->{code}
259 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
264 sub _fix_metaclass_incompatibility {
265 my ($self, @superclasses) = @_;
267 foreach my $super (@superclasses) {
268 next if $self->_superclass_meta_is_compatible($super);
270 unless ( $self->is_pristine ) {
272 "Cannot attempt to reinitialize metaclass for "
274 . ", it isn't pristine" );
277 $self->_reconcile_with_superclass_meta($super);
281 sub _superclass_meta_is_compatible {
282 my ($self, $super) = @_;
284 my $super_meta = Class::MOP::Class->initialize($super)
287 next unless $super_meta->isa("Class::MOP::Class");
290 = $super_meta->is_immutable
291 ? $super_meta->get_mutable_metaclass_name
295 if $self->isa($super_meta_name)
297 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
300 # I don't want to have to type this >1 time
302 qw( attribute_metaclass method_metaclass instance_metaclass
303 constructor_class destructor_class error_class );
305 sub _reconcile_with_superclass_meta {
306 my ($self, $super) = @_;
308 my $super_meta = Class::MOP::class_of($super);
311 = $super_meta->is_immutable
312 ? $super_meta->get_mutable_metaclass_name
315 my $self_metaclass = ref $self;
317 # If neither of these is true we have a more serious
318 # incompatibility that we just cannot fix (yet?).
319 if ( $super_meta_name->isa( ref $self )
320 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
321 $self->_reinitialize_with($super_meta);
323 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
324 $self->_reconcile_role_differences($super_meta);
328 sub _reinitialize_with {
329 my ( $self, $new_meta ) = @_;
331 my $new_self = $new_meta->reinitialize(
333 attribute_metaclass => $new_meta->attribute_metaclass,
334 method_metaclass => $new_meta->method_metaclass,
335 instance_metaclass => $new_meta->instance_metaclass,
338 $new_self->$_( $new_meta->$_ )
339 for qw( constructor_class destructor_class error_class );
343 bless $self, ref $new_self;
345 # We need to replace the cached metaclass instance or else when it
346 # goes out of scope Class::MOP::Class destroy's the namespace for
347 # the metaclass's class, causing much havoc.
348 Class::MOP::store_metaclass_by_name( $self->name, $self );
349 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
352 # In the more complex case, we share a common ancestor with our
353 # superclass's metaclass, but each metaclass (ours and the parent's)
354 # has a different set of roles applied. We reconcile this by first
355 # reinitializing into the parent class, and _then_ applying our own
357 sub _all_metaclasses_differ_by_roles_only {
358 my ($self, $super_meta) = @_;
361 [ ref $self, ref $super_meta ],
362 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
365 next if $pair->[0] eq $pair->[1];
367 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
368 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
371 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
373 return unless $common_ancestor;
376 unless _is_role_only_subclass_of(
380 && _is_role_only_subclass_of(
389 # This, and some other functions, could be called as methods, but
390 # they're not for two reasons. One, we just end up ignoring the first
391 # argument, because we can't call these directly on one of the real
392 # arguments, because one of them could be a Class::MOP::Class object
393 # and not a Moose::Meta::Class. Second, only a completely insane
394 # person would attempt to subclass this stuff!
395 sub _find_common_ancestor {
396 my ($meta1, $meta2) = @_;
398 # FIXME? This doesn't account for multiple inheritance (not sure
399 # if it needs to though). For example, is somewhere in $meta1's
400 # history it inherits from both ClassA and ClassB, and $meta2
401 # inherits from ClassB & ClassA, does it matter? And what crazy
402 # fool would do that anyway?
404 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
406 return first { $meta1_parents{$_} } $meta2->linearized_isa;
409 sub _is_role_only_subclass_of {
410 my ($meta, $ancestor) = @_;
412 return 1 if $meta->name eq $ancestor;
414 my @roles = _all_roles_until( $meta, $ancestor );
416 my %role_packages = map { $_->name => 1 } @roles;
418 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
420 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
422 for my $method ( $meta->get_all_methods() ) {
423 next if $method->name eq 'meta';
424 next if $method->can('associated_attribute');
427 if $role_packages{ $method->original_package_name }
428 || $shared_ancestors{ $method->original_package_name };
433 # FIXME - this really isn't right. Just because an attribute is
434 # defined in a role doesn't mean it isn't _also_ defined in the
436 for my $attr ( $meta->get_all_attributes ) {
437 next if $shared_ancestors{ $attr->associated_class->name };
439 next if any { $_->has_attribute( $attr->name ) } @roles;
450 return _all_roles_until($meta);
453 sub _all_roles_until {
454 my ($meta, $stop_at_class) = @_;
456 return unless $meta->can('calculate_all_roles');
458 my @roles = $meta->calculate_all_roles;
460 for my $class ( $meta->linearized_isa ) {
461 last if $stop_at_class && $stop_at_class eq $class;
463 my $meta = Class::MOP::Class->initialize($class);
464 last unless $meta->can('calculate_all_roles');
466 push @roles, $meta->calculate_all_roles;
472 sub _reconcile_role_differences {
473 my ($self, $super_meta) = @_;
475 my $self_meta = Class::MOP::class_of($self);
479 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
480 $roles{metaclass_roles} = \@roles;
483 for my $thing (@MetaClassTypes) {
484 my $name = $self->$thing();
486 my $thing_meta = Class::MOP::Class->initialize($name);
488 my @roles = map { $_->name } _all_roles($thing_meta)
491 $roles{ $thing . '_roles' } = \@roles;
494 $self->_reinitialize_with($super_meta);
496 Moose::Util::MetaRole::apply_metaclass_roles(
497 for_class => $self->name,
504 sub _process_attribute {
505 my ( $self, $name, @args ) = @_;
507 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
509 if (($name || '') =~ /^\+(.*)/) {
510 return $self->_process_inherited_attribute($1, @args);
513 return $self->_process_new_attribute($name, @args);
517 sub _process_new_attribute {
518 my ( $self, $name, @args ) = @_;
520 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
523 sub _process_inherited_attribute {
524 my ($self, $attr_name, %options) = @_;
525 my $inherited_attr = $self->find_attribute_by_name($attr_name);
526 (defined $inherited_attr)
527 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
528 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
529 return $inherited_attr->clone_and_inherit_options(%options);
533 # kind of a kludge to handle Class::MOP::Attributes
534 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
538 ## -------------------------------------------------
540 use Moose::Meta::Method::Constructor;
541 use Moose::Meta::Method::Destructor;
544 sub _default_immutable_transformer_options {
547 my %options = $self->SUPER::_default_immutable_transformer_options;
549 # We need to copy the references as we do not want to alter the
550 # superclass's references.
551 $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
552 $options{memoize} = {
553 %{ $options{memoize} },
554 calculate_all_roles => 'ARRAY',
559 constructor_class => $self->constructor_class,
560 destructor_class => $self->destructor_class,
561 inline_destructor => 1,
563 # Moose always does this when an attribute is created
564 inline_accessors => 0,
573 my ( $self, @args ) = @_;
574 local $error_level = ($error_level || 0) + 1;
575 $self->raise_error($self->create_error(@args));
579 my ( $self, @args ) = @_;
584 my ( $self, @args ) = @_;
588 local $error_level = ($error_level || 0 ) + 1;
590 if ( @args % 2 == 1 ) {
591 unshift @args, "message";
594 my %args = ( metaclass => $self, last_error => $@, @args );
596 $args{depth} += $error_level;
598 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
600 Class::MOP::load_class($class);
603 Carp::caller_info($args{depth}),
616 Moose::Meta::Class - The Moose metaclass
620 This class is a subclass of L<Class::MOP::Class> that provides
621 additional Moose-specific functionality.
623 To really understand this class, you will need to start with the
624 L<Class::MOP::Class> documentation. This class can be understood as a
625 set of additional features on top of the basic feature provided by
630 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
636 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
638 This overrides the parent's method in order to provide its own
639 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
640 C<method_metaclass> options.
642 These all default to the appropriate Moose class.
644 =item B<< Moose::Meta::Class->create($package_name, %options) >>
646 This overrides the parent's method in order to accept a C<roles>
647 option. This should be an array reference containing one more roles
650 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
652 =item B<< Moose::Meta::Class->create_anon_class >>
654 This overrides the parent's method to accept a C<roles> option, just
657 It also accepts a C<cache> option. If this is true, then the anonymous
658 class will be cached based on its superclasses and roles. If an
659 existing anonymous class in the cache has the same superclasses and
660 roles, it will be reused.
662 my $metaclass = Moose::Meta::Class->create_anon_class(
663 superclasses => ['Foo'],
664 roles => [qw/Some Roles Go Here/],
668 =item B<< $metaclass->make_immutable(%options) >>
670 This overrides the parent's method to add a few options. Specifically,
671 it uses the Moose-specific constructor and destructor classes, and
672 enables inlining the destructor.
674 Also, since Moose always inlines attributes, it sets the
675 C<inline_accessors> option to false.
677 =item B<< $metaclass->new_object(%params) >>
679 This overrides the parent's method in order to add support for
682 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
684 This adds an C<override> method modifier to the package.
686 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
688 This adds an C<augment> method modifier to the package.
690 =item B<< $metaclass->calculate_all_roles >>
692 This will return a unique array of C<Moose::Meta::Role> instances
693 which are attached to this class.
695 =item B<< $metaclass->add_role($role) >>
697 This takes a L<Moose::Meta::Role> object, and adds it to the class's
698 list of roles. This I<does not> actually apply the role to the class.
700 =item B<< $metaclass->does_role($role_name) >>
702 This returns a boolean indicating whether or not the class does the
703 specified role. This tests both the class and its parents.
705 =item B<< $metaclass->excludes_role($role_name) >>
707 A class excludes a role if it has already composed a role which
708 excludes the named role. This tests both the class and its parents.
710 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
712 This overrides the parent's method in order to allow the parameters to
713 be provided as a hash reference.
715 =item B<< $metaclass->constructor_class ($class_name) >>
717 =item B<< $metaclass->destructor_class ($class_name) >>
719 These are the names of classes used when making a class
720 immutable. These default to L<Moose::Meta::Method::Constructor> and
721 L<Moose::Meta::Method::Destructor> respectively. These accessors are
722 read-write, so you can use them to change the class name.
724 =item B<< $metaclass->error_class($class_name) >>
726 The name of the class used to throw errors. This defaults to
727 L<Moose::Error::Default>, which generates an error with a stacktrace
728 just like C<Carp::confess>.
730 =item B<< $metaclass->throw_error($message, %extra) >>
732 Throws the error created by C<create_error> using C<raise_error>
738 All complex software has bugs lurking in it, and this module is no
739 exception. If you find a bug please either email me, or add the bug
744 Stevan Little E<lt>stevan@iinteractive.comE<gt>
746 =head1 COPYRIGHT AND LICENSE
748 Copyright 2006-2009 by Infinity Interactive, Inc.
750 L<http://www.iinteractive.com>
752 This library is free software; you can redistribute it and/or modify
753 it under the same terms as Perl itself.