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_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) = @_;
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;
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 class is a subclass of L<Class::MOP::Class> that provides
611 additional Moose-specific functionality.
613 To really understand this class, you will need to start with the
614 L<Class::MOP::Class> documentation. This class can be understood as a
615 set of additional features on top of the basic feature provided by
620 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
626 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
628 This overrides the parent's method in order to provide its own
629 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
630 C<method_metaclass> options.
632 These all default to the appropriate Moose class.
634 =item B<< Moose::Meta::Class->create($package_name, %options) >>
636 This overrides the parent's method in order to accept a C<roles>
637 option. This should be an array reference containing one more roles
640 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
642 =item B<< Moose::Meta::Class->create_anon_class >>
644 This overrides the parent's method to accept a C<roles> option, just
647 It also accepts a C<cache> option. If this is true, then the anonymous
648 class will be cached based on its superclasses and roles. If an
649 existing anonymous class in the cache has the same superclasses and
650 roles, it will be reused.
652 my $metaclass = Moose::Meta::Class->create_anon_class(
653 superclasses => ['Foo'],
654 roles => [qw/Some Roles Go Here/],
658 =item B<< $metaclass->make_immutable(%options) >>
660 This overrides the parent's method to add a few options. Specifically,
661 it uses the Moose-specific constructor and destructor classes, and
662 enables inlining the destructor.
664 Also, since Moose always inlines attributes, it sets the
665 C<inline_accessors> option to false.
667 =item B<< $metaclass->new_object(%params) >>
669 This overrides the parent's method in order to add support for
672 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
674 This adds an C<override> method modifier to the package.
676 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
678 This adds an C<augment> method modifier to the package.
680 =item B<< $metaclass->calculate_all_roles >>
682 This will return a unique array of C<Moose::Meta::Role> instances
683 which are attached to this class.
685 =item B<< $metaclass->add_role($role) >>
687 This takes a L<Moose::Meta::Role> object, and adds it to the class's
688 list of roles. This I<does not> actually apply the role to the class.
690 =item B<< $metaclass->does_role($role_name) >>
692 This returns a boolean indicating whether or not the class does the
693 specified role. This tests both the class and its parents.
695 =item B<< $metaclass->excludes_role($role_name) >>
697 A class excludes a role if it has already composed a role which
698 excludes the named role. This tests both the class and its parents.
700 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
702 This overrides the parent's method in order to allow the parameters to
703 be provided as a hash reference.
705 =item B<< $metaclass->constructor_class ($class_name) >>
707 =item B<< $metaclass->destructor_class ($class_name) >>
709 These are the names of classes used when making a class
710 immutable. These default to L<Moose::Meta::Method::Constructor> and
711 L<Moose::Meta::Method::Destructor> respectively. These accessors are
712 read-write, so you can use them to change the class name.
714 =item B<< $metaclass->error_class($class_name) >>
716 The name of the class used to throw errors. This defaults to
717 L<Moose::Error::Default>, which generates an error with a stacktrace
718 just like C<Carp::confess>.
720 =item B<< $metaclass->throw_error($message, %extra) >>
722 Throws the error created by C<create_error> using C<raise_error>
728 All complex software has bugs lurking in it, and this module is no
729 exception. If you find a bug please either email me, or add the bug
734 Stevan Little E<lt>stevan@iinteractive.comE<gt>
736 =head1 COPYRIGHT AND LICENSE
738 Copyright 2006-2009 by Infinity Interactive, Inc.
740 L<http://www.iinteractive.com>
742 This library is free software; you can redistribute it and/or modify
743 it under the same terms as Perl itself.