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.74';
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,
493 sub _process_attribute {
494 my ( $self, $name, @args ) = @_;
496 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
498 if (($name || '') =~ /^\+(.*)/) {
499 return $self->_process_inherited_attribute($1, @args);
502 return $self->_process_new_attribute($name, @args);
506 sub _process_new_attribute {
507 my ( $self, $name, @args ) = @_;
509 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
512 sub _process_inherited_attribute {
513 my ($self, $attr_name, %options) = @_;
514 my $inherited_attr = $self->find_attribute_by_name($attr_name);
515 (defined $inherited_attr)
516 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
517 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
518 return $inherited_attr->clone_and_inherit_options(%options);
522 # kind of a kludge to handle Class::MOP::Attributes
523 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
527 ## -------------------------------------------------
529 use Moose::Meta::Method::Constructor;
530 use Moose::Meta::Method::Destructor;
533 sub _default_immutable_transformer_options {
536 my %options = $self->SUPER::_default_immutable_transformer_options;
538 # We need to copy the references as we do not want to alter the
539 # superclass's references.
540 $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
541 $options{memoize} = {
542 %{ $options{memoize} },
543 calculate_all_roles => 'ARRAY',
548 constructor_class => $self->constructor_class,
549 destructor_class => $self->destructor_class,
550 inline_destructor => 1,
552 # Moose always does this when an attribute is created
553 inline_accessors => 0,
562 my ( $self, @args ) = @_;
563 local $error_level = ($error_level || 0) + 1;
564 $self->raise_error($self->create_error(@args));
568 my ( $self, @args ) = @_;
573 my ( $self, @args ) = @_;
577 local $error_level = ($error_level || 0 ) + 1;
579 if ( @args % 2 == 1 ) {
580 unshift @args, "message";
583 my %args = ( metaclass => $self, last_error => $@, @args );
585 $args{depth} += $error_level;
587 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
589 Class::MOP::load_class($class);
592 Carp::caller_info($args{depth}),
605 Moose::Meta::Class - The Moose metaclass
609 This class is a subclass of L<Class::MOP::Class> that provides
610 additional Moose-specific functionality.
612 To really understand this class, you will need to start with the
613 L<Class::MOP::Class> documentation. This class can be understood as a
614 set of additional features on top of the basic feature provided by
619 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
625 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
627 This overrides the parent's method in order to provide its own
628 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
629 C<method_metaclass> options.
631 These all default to the appropriate Moose class.
633 =item B<< Moose::Meta::Class->create($package_name, %options) >>
635 This overrides the parent's method in order to accept a C<roles>
636 option. This should be an array reference containing one more roles
639 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
641 =item B<< Moose::Meta::Class->create_anon_class >>
643 This overrides the parent's method to accept a C<roles> option, just
646 It also accepts a C<cache> option. If this is true, then the anonymous
647 class will be cached based on its superclasses and roles. If an
648 existing anonymous class in the cache has the same superclasses and
649 roles, it will be reused.
651 my $metaclass = Moose::Meta::Class->create_anon_class(
652 superclasses => ['Foo'],
653 roles => [qw/Some Roles Go Here/],
657 =item B<< $metaclass->make_immutable(%options) >>
659 This overrides the parent's method to add a few options. Specifically,
660 it uses the Moose-specific constructor and destructor classes, and
661 enables inlining the destructor.
663 Also, since Moose always inlines attributes, it sets the
664 C<inline_accessors> option to false.
666 =item B<< $metaclass->new_object(%params) >>
668 This overrides the parent's method in order to add support for
671 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
673 This adds an C<override> method modifier to the package.
675 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
677 This adds an C<augment> method modifier to the package.
679 =item B<< $metaclass->calculate_all_roles >>
681 This will return a unique array of C<Moose::Meta::Role> instances
682 which are attached to this class.
684 =item B<< $metaclass->add_role($role) >>
686 This takes a L<Moose::Meta::Role> object, and adds it to the class's
687 list of roles. This I<does not> actually apply the role to the class.
689 =item B<< $metaclass->does_role($role_name) >>
691 This returns a boolean indicating whether or not the class does the
692 specified role. This tests both the class and its parents.
694 =item B<< $metaclass->excludes_role($role_name) >>
696 A class excludes a role if it has already composed a role which
697 excludes the named role. This tests both the class and its parents.
699 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
701 This overrides the parent's method in order to allow the parameters to
702 be provided as a hash reference.
704 =item B<< $metaclass->constructor_class ($class_name) >>
706 =item B<< $metaclass->destructor_class ($class_name) >>
708 These are the names of classes used when making a class
709 immutable. These default to L<Moose::Meta::Method::Constructor> and
710 L<Moose::Meta::Method::Destructor> respectively. These accessors are
711 read-write, so you can use them to change the class name.
713 =item B<< $metaclass->error_class($class_name) >>
715 The name of the class used to throw errors. This defaults to
716 L<Moose::Error::Default>, which generates an error with a stacktrace
717 just like C<Carp::confess>.
719 =item B<< $metaclass->throw_error($message, %extra) >>
721 Throws the error created by C<create_error> using C<raise_error>
727 All complex software has bugs lurking in it, and this module is no
728 exception. If you find a bug please either email me, or add the bug
733 Stevan Little E<lt>stevan@iinteractive.comE<gt>
735 =head1 COPYRIGHT AND LICENSE
737 Copyright 2006-2009 by Infinity Interactive, Inc.
739 L<http://www.iinteractive.com>
741 This library is free software; you can redistribute it and/or modify
742 it under the same terms as Perl itself.