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 next unless $meta && $meta->can('roles');
131 foreach my $role (@{$meta->roles}) {
132 return 1 if $role->does_role($role_name);
139 my ($self, $role_name) = @_;
141 || $self->throw_error("You must supply a role name to look for");
142 foreach my $class ($self->class_precedence_list) {
143 next unless $class->can('meta');
145 # in the pretty rare instance when a Moose metaclass
146 # is itself extended with a role, this check needs to
147 # be done since some items in the class_precedence_list
148 # might in fact be Class::MOP based still.
149 next unless $class->meta->can('roles');
150 foreach my $role (@{$class->meta->roles}) {
151 return 1 if $role->excludes_role($role_name);
159 my $params = @_ == 1 ? $_[0] : {@_};
160 my $self = $class->SUPER::new_object($params);
162 foreach my $attr ( $class->compute_all_applicable_attributes() ) {
164 next unless $attr->can('has_trigger') && $attr->has_trigger;
166 my $init_arg = $attr->init_arg;
168 next unless defined $init_arg;
170 next unless exists $params->{$init_arg};
176 ? $attr->get_read_method_ref->($self)
177 : $params->{$init_arg}
186 sub construct_instance {
188 my $params = @_ == 1 ? $_[0] : {@_};
189 my $meta_instance = $class->get_meta_instance;
191 # the code below is almost certainly incorrect
192 # but this is foreign inheritance, so we might
193 # have to kludge it in the end.
194 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
195 foreach my $attr ($class->compute_all_applicable_attributes()) {
196 $attr->initialize_instance_slot($meta_instance, $instance, $params);
201 ### ---------------------------------------------
205 $self->SUPER::add_attribute(
206 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
208 : $self->_process_attribute(@_))
212 sub add_override_method_modifier {
213 my ($self, $name, $method, $_super_package) = @_;
215 (!$self->has_method($name))
216 || $self->throw_error("Cannot add an override method if a local method is already present");
218 $self->add_method($name => Moose::Meta::Method::Overridden->new(
221 package => $_super_package, # need this for roles
226 sub add_augment_method_modifier {
227 my ($self, $name, $method) = @_;
228 (!$self->has_method($name))
229 || $self->throw_error("Cannot add an augment method if a local method is already present");
231 $self->add_method($name => Moose::Meta::Method::Augmented->new(
238 ## Private Utility methods ...
240 sub _find_next_method_by_name_which_is_not_overridden {
241 my ($self, $name) = @_;
242 foreach my $method ($self->find_all_methods_by_name($name)) {
243 return $method->{code}
244 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
249 sub _fix_metaclass_incompatibility {
250 my ($self, @superclasses) = @_;
252 foreach my $super (@superclasses) {
253 next if $self->_superclass_meta_is_compatible($super);
255 unless ( $self->is_pristine ) {
257 "Cannot attempt to reinitialize metaclass for "
259 . ", it isn't pristine" );
262 $self->_reconcile_with_superclass_meta($super);
266 sub _superclass_meta_is_compatible {
267 my ($self, $super) = @_;
269 my $super_meta = Class::MOP::Class->initialize($super)
272 next unless $super_meta->isa("Class::MOP::Class");
275 = $super_meta->is_immutable
276 ? $super_meta->get_mutable_metaclass_name
280 if $self->isa($super_meta_name)
282 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
285 # I don't want to have to type this >1 time
287 qw( attribute_metaclass method_metaclass instance_metaclass
288 constructor_class destructor_class error_class );
290 sub _reconcile_with_superclass_meta {
291 my ($self, $super) = @_;
293 my $super_meta = $super->meta;
296 = $super_meta->is_immutable
297 ? $super_meta->get_mutable_metaclass_name
300 my $self_metaclass = ref $self;
302 # If neither of these is true we have a more serious
303 # incompatibility that we just cannot fix (yet?).
304 if ( $super_meta_name->isa( ref $self )
305 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
306 $self->_reinitialize_with($super_meta);
308 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
309 $self->_reconcile_role_differences($super_meta);
313 sub _reinitialize_with {
314 my ( $self, $new_meta ) = @_;
316 my $new_self = $new_meta->reinitialize(
318 attribute_metaclass => $new_meta->attribute_metaclass,
319 method_metaclass => $new_meta->method_metaclass,
320 instance_metaclass => $new_meta->instance_metaclass,
323 $new_self->$_( $new_meta->$_ )
324 for qw( constructor_class destructor_class error_class );
328 bless $self, ref $new_self;
330 # We need to replace the cached metaclass instance or else when it
331 # goes out of scope Class::MOP::Class destroy's the namespace for
332 # the metaclass's class, causing much havoc.
333 Class::MOP::store_metaclass_by_name( $self->name, $self );
334 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
337 # In the more complex case, we share a common ancestor with our
338 # superclass's metaclass, but each metaclass (ours and the parent's)
339 # has a different set of roles applied. We reconcile this by first
340 # reinitializing into the parent class, and _then_ applying our own
342 sub _all_metaclasses_differ_by_roles_only {
343 my ($self, $super_meta) = @_;
346 [ ref $self, ref $super_meta ],
347 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
350 next if $pair->[0] eq $pair->[1];
352 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
353 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
356 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
358 return unless $common_ancestor;
361 unless _is_role_only_subclass_of(
365 && _is_role_only_subclass_of(
374 # This, and some other functions, could be called as methods, but
375 # they're not for two reasons. One, we just end up ignoring the first
376 # argument, because we can't call these directly on one of the real
377 # arguments, because one of them could be a Class::MOP::Class object
378 # and not a Moose::Meta::Class. Second, only a completely insane
379 # person would attempt to subclass this stuff!
380 sub _find_common_ancestor {
381 my ($meta1, $meta2) = @_;
383 # FIXME? This doesn't account for multiple inheritance (not sure
384 # if it needs to though). For example, is somewhere in $meta1's
385 # history it inherits from both ClassA and ClassB, and $meta2
386 # inherits from ClassB & ClassA, does it matter? And what crazy
387 # fool would do that anyway?
389 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
391 return first { $meta1_parents{$_} } $meta2->linearized_isa;
394 sub _is_role_only_subclass_of {
395 my ($meta, $ancestor) = @_;
397 return 1 if $meta->name eq $ancestor;
399 my @roles = _all_roles_until( $meta, $ancestor );
401 my %role_packages = map { $_->name => 1 } @roles;
403 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
405 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
407 for my $method ( $meta->get_all_methods() ) {
408 next if $method->name eq 'meta';
409 next if $method->can('associated_attribute');
412 if $role_packages{ $method->original_package_name }
413 || $shared_ancestors{ $method->original_package_name };
418 # FIXME - this really isn't right. Just because an attribute is
419 # defined in a role doesn't mean it isn't _also_ defined in the
421 for my $attr ( $meta->get_all_attributes ) {
422 next if $shared_ancestors{ $attr->associated_class->name };
424 next if any { $_->has_attribute( $attr->name ) } @roles;
435 return _all_roles_until($meta);
438 sub _all_roles_until {
439 my ($meta, $stop_at_class) = @_;
441 return unless $meta->can('calculate_all_roles');
443 my @roles = $meta->calculate_all_roles;
445 for my $class ( $meta->linearized_isa ) {
446 last if $stop_at_class && $stop_at_class eq $class;
448 my $meta = Class::MOP::Class->initialize($class);
449 last unless $meta->can('calculate_all_roles');
451 push @roles, $meta->calculate_all_roles;
457 sub _reconcile_role_differences {
458 my ($self, $super_meta) = @_;
460 my $self_meta = $self->meta;
464 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
465 $roles{metaclass_roles} = \@roles;
468 for my $thing (@MetaClassTypes) {
469 my $name = $self->$thing();
471 my $thing_meta = Class::MOP::Class->initialize($name);
473 my @roles = map { $_->name } _all_roles($thing_meta)
476 $roles{ $thing . '_roles' } = \@roles;
479 $self->_reinitialize_with($super_meta);
481 Moose::Util::MetaRole::apply_metaclass_roles(
482 for_class => $self->name,
490 # this was crap anyway, see
491 # Moose::Util::apply_all_roles
493 sub _apply_all_roles {
494 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
497 sub _process_attribute {
498 my ( $self, $name, @args ) = @_;
500 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
502 if (($name || '') =~ /^\+(.*)/) {
503 return $self->_process_inherited_attribute($1, @args);
506 return $self->_process_new_attribute($name, @args);
510 sub _process_new_attribute {
511 my ( $self, $name, @args ) = @_;
513 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
516 sub _process_inherited_attribute {
517 my ($self, $attr_name, %options) = @_;
518 my $inherited_attr = $self->find_attribute_by_name($attr_name);
519 (defined $inherited_attr)
520 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
521 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
522 return $inherited_attr->clone_and_inherit_options(%options);
526 # kind of a kludge to handle Class::MOP::Attributes
527 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
531 ## -------------------------------------------------
533 use Moose::Meta::Method::Constructor;
534 use Moose::Meta::Method::Destructor;
537 sub _default_immutable_transformer_options {
540 my %options = $self->SUPER::_default_immutable_transformer_options;
542 # We need to copy the references as we do not want to alter the
543 # superclass's references.
544 $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
545 $options{memoize} = {
546 %{ $options{memoize} },
547 calculate_all_roles => 'ARRAY',
552 constructor_class => $self->constructor_class,
553 destructor_class => $self->destructor_class,
554 inline_destructor => 1,
556 # Moose always does this when an attribute is created
557 inline_accessors => 0,
566 my ( $self, @args ) = @_;
567 local $error_level = ($error_level || 0) + 1;
568 $self->raise_error($self->create_error(@args));
572 my ( $self, @args ) = @_;
577 my ( $self, @args ) = @_;
581 local $error_level = ($error_level || 0 ) + 1;
583 if ( @args % 2 == 1 ) {
584 unshift @args, "message";
587 my %args = ( metaclass => $self, last_error => $@, @args );
589 $args{depth} += $error_level;
591 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
593 Class::MOP::load_class($class);
596 Carp::caller_info($args{depth}),
609 Moose::Meta::Class - The Moose metaclass
613 This class is a subclass of L<Class::MOP::Class> that provides
614 additional Moose-specific functionality.
616 To really understand this class, you will need to start with the
617 L<Class::MOP::Class> documentation. This class can be understood as a
618 set of additional features on top of the basic feature provided by
623 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
629 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
631 This overrides the parent's method in order to provide its own
632 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
633 C<method_metaclass> options.
635 These all default to the appropriate Moose class.
637 =item B<< Moose::Meta::Class->create($package_name, %options) >>
639 This overrides the parent's method in order to accept a C<roles>
640 option. This should be an array reference containing one more roles
643 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
645 =item B<< Moose::Meta::Class->create_anon_class >>
647 This overrides the parent's method to accept a C<roles> option, just
650 It also accepts a C<cache> option. If this is true, then the anonymous
651 class will be cached based on its superclasses and roles. If an
652 existing anonymous class in the cache has the same superclasses and
653 roles, it will be reused.
655 my $metaclass = Moose::Meta::Class->create_anon_class(
656 superclasses => ['Foo'],
657 roles => [qw/Some Roles Go Here/],
661 =item B<< $metaclass->make_immutable(%options) >>
663 This overrides the parent's method to add a few options. Specifically,
664 it uses the Moose-specific constructor and destructor classes, and
665 enables inlining the destructor.
667 Also, since Moose always inlines attributes, it sets the
668 C<inline_accessors> option to false.
670 =item B<< $metaclass->new_object(%params) >>
672 This overrides the parent's method in order to add support for
675 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
677 This adds an C<override> method modifier to the package.
679 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
681 This adds an C<augment> method modifier to the package.
683 =item B<< $metaclass->calculate_all_roles >>
685 This will return a unique array of C<Moose::Meta::Role> instances
686 which are attached to this class.
688 =item B<< $metaclass->add_role($role) >>
690 This takes a L<Moose::Meta::Role> object, and adds it to the class's
691 list of roles. This I<does not> actually apply the role to the class.
693 =item B<< $metaclass->does_role($role_name) >>
695 This returns a boolean indicating whether or not the class does the
696 specified role. This tests both the class and its parents.
698 =item B<< $metaclass->excludes_role($role_name) >>
700 A class excludes a role if it has already composed a role which
701 excludes the named role. This tests both the class and its parents.
703 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
705 This overrides the parent's method in order to allow the parameters to
706 be provided as a hash reference.
708 =item B<< $metaclass->constructor_class ($class_name) >>
710 =item B<< $metaclass->destructor_class ($class_name) >>
712 These are the names of classes used when making a class
713 immutable. These default to L<Moose::Meta::Method::Constructor> and
714 L<Moose::Meta::Method::Destructor> respectively. These accessors are
715 read-write, so you can use them to change the class name.
717 =item B<< $metaclass->error_class($class_name) >>
719 The name of the class used to throw errors. This defaults to
720 L<Moose::Error::Default>, which generates an error with a stacktrace
721 just like C<Carp::confess>.
723 =item B<< $metaclass->throw_error($message, %extra) >>
725 Throws the error created by C<create_error> using C<raise_error>
731 All complex software has bugs lurking in it, and this module is no
732 exception. If you find a bug please either email me, or add the bug
737 Stevan Little E<lt>stevan@iinteractive.comE<gt>
739 =head1 COPYRIGHT AND LICENSE
741 Copyright 2006-2009 by Infinity Interactive, Inc.
743 L<http://www.iinteractive.com>
745 This library is free software; you can redistribute it and/or modify
746 it under the same terms as Perl itself.