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.63';
15 $VERSION = eval $VERSION;
16 our $AUTHORITY = 'cpan:STEVAN';
18 use Moose::Meta::Method::Overriden;
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('|', sort @{$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 inheritence, 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::Overriden->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::Overriden');
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 $meta
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", 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 is a subclass of L<Class::MOP::Class> with Moose specific
642 For the most part, the only time you will ever encounter an
643 instance of this class is if you are doing some serious deep
644 introspection. To really understand this class, you need to refer
645 to the L<Class::MOP::Class> documentation.
655 Overrides original to accept a list of roles to apply to
658 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
660 =item B<create_anon_class>
662 Overrides original to support roles and caching.
664 my $metaclass = Moose::Meta::Class->create_anon_class(
665 superclasses => ['Foo'],
666 roles => [qw/Some Roles Go Here/],
670 =item B<make_immutable>
672 Override original to add default options for inlining destructor
673 and altering the Constructor metaclass.
675 =item B<create_immutable_transformer>
677 Override original to lock C<add_role> and memoize C<calculate_all_roles>
681 We override this method to support the C<trigger> attribute option.
683 =item B<construct_instance>
685 This provides some Moose specific extensions to this method, you
686 almost never call this method directly unless you really know what
689 This method makes sure to handle the moose weak-ref, type-constraint
690 and type coercion features.
692 =item B<get_method_map>
694 This accommodates Moose::Meta::Role::Method instances, which are
695 aliased, instead of added, but still need to be counted as valid
698 =item B<add_override_method_modifier ($name, $method)>
700 This will create an C<override> method modifier for you, and install
703 =item B<add_augment_method_modifier ($name, $method)>
705 This will create an C<augment> method modifier for you, and install
708 =item B<calculate_all_roles>
712 This will return an array of C<Moose::Meta::Role> instances which are
713 attached to this class.
715 =item B<add_role ($role)>
717 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
718 to the list of associated roles.
720 =item B<does_role ($role_name)>
722 This will test if this class C<does> a given C<$role_name>. It will
723 not only check it's local roles, but ask them as well in order to
724 cascade down the role hierarchy.
726 =item B<excludes_role ($role_name)>
728 This will test if this class C<excludes> a given C<$role_name>. It will
729 not only check it's local roles, but ask them as well in order to
730 cascade down the role hierarchy.
732 =item B<add_attribute ($attr_name, %params|$params)>
734 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
735 support for taking the C<$params> as a HASH ref.
737 =item B<constructor_class ($class_name)>
739 =item B<destructor_class ($class_name)>
741 These are the names of classes used when making a class
742 immutable. These default to L<Moose::Meta::Method::Constructor> and
743 L<Moose::Meta::Method::Destructor> respectively. These accessors are
744 read-write, so you can use them to change the class name.
746 =item B<error_class ($class_name)>
748 The name of the class used to throw errors. This default to
749 L<Moose::Error::Default>, which generates an error with a stacktrace
750 just like C<Carp::confess>.
752 =item B<check_metaclass_compatibility>
754 Moose overrides this method from C<Class::MOP::Class> and attempts to
755 fix some incompatibilities before doing the check.
757 =item B<throw_error $message, %extra>
759 Throws the error created by C<create_error> using C<raise_error>
761 =item B<create_error $message, %extra>
763 Creates an error message or object.
765 The default behavior is C<create_error_confess>.
767 If C<error_class> is set uses C<create_error_object>. Otherwise uses
768 C<error_builder> (a code reference or variant name), and calls the appropriate
769 C<create_error_$builder> method.
771 =item B<error_builder $builder_name>
773 Get or set the error builder. Defaults to C<confess>.
775 =item B<error_class $class_name>
777 Get or set the error class. This defaults to L<Moose::Error::Default>.
779 =item B<create_error_confess %args>
781 Creates an error using L<Carp/longmess>
783 =item B<create_error_croak %args>
785 Creates an error using L<Carp/shortmess>
787 =item B<create_error_object %args>
789 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
790 to support custom error objects for your meta class.
792 =item B<raise_error $error>
794 Dies with an error object or string.
800 All complex software has bugs lurking in it, and this module is no
801 exception. If you find a bug please either email me, or add the bug
806 Stevan Little E<lt>stevan@iinteractive.comE<gt>
808 =head1 COPYRIGHT AND LICENSE
810 Copyright 2006-2008 by Infinity Interactive, Inc.
812 L<http://www.iinteractive.com>
814 This library is free software; you can redistribute it and/or modify
815 it under the same terms as Perl itself.