2 package Moose::Meta::Class;
10 use List::Util qw( first );
11 use List::MoreUtils qw( any all );
12 use Scalar::Util 'weaken', 'blessed';
14 our $VERSION = '0.57';
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 => sub { 'Moose::Meta::Method::Constructor' }
34 __PACKAGE__->meta->add_attribute('destructor_class' => (
35 accessor => 'destructor_class',
36 default => sub { '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};
64 my $class = $self->SUPER::create($package_name, %options);
66 if (exists $options{roles}) {
67 Moose::Util::apply_all_roles($class, @{$options{roles}});
73 sub check_metaclass_compatibility {
76 if ( my @supers = $self->superclasses ) {
77 $self->_fix_metaclass_incompatibility(@supers);
80 $self->SUPER::check_metaclass_compatibility(@_);
85 sub create_anon_class {
86 my ($self, %options) = @_;
88 my $cache_ok = delete $options{cache};
90 # something like Super::Class|Super::Class::2=Role|Role::1
91 my $cache_key = join '=' => (
92 join('|', sort @{$options{superclasses} || []}),
93 join('|', sort @{$options{roles} || []}),
96 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
97 return $ANON_CLASSES{$cache_key};
100 my $new_class = $self->SUPER::create_anon_class(%options);
102 $ANON_CLASSES{$cache_key} = $new_class
109 my ($self, $role) = @_;
110 (blessed($role) && $role->isa('Moose::Meta::Role'))
111 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
112 push @{$self->roles} => $role;
115 sub calculate_all_roles {
118 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
122 my ($self, $role_name) = @_;
124 || $self->throw_error("You must supply a role name to look for");
125 foreach my $class ($self->class_precedence_list) {
126 next unless $class->can('meta') && $class->meta->can('roles');
127 foreach my $role (@{$class->meta->roles}) {
128 return 1 if $role->does_role($role_name);
135 my ($self, $role_name) = @_;
137 || $self->throw_error("You must supply a role name to look for");
138 foreach my $class ($self->class_precedence_list) {
139 next unless $class->can('meta');
141 # in the pretty rare instance when a Moose metaclass
142 # is itself extended with a role, this check needs to
143 # be done since some items in the class_precedence_list
144 # might in fact be Class::MOP based still.
145 next unless $class->meta->can('roles');
146 foreach my $role (@{$class->meta->roles}) {
147 return 1 if $role->excludes_role($role_name);
155 my $params = @_ == 1 ? $_[0] : {@_};
156 my $self = $class->SUPER::new_object($params);
157 foreach my $attr ($class->compute_all_applicable_attributes()) {
158 # if we have a trigger, then ...
159 if ($attr->can('has_trigger') && $attr->has_trigger) {
160 # make sure we have an init-arg ...
161 if (defined(my $init_arg = $attr->init_arg)) {
162 # now make sure an init-arg was passes ...
163 if (exists $params->{$init_arg}) {
164 # and if get here, fire the trigger
167 # check if there is a coercion
168 ($attr->should_coerce
169 # and if so, we need to grab the
170 # value that is actually been stored
171 ? $attr->get_read_method_ref->($self)
172 # otherwise, just get the value from
173 # the constructor params
174 : $params->{$init_arg}),
184 sub construct_instance {
186 my $params = @_ == 1 ? $_[0] : {@_};
187 my $meta_instance = $class->get_meta_instance;
189 # the code below is almost certainly incorrect
190 # but this is foreign inheritence, so we might
191 # have to kludge it in the end.
192 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
193 foreach my $attr ($class->compute_all_applicable_attributes()) {
194 $attr->initialize_instance_slot($meta_instance, $instance, $params);
204 my $current = Class::MOP::check_package_cache_flag($self->name);
206 if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
207 return $self->{'methods'};
210 $self->{_package_cache_flag} = $current;
212 my $map = $self->{'methods'};
214 my $class_name = $self->name;
215 my $method_metaclass = $self->method_metaclass;
217 my %all_code = $self->get_all_package_symbols('CODE');
219 foreach my $symbol (keys %all_code) {
220 my $code = $all_code{$symbol};
222 next if exists $map->{$symbol} &&
223 defined $map->{$symbol} &&
224 $map->{$symbol}->body == $code;
226 my ($pkg, $name) = Class::MOP::get_code_info($code);
228 if ($pkg->can('meta')
230 # we don't know what ->meta we are calling
231 # here, so we need to be careful cause it
232 # just might blow up at us, or just complain
233 # loudly (in the case of Curses.pm) so we
234 # just be a little overly cautious here.
236 && eval { no warnings; blessed($pkg->meta) }
237 && $pkg->meta->isa('Moose::Meta::Role')) {
238 #my $role = $pkg->meta->name;
239 #next unless $self->does_role($role);
244 # in 5.10 constant.pm the constants show up
245 # as being in the right package, but in pre-5.10
246 # they show up as constant::__ANON__ so we
247 # make an exception here to be sure that things
248 # work as expected in both.
250 unless ($pkg eq 'constant' && $name eq '__ANON__') {
251 next if ($pkg || '') ne $class_name ||
252 (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
257 $map->{$symbol} = $method_metaclass->wrap(
259 package_name => $class_name,
267 ### ---------------------------------------------
271 $self->SUPER::add_attribute(
272 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
274 : $self->_process_attribute(@_))
278 sub add_override_method_modifier {
279 my ($self, $name, $method, $_super_package) = @_;
281 (!$self->has_method($name))
282 || $self->throw_error("Cannot add an override method if a local method is already present");
284 $self->add_method($name => Moose::Meta::Method::Overriden->new(
287 package => $_super_package, # need this for roles
292 sub add_augment_method_modifier {
293 my ($self, $name, $method) = @_;
294 (!$self->has_method($name))
295 || $self->throw_error("Cannot add an augment method if a local method is already present");
297 $self->add_method($name => Moose::Meta::Method::Augmented->new(
304 ## Private Utility methods ...
306 sub _find_next_method_by_name_which_is_not_overridden {
307 my ($self, $name) = @_;
308 foreach my $method ($self->find_all_methods_by_name($name)) {
309 return $method->{code}
310 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
315 sub _fix_metaclass_incompatibility {
316 my ($self, @superclasses) = @_;
318 foreach my $super (@superclasses) {
319 next if $self->_superclass_meta_is_compatible($super);
321 unless ( $self->is_pristine ) {
323 "Cannot attempt to reinitialize metaclass for "
325 . ", it isn't pristine" );
328 $self->_reconcile_with_superclass_meta($super);
332 sub _superclass_meta_is_compatible {
333 my ($self, $super) = @_;
335 my $super_meta = Class::MOP::Class->initialize($super)
338 next unless $super_meta->isa("Class::MOP::Class");
341 = $super_meta->is_immutable
342 ? $super_meta->get_mutable_metaclass_name
346 if $self->isa($super_meta_name)
348 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
351 # I don't want to have to type this >1 time
353 qw( attribute_metaclass method_metaclass instance_metaclass constructor_class destructor_class );
355 sub _reconcile_with_superclass_meta {
356 my ($self, $super) = @_;
358 my $super_meta = $super->meta;
361 = $super_meta->is_immutable
362 ? $super_meta->get_mutable_metaclass_name
365 my $self_metaclass = ref $self;
367 # If neither of these is true we have a more serious
368 # incompatibility that we just cannot fix (yet?).
369 if ( $super_meta_name->isa( ref $self )
370 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
371 $self->_reinitialize_with($super_meta);
373 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
374 $self->_reconcile_role_differences($super_meta);
378 sub _reinitialize_with {
379 my ( $self, $new_meta ) = @_;
381 my $new_self = $new_meta->reinitialize(
383 attribute_metaclass => $new_meta->attribute_metaclass,
384 method_metaclass => $new_meta->method_metaclass,
385 instance_metaclass => $new_meta->instance_metaclass,
388 $new_self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class );
392 bless $self, ref $new_self;
394 # We need to replace the cached metaclass instance or else when it
395 # goes out of scope Class::MOP::Class destroy's the namespace for
396 # the metaclass's class, causing much havoc.
397 Class::MOP::store_metaclass_by_name( $self->name, $self );
398 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
401 # In the more complex case, we share a common ancestor with our
402 # superclass's metaclass, but each metaclass (ours and the parent's)
403 # has a different set of roles applied. We reconcile this by first
404 # reinitializing into the parent class, and _then_ applying our own
406 sub _all_metaclasses_differ_by_roles_only {
407 my ($self, $super_meta) = @_;
410 [ ref $self, ref $super_meta ],
411 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
414 next if $pair->[0] eq $pair->[1];
416 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
417 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
420 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
422 return unless $common_ancestor;
425 unless _is_role_only_subclass_of(
429 && _is_role_only_subclass_of(
438 # This, and some other functions, could be called as methods, but
439 # they're not for two reasons. One, we just end up ignoring the first
440 # argument, because we can't call these directly on one of the real
441 # arguments, because one of them could be a Class::MOP::Class object
442 # and not a Moose::Meta::Class. Second, only a completely insane
443 # person would attempt to subclass this stuff!
444 sub _find_common_ancestor {
445 my ($meta1, $meta2) = @_;
447 # FIXME? This doesn't account for multiple inheritance (not sure
448 # if it needs to though). For example, is somewhere in $meta1's
449 # history it inherits from both ClassA and ClassB, and $meta
450 # inherits from ClassB & ClassA, does it matter? And what crazy
451 # fool would do that anyway?
453 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
455 return first { $meta1_parents{$_} } $meta2->linearized_isa;
458 sub _is_role_only_subclass_of {
459 my ($meta, $ancestor) = @_;
461 return 1 if $meta->name eq $ancestor;
463 my @roles = _all_roles_until( $meta, $ancestor );
465 my %role_packages = map { $_->name => 1 } @roles;
467 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
469 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
471 for my $method ( $meta->get_all_methods() ) {
472 next if $method->name eq 'meta';
473 next if $method->can('associated_attribute');
476 if $role_packages{ $method->original_package_name }
477 || $shared_ancestors{ $method->original_package_name };
482 # FIXME - this really isn't right. Just because an attribute is
483 # defined in a role doesn't mean it isn't _also_ defined in the
485 for my $attr ( $meta->get_all_attributes ) {
486 next if $shared_ancestors{ $attr->associated_class->name };
488 next if any { $_->has_attribute( $attr->name ) } @roles;
499 return _all_roles_until($meta);
502 sub _all_roles_until {
503 my ($meta, $stop_at_class) = @_;
505 return unless $meta->can('calculate_all_roles');
507 my @roles = $meta->calculate_all_roles;
509 for my $class ( $meta->linearized_isa ) {
510 last if $stop_at_class && $stop_at_class eq $class;
512 my $meta = Class::MOP::Class->initialize($class);
513 last unless $meta->can('calculate_all_roles');
515 push @roles, $meta->calculate_all_roles;
521 sub _reconcile_role_differences {
522 my ($self, $super_meta) = @_;
524 my $self_meta = $self->meta;
528 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
529 $roles{metaclass_roles} = \@roles;
532 for my $thing (@MetaClassTypes) {
533 my $name = $self->$thing();
535 my $thing_meta = Class::MOP::Class->initialize($name);
537 my @roles = map { $_->name } _all_roles($thing_meta)
540 $roles{ $thing . '_roles' } = \@roles;
543 $self->_reinitialize_with($super_meta);
545 Moose::Util::MetaRole::apply_metaclass_roles(
546 for_class => $self->name,
554 # this was crap anyway, see
555 # Moose::Util::apply_all_roles
557 sub _apply_all_roles {
558 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
561 sub _process_attribute {
562 my ( $self, $name, @args ) = @_;
564 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
566 if ($name =~ /^\+(.*)/) {
567 return $self->_process_inherited_attribute($1, @args);
570 return $self->_process_new_attribute($name, @args);
574 sub _process_new_attribute {
575 my ( $self, $name, @args ) = @_;
577 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
580 sub _process_inherited_attribute {
581 my ($self, $attr_name, %options) = @_;
582 my $inherited_attr = $self->find_attribute_by_name($attr_name);
583 (defined $inherited_attr)
584 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
585 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
586 return $inherited_attr->clone_and_inherit_options(%options);
590 # kind of a kludge to handle Class::MOP::Attributes
591 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
595 ## -------------------------------------------------
597 use Moose::Meta::Method::Constructor;
598 use Moose::Meta::Method::Destructor;
600 # This could be done by using SUPER and altering ->options
601 # I am keeping it this way to make it more explicit.
602 sub create_immutable_transformer {
604 my $class = Class::MOP::Immutable->new($self, {
605 read_only => [qw/superclasses/],
612 remove_package_symbol
616 class_precedence_list => 'ARRAY',
617 linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
618 get_all_methods => 'ARRAY',
619 #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
620 compute_all_applicable_attributes => 'ARRAY',
621 get_meta_instance => 'SCALAR',
622 get_method_map => 'SCALAR',
623 calculate_all_roles => 'ARRAY',
626 # this is ugly, but so are typeglobs,
627 # so whattayahgonnadoboutit
630 add_package_symbol => sub {
631 my $original = shift;
632 $self->throw_error("Cannot add package symbols to an immutable metaclass")
633 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
634 goto $original->body;
643 $self->SUPER::make_immutable
645 constructor_class => $self->constructor_class,
646 destructor_class => $self->destructor_class,
647 inline_destructor => 1,
649 # no need to do this,
650 # Moose always does it
651 inline_accessors => 0,
659 my ( $self, @args ) = @_;
660 local $error_level = ($error_level || 0) + 1;
661 $self->raise_error($self->create_error(@args));
665 my ( $self, @args ) = @_;
670 my ( $self, @args ) = @_;
674 local $error_level = ($error_level || 0 ) + 1;
676 if ( @args % 2 == 1 ) {
677 unshift @args, "message";
680 my %args = ( metaclass => $self, last_error => $@, @args );
682 $args{depth} += $error_level;
684 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
687 Carp::caller_info($args{depth}),
700 Moose::Meta::Class - The Moose metaclass
704 This is a subclass of L<Class::MOP::Class> with Moose specific
707 For the most part, the only time you will ever encounter an
708 instance of this class is if you are doing some serious deep
709 introspection. To really understand this class, you need to refer
710 to the L<Class::MOP::Class> documentation.
720 Overrides original to accept a list of roles to apply to
723 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
725 =item B<create_anon_class>
727 Overrides original to support roles and caching.
729 my $metaclass = Moose::Meta::Class->create_anon_class(
730 superclasses => ['Foo'],
731 roles => [qw/Some Roles Go Here/],
735 =item B<make_immutable>
737 Override original to add default options for inlining destructor
738 and altering the Constructor metaclass.
740 =item B<create_immutable_transformer>
742 Override original to lock C<add_role> and memoize C<calculate_all_roles>
746 We override this method to support the C<trigger> attribute option.
748 =item B<construct_instance>
750 This provides some Moose specific extensions to this method, you
751 almost never call this method directly unless you really know what
754 This method makes sure to handle the moose weak-ref, type-constraint
755 and type coercion features.
757 =item B<get_method_map>
759 This accommodates Moose::Meta::Role::Method instances, which are
760 aliased, instead of added, but still need to be counted as valid
763 =item B<add_override_method_modifier ($name, $method)>
765 This will create an C<override> method modifier for you, and install
768 =item B<add_augment_method_modifier ($name, $method)>
770 This will create an C<augment> method modifier for you, and install
773 =item B<calculate_all_roles>
777 This will return an array of C<Moose::Meta::Role> instances which are
778 attached to this class.
780 =item B<add_role ($role)>
782 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
783 to the list of associated roles.
785 =item B<does_role ($role_name)>
787 This will test if this class C<does> a given C<$role_name>. It will
788 not only check it's local roles, but ask them as well in order to
789 cascade down the role hierarchy.
791 =item B<excludes_role ($role_name)>
793 This will test if this class C<excludes> a given C<$role_name>. It will
794 not only check it's local roles, but ask them as well in order to
795 cascade down the role hierarchy.
797 =item B<add_attribute ($attr_name, %params|$params)>
799 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
800 support for taking the C<$params> as a HASH ref.
802 =item B<constructor_class ($class_name)>
804 =item B<destructor_class ($class_name)>
806 These are the names of classes used when making a class
807 immutable. These default to L<Moose::Meta::Method::Constructor> and
808 L<Moose::Meta::Method::Destructor> respectively. These accessors are
809 read-write, so you can use them to change the class name.
811 =item B<check_metaclass_compatibility>
813 Moose overrides this method from C<Class::MOP::Class> and attempts to
814 fix some incompatibilities before doing the check.
816 =item B<throw_error $message, %extra>
818 Throws the error created by C<create_error> using C<raise_error>
820 =item B<create_error $message, %extra>
822 Creates an error message or object.
824 The default behavior is C<create_error_confess>.
826 If C<error_class> is set uses C<create_error_object>. Otherwise uses
827 C<error_builder> (a code reference or variant name), and calls the appropriate
828 C<create_error_$builder> method.
830 =item B<error_builder $builder_name>
832 Get or set the error builder. Defaults to C<confess>.
834 =item B<error_class $class_name>
836 Get or set the error class. Has no default.
838 =item B<create_error_confess %args>
840 Creates an error using L<Carp/longmess>
842 =item B<create_error_croak %args>
844 Creates an error using L<Carp/shortmess>
846 =item B<create_error_object %args>
848 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
849 to support custom error objects for your meta class.
851 =item B<raise_error $error>
853 Dies with an error object or string.
859 All complex software has bugs lurking in it, and this module is no
860 exception. If you find a bug please either email me, or add the bug
865 Stevan Little E<lt>stevan@iinteractive.comE<gt>
867 =head1 COPYRIGHT AND LICENSE
869 Copyright 2006-2008 by Infinity Interactive, Inc.
871 L<http://www.iinteractive.com>
873 This library is free software; you can redistribute it and/or modify
874 it under the same terms as Perl itself.