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 $meta2
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;
533 # This could be done by using SUPER and altering ->options
534 # I am keeping it this way to make it more explicit.
535 sub create_immutable_transformer {
537 my $class = Class::MOP::Immutable->new($self, {
538 read_only => [qw/superclasses/],
545 remove_package_symbol
549 class_precedence_list => 'ARRAY',
550 linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
551 get_all_methods => 'ARRAY',
552 #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
553 compute_all_applicable_attributes => 'ARRAY',
554 get_meta_instance => 'SCALAR',
555 get_method_map => 'SCALAR',
556 calculate_all_roles => 'ARRAY',
559 # this is ugly, but so are typeglobs,
560 # so whattayahgonnadoboutit
563 add_package_symbol => sub {
564 my $original = shift;
565 $self->throw_error("Cannot add package symbols to an immutable metaclass")
566 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
567 goto $original->body;
576 $self->SUPER::make_immutable
578 constructor_class => $self->constructor_class,
579 destructor_class => $self->destructor_class,
580 inline_destructor => 1,
582 # no need to do this,
583 # Moose always does it
584 inline_accessors => 0,
592 my ( $self, @args ) = @_;
593 local $error_level = ($error_level || 0) + 1;
594 $self->raise_error($self->create_error(@args));
598 my ( $self, @args ) = @_;
603 my ( $self, @args ) = @_;
607 local $error_level = ($error_level || 0 ) + 1;
609 if ( @args % 2 == 1 ) {
610 unshift @args, "message";
613 my %args = ( metaclass => $self, last_error => $@, @args );
615 $args{depth} += $error_level;
617 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
619 Class::MOP::load_class($class);
622 Carp::caller_info($args{depth}),
635 Moose::Meta::Class - The Moose metaclass
639 This class is a subclass of L<Class::MOP::Class> that provides
640 additional Moose-specific functionality.
642 To really understand this class, you will probably need to start with
643 the L<Class::MOP::Class> documentation. This class can be understood
644 as a set of additional features on top of the basic feature provided
645 by that parent class.
651 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
653 This overrides the parent's method in order to provide its own
654 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
655 C<method_metaclass> options.
657 These all default to the appropriate Moose class.
659 =item B<< Moose::Meta::Class->create($package_name, %options) >>
661 This overrides the parent's method in order to accept a C<roles>
662 option. This should be an array reference containing one more roles
665 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
667 =item B<< Moose::Meta::Class->create_anon_class >>
669 This overrides the parent's method to accept a C<roles> option, just
672 It also accepts a C<cache> option. If this is true, then the anonymous
673 class will be cached based on its superclasses and roles. If an
674 existing anonymous class in the cache has the same superclasses and
675 roles, it will be reused.
677 my $metaclass = Moose::Meta::Class->create_anon_class(
678 superclasses => ['Foo'],
679 roles => [qw/Some Roles Go Here/],
683 =item B<< $metaclass->make_immutable(%options) >>
685 This overrides the parent's method to add a few options. Specifically,
686 it uses the Moose-specific constructor and destructor classes, and
687 enables inlining the destructor.
689 Also, since Moose always inlines attributes, it sets the
690 C<inline_accessors> option to false.
692 =item B<< $metaclass->new_object(%params) >>
694 This overrides the parent's method in order to add support for
697 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
699 This adds an C<override> method modifier to the package.
701 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
703 This adds an C<augment> method modifier to the package.
705 =item B<< $metaclass->calculate_all_roles >>
707 This will return a unique array of C<Moose::Meta::Role> instances
708 which are attached to this class.
710 =item B<< $metaclass->add_role($role) >>
712 This takes a L<Moose::Meta::Role> object, and adds it to the class's
713 list of roles. This I<does not> actually apply the role to the class.
715 =item B<< $metaclass->does_role($role_name) >>
717 This returns a boolean indicating whether or not the class does the
718 specified role. This tests both the class and its parents.
720 =item B<< $metaclass->excludes_role($role_name) >>
722 A class excludes a role if it has already composed a role which
723 excludes the named role. This tests both the class and its parents.
725 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
727 This overrides the parent's method in order to allow the parameters to
728 be provided as a hash reference.
730 =item B<< $metaclass->constructor_class ($class_name) >>
732 =item B<< $metaclass->destructor_class ($class_name) >>
734 These are the names of classes used when making a class
735 immutable. These default to L<Moose::Meta::Method::Constructor> and
736 L<Moose::Meta::Method::Destructor> respectively. These accessors are
737 read-write, so you can use them to change the class name.
739 =item B<< $metaclass->error_class($class_name) >>
741 The name of the class used to throw errors. This defaults to
742 L<Moose::Error::Default>, which generates an error with a stacktrace
743 just like C<Carp::confess>.
745 =item B<< $metaclass->throw_error($message, %extra) >>
747 Throws the error created by C<create_error> using C<raise_error>
753 All complex software has bugs lurking in it, and this module is no
754 exception. If you find a bug please either email me, or add the bug
759 Stevan Little E<lt>stevan@iinteractive.comE<gt>
761 =head1 COPYRIGHT AND LICENSE
763 Copyright 2006-2009 by Infinity Interactive, Inc.
765 L<http://www.iinteractive.com>
767 This library is free software; you can redistribute it and/or modify
768 it under the same terms as Perl itself.