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';
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->compute_all_applicable_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}
191 sub construct_instance {
193 my $params = @_ == 1 ? $_[0] : {@_};
194 my $meta_instance = $class->get_meta_instance;
196 # the code below is almost certainly incorrect
197 # but this is foreign inheritance, so we might
198 # have to kludge it in the end.
199 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
200 foreach my $attr ($class->compute_all_applicable_attributes()) {
201 $attr->initialize_instance_slot($meta_instance, $instance, $params);
206 ### ---------------------------------------------
210 $self->SUPER::add_attribute(
211 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
213 : $self->_process_attribute(@_))
217 sub add_override_method_modifier {
218 my ($self, $name, $method, $_super_package) = @_;
220 (!$self->has_method($name))
221 || $self->throw_error("Cannot add an override method if a local method is already present");
223 $self->add_method($name => Moose::Meta::Method::Overridden->new(
226 package => $_super_package, # need this for roles
231 sub add_augment_method_modifier {
232 my ($self, $name, $method) = @_;
233 (!$self->has_method($name))
234 || $self->throw_error("Cannot add an augment method if a local method is already present");
236 $self->add_method($name => Moose::Meta::Method::Augmented->new(
243 ## Private Utility methods ...
245 sub _find_next_method_by_name_which_is_not_overridden {
246 my ($self, $name) = @_;
247 foreach my $method ($self->find_all_methods_by_name($name)) {
248 return $method->{code}
249 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
254 sub _fix_metaclass_incompatibility {
255 my ($self, @superclasses) = @_;
257 foreach my $super (@superclasses) {
258 next if $self->_superclass_meta_is_compatible($super);
260 unless ( $self->is_pristine ) {
262 "Cannot attempt to reinitialize metaclass for "
264 . ", it isn't pristine" );
267 $self->_reconcile_with_superclass_meta($super);
271 sub _superclass_meta_is_compatible {
272 my ($self, $super) = @_;
274 my $super_meta = Class::MOP::Class->initialize($super)
277 next unless $super_meta->isa("Class::MOP::Class");
280 = $super_meta->is_immutable
281 ? $super_meta->get_mutable_metaclass_name
285 if $self->isa($super_meta_name)
287 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
290 # I don't want to have to type this >1 time
292 qw( attribute_metaclass method_metaclass instance_metaclass
293 constructor_class destructor_class error_class );
295 sub _reconcile_with_superclass_meta {
296 my ($self, $super) = @_;
298 my $super_meta = Class::MOP::class_of($super);
301 = $super_meta->is_immutable
302 ? $super_meta->get_mutable_metaclass_name
305 my $self_metaclass = ref $self;
307 # If neither of these is true we have a more serious
308 # incompatibility that we just cannot fix (yet?).
309 if ( $super_meta_name->isa( ref $self )
310 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
311 $self->_reinitialize_with($super_meta);
313 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
314 $self->_reconcile_role_differences($super_meta);
318 sub _reinitialize_with {
319 my ( $self, $new_meta ) = @_;
321 my $new_self = $new_meta->reinitialize(
323 attribute_metaclass => $new_meta->attribute_metaclass,
324 method_metaclass => $new_meta->method_metaclass,
325 instance_metaclass => $new_meta->instance_metaclass,
328 $new_self->$_( $new_meta->$_ )
329 for qw( constructor_class destructor_class error_class );
333 bless $self, ref $new_self;
335 # We need to replace the cached metaclass instance or else when it
336 # goes out of scope Class::MOP::Class destroy's the namespace for
337 # the metaclass's class, causing much havoc.
338 Class::MOP::store_metaclass_by_name( $self->name, $self );
339 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
342 # In the more complex case, we share a common ancestor with our
343 # superclass's metaclass, but each metaclass (ours and the parent's)
344 # has a different set of roles applied. We reconcile this by first
345 # reinitializing into the parent class, and _then_ applying our own
347 sub _all_metaclasses_differ_by_roles_only {
348 my ($self, $super_meta) = @_;
351 [ ref $self, ref $super_meta ],
352 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
355 next if $pair->[0] eq $pair->[1];
357 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
358 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
361 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
363 return unless $common_ancestor;
366 unless _is_role_only_subclass_of(
370 && _is_role_only_subclass_of(
379 # This, and some other functions, could be called as methods, but
380 # they're not for two reasons. One, we just end up ignoring the first
381 # argument, because we can't call these directly on one of the real
382 # arguments, because one of them could be a Class::MOP::Class object
383 # and not a Moose::Meta::Class. Second, only a completely insane
384 # person would attempt to subclass this stuff!
385 sub _find_common_ancestor {
386 my ($meta1, $meta2) = @_;
388 # FIXME? This doesn't account for multiple inheritance (not sure
389 # if it needs to though). For example, is somewhere in $meta1's
390 # history it inherits from both ClassA and ClassB, and $meta2
391 # inherits from ClassB & ClassA, does it matter? And what crazy
392 # fool would do that anyway?
394 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
396 return first { $meta1_parents{$_} } $meta2->linearized_isa;
399 sub _is_role_only_subclass_of {
400 my ($meta, $ancestor) = @_;
402 return 1 if $meta->name eq $ancestor;
404 my @roles = _all_roles_until( $meta, $ancestor );
406 my %role_packages = map { $_->name => 1 } @roles;
408 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
410 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
412 for my $method ( $meta->get_all_methods() ) {
413 next if $method->name eq 'meta';
414 next if $method->can('associated_attribute');
417 if $role_packages{ $method->original_package_name }
418 || $shared_ancestors{ $method->original_package_name };
423 # FIXME - this really isn't right. Just because an attribute is
424 # defined in a role doesn't mean it isn't _also_ defined in the
426 for my $attr ( $meta->get_all_attributes ) {
427 next if $shared_ancestors{ $attr->associated_class->name };
429 next if any { $_->has_attribute( $attr->name ) } @roles;
440 return _all_roles_until($meta);
443 sub _all_roles_until {
444 my ($meta, $stop_at_class) = @_;
446 return unless $meta->can('calculate_all_roles');
448 my @roles = $meta->calculate_all_roles;
450 for my $class ( $meta->linearized_isa ) {
451 last if $stop_at_class && $stop_at_class eq $class;
453 my $meta = Class::MOP::Class->initialize($class);
454 last unless $meta->can('calculate_all_roles');
456 push @roles, $meta->calculate_all_roles;
462 sub _reconcile_role_differences {
463 my ($self, $super_meta) = @_;
465 my $self_meta = $self->meta;
469 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
470 $roles{metaclass_roles} = \@roles;
473 for my $thing (@MetaClassTypes) {
474 my $name = $self->$thing();
476 my $thing_meta = Class::MOP::Class->initialize($name);
478 my @roles = map { $_->name } _all_roles($thing_meta)
481 $roles{ $thing . '_roles' } = \@roles;
484 $self->_reinitialize_with($super_meta);
486 Moose::Util::MetaRole::apply_metaclass_roles(
487 for_class => $self->name,
495 # this was crap anyway, see
496 # Moose::Util::apply_all_roles
498 sub _apply_all_roles {
499 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
502 sub _process_attribute {
503 my ( $self, $name, @args ) = @_;
505 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
507 if (($name || '') =~ /^\+(.*)/) {
508 return $self->_process_inherited_attribute($1, @args);
511 return $self->_process_new_attribute($name, @args);
515 sub _process_new_attribute {
516 my ( $self, $name, @args ) = @_;
518 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
521 sub _process_inherited_attribute {
522 my ($self, $attr_name, %options) = @_;
523 my $inherited_attr = $self->find_attribute_by_name($attr_name);
524 (defined $inherited_attr)
525 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
526 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
527 return $inherited_attr->clone_and_inherit_options(%options);
531 # kind of a kludge to handle Class::MOP::Attributes
532 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
536 ## -------------------------------------------------
538 use Moose::Meta::Method::Constructor;
539 use Moose::Meta::Method::Destructor;
542 sub _default_immutable_transformer_options {
545 my %options = $self->SUPER::_default_immutable_transformer_options;
547 # We need to copy the references as we do not want to alter the
548 # superclass's references.
549 $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
550 $options{memoize} = {
551 %{ $options{memoize} },
552 calculate_all_roles => 'ARRAY',
557 constructor_class => $self->constructor_class,
558 destructor_class => $self->destructor_class,
559 inline_destructor => 1,
561 # Moose always does this when an attribute is created
562 inline_accessors => 0,
571 my ( $self, @args ) = @_;
572 local $error_level = ($error_level || 0) + 1;
573 $self->raise_error($self->create_error(@args));
577 my ( $self, @args ) = @_;
582 my ( $self, @args ) = @_;
586 local $error_level = ($error_level || 0 ) + 1;
588 if ( @args % 2 == 1 ) {
589 unshift @args, "message";
592 my %args = ( metaclass => $self, last_error => $@, @args );
594 $args{depth} += $error_level;
596 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
598 Class::MOP::load_class($class);
601 Carp::caller_info($args{depth}),
614 Moose::Meta::Class - The Moose metaclass
618 This class is a subclass of L<Class::MOP::Class> that provides
619 additional Moose-specific functionality.
621 To really understand this class, you will need to start with the
622 L<Class::MOP::Class> documentation. This class can be understood as a
623 set of additional features on top of the basic feature provided by
628 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
634 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
636 This overrides the parent's method in order to provide its own
637 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
638 C<method_metaclass> options.
640 These all default to the appropriate Moose class.
642 =item B<< Moose::Meta::Class->create($package_name, %options) >>
644 This overrides the parent's method in order to accept a C<roles>
645 option. This should be an array reference containing one more roles
648 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
650 =item B<< Moose::Meta::Class->create_anon_class >>
652 This overrides the parent's method to accept a C<roles> option, just
655 It also accepts a C<cache> option. If this is true, then the anonymous
656 class will be cached based on its superclasses and roles. If an
657 existing anonymous class in the cache has the same superclasses and
658 roles, it will be reused.
660 my $metaclass = Moose::Meta::Class->create_anon_class(
661 superclasses => ['Foo'],
662 roles => [qw/Some Roles Go Here/],
666 =item B<< $metaclass->make_immutable(%options) >>
668 This overrides the parent's method to add a few options. Specifically,
669 it uses the Moose-specific constructor and destructor classes, and
670 enables inlining the destructor.
672 Also, since Moose always inlines attributes, it sets the
673 C<inline_accessors> option to false.
675 =item B<< $metaclass->new_object(%params) >>
677 This overrides the parent's method in order to add support for
680 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
682 This adds an C<override> method modifier to the package.
684 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
686 This adds an C<augment> method modifier to the package.
688 =item B<< $metaclass->calculate_all_roles >>
690 This will return a unique array of C<Moose::Meta::Role> instances
691 which are attached to this class.
693 =item B<< $metaclass->add_role($role) >>
695 This takes a L<Moose::Meta::Role> object, and adds it to the class's
696 list of roles. This I<does not> actually apply the role to the class.
698 =item B<< $metaclass->does_role($role_name) >>
700 This returns a boolean indicating whether or not the class does the
701 specified role. This tests both the class and its parents.
703 =item B<< $metaclass->excludes_role($role_name) >>
705 A class excludes a role if it has already composed a role which
706 excludes the named role. This tests both the class and its parents.
708 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
710 This overrides the parent's method in order to allow the parameters to
711 be provided as a hash reference.
713 =item B<< $metaclass->constructor_class ($class_name) >>
715 =item B<< $metaclass->destructor_class ($class_name) >>
717 These are the names of classes used when making a class
718 immutable. These default to L<Moose::Meta::Method::Constructor> and
719 L<Moose::Meta::Method::Destructor> respectively. These accessors are
720 read-write, so you can use them to change the class name.
722 =item B<< $metaclass->error_class($class_name) >>
724 The name of the class used to throw errors. This defaults to
725 L<Moose::Error::Default>, which generates an error with a stacktrace
726 just like C<Carp::confess>.
728 =item B<< $metaclass->throw_error($message, %extra) >>
730 Throws the error created by C<create_error> using C<raise_error>
736 All complex software has bugs lurking in it, and this module is no
737 exception. If you find a bug please either email me, or add the bug
742 Stevan Little E<lt>stevan@iinteractive.comE<gt>
744 =head1 COPYRIGHT AND LICENSE
746 Copyright 2006-2009 by Infinity Interactive, Inc.
748 L<http://www.iinteractive.com>
750 This library is free software; you can redistribute it and/or modify
751 it under the same terms as Perl itself.