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.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 => '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);
203 my $current = Class::MOP::check_package_cache_flag($self->name);
205 if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
206 return $self->{'methods'};
209 $self->{_package_cache_flag} = $current;
211 my $map = $self->{'methods'};
213 my $class_name = $self->name;
214 my $method_metaclass = $self->method_metaclass;
216 my %all_code = $self->get_all_package_symbols('CODE');
218 foreach my $symbol (keys %all_code) {
219 my $code = $all_code{$symbol};
221 next if exists $map->{$symbol} &&
222 defined $map->{$symbol} &&
223 $map->{$symbol}->body == $code;
225 my ($pkg, $name) = Class::MOP::get_code_info($code);
227 if ($pkg->can('meta')
229 # we don't know what ->meta we are calling
230 # here, so we need to be careful cause it
231 # just might blow up at us, or just complain
232 # loudly (in the case of Curses.pm) so we
233 # just be a little overly cautious here.
235 && eval { no warnings; blessed($pkg->meta) }
236 && $pkg->meta->isa('Moose::Meta::Role')) {
237 #my $role = $pkg->meta->name;
238 #next unless $self->does_role($role);
243 # in 5.10 constant.pm the constants show up
244 # as being in the right package, but in pre-5.10
245 # they show up as constant::__ANON__ so we
246 # make an exception here to be sure that things
247 # work as expected in both.
249 unless ($pkg eq 'constant' && $name eq '__ANON__') {
250 next if ($pkg || '') ne $class_name ||
251 (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
256 $map->{$symbol} = $method_metaclass->wrap(
258 package_name => $class_name,
266 ### ---------------------------------------------
270 $self->SUPER::add_attribute(
271 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
273 : $self->_process_attribute(@_))
277 sub add_override_method_modifier {
278 my ($self, $name, $method, $_super_package) = @_;
280 (!$self->has_method($name))
281 || $self->throw_error("Cannot add an override method if a local method is already present");
283 $self->add_method($name => Moose::Meta::Method::Overriden->new(
286 package => $_super_package, # need this for roles
291 sub add_augment_method_modifier {
292 my ($self, $name, $method) = @_;
293 (!$self->has_method($name))
294 || $self->throw_error("Cannot add an augment method if a local method is already present");
296 $self->add_method($name => Moose::Meta::Method::Augmented->new(
303 ## Private Utility methods ...
305 sub _find_next_method_by_name_which_is_not_overridden {
306 my ($self, $name) = @_;
307 foreach my $method ($self->find_all_methods_by_name($name)) {
308 return $method->{code}
309 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
314 sub _fix_metaclass_incompatibility {
315 my ($self, @superclasses) = @_;
317 foreach my $super (@superclasses) {
318 next if $self->_superclass_meta_is_compatible($super);
320 unless ( $self->is_pristine ) {
322 "Cannot attempt to reinitialize metaclass for "
324 . ", it isn't pristine" );
327 $self->_reconcile_with_superclass_meta($super);
331 sub _superclass_meta_is_compatible {
332 my ($self, $super) = @_;
334 my $super_meta = Class::MOP::Class->initialize($super)
337 next unless $super_meta->isa("Class::MOP::Class");
340 = $super_meta->is_immutable
341 ? $super_meta->get_mutable_metaclass_name
345 if $self->isa($super_meta_name)
347 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
350 # I don't want to have to type this >1 time
352 qw( attribute_metaclass method_metaclass instance_metaclass
353 constructor_class destructor_class error_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->$_ )
389 for qw( constructor_class destructor_class error_class );
393 bless $self, ref $new_self;
395 # We need to replace the cached metaclass instance or else when it
396 # goes out of scope Class::MOP::Class destroy's the namespace for
397 # the metaclass's class, causing much havoc.
398 Class::MOP::store_metaclass_by_name( $self->name, $self );
399 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
402 # In the more complex case, we share a common ancestor with our
403 # superclass's metaclass, but each metaclass (ours and the parent's)
404 # has a different set of roles applied. We reconcile this by first
405 # reinitializing into the parent class, and _then_ applying our own
407 sub _all_metaclasses_differ_by_roles_only {
408 my ($self, $super_meta) = @_;
411 [ ref $self, ref $super_meta ],
412 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
415 next if $pair->[0] eq $pair->[1];
417 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
418 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
421 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
423 return unless $common_ancestor;
426 unless _is_role_only_subclass_of(
430 && _is_role_only_subclass_of(
439 # This, and some other functions, could be called as methods, but
440 # they're not for two reasons. One, we just end up ignoring the first
441 # argument, because we can't call these directly on one of the real
442 # arguments, because one of them could be a Class::MOP::Class object
443 # and not a Moose::Meta::Class. Second, only a completely insane
444 # person would attempt to subclass this stuff!
445 sub _find_common_ancestor {
446 my ($meta1, $meta2) = @_;
448 # FIXME? This doesn't account for multiple inheritance (not sure
449 # if it needs to though). For example, is somewhere in $meta1's
450 # history it inherits from both ClassA and ClassB, and $meta
451 # inherits from ClassB & ClassA, does it matter? And what crazy
452 # fool would do that anyway?
454 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
456 return first { $meta1_parents{$_} } $meta2->linearized_isa;
459 sub _is_role_only_subclass_of {
460 my ($meta, $ancestor) = @_;
462 return 1 if $meta->name eq $ancestor;
464 my @roles = _all_roles_until( $meta, $ancestor );
466 my %role_packages = map { $_->name => 1 } @roles;
468 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
470 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
472 for my $method ( $meta->get_all_methods() ) {
473 next if $method->name eq 'meta';
474 next if $method->can('associated_attribute');
477 if $role_packages{ $method->original_package_name }
478 || $shared_ancestors{ $method->original_package_name };
483 # FIXME - this really isn't right. Just because an attribute is
484 # defined in a role doesn't mean it isn't _also_ defined in the
486 for my $attr ( $meta->get_all_attributes ) {
487 next if $shared_ancestors{ $attr->associated_class->name };
489 next if any { $_->has_attribute( $attr->name ) } @roles;
500 return _all_roles_until($meta);
503 sub _all_roles_until {
504 my ($meta, $stop_at_class) = @_;
506 return unless $meta->can('calculate_all_roles');
508 my @roles = $meta->calculate_all_roles;
510 for my $class ( $meta->linearized_isa ) {
511 last if $stop_at_class && $stop_at_class eq $class;
513 my $meta = Class::MOP::Class->initialize($class);
514 last unless $meta->can('calculate_all_roles');
516 push @roles, $meta->calculate_all_roles;
522 sub _reconcile_role_differences {
523 my ($self, $super_meta) = @_;
525 my $self_meta = $self->meta;
529 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
530 $roles{metaclass_roles} = \@roles;
533 for my $thing (@MetaClassTypes) {
534 my $name = $self->$thing();
536 my $thing_meta = Class::MOP::Class->initialize($name);
538 my @roles = map { $_->name } _all_roles($thing_meta)
541 $roles{ $thing . '_roles' } = \@roles;
544 $self->_reinitialize_with($super_meta);
546 Moose::Util::MetaRole::apply_metaclass_roles(
547 for_class => $self->name,
555 # this was crap anyway, see
556 # Moose::Util::apply_all_roles
558 sub _apply_all_roles {
559 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
562 sub _process_attribute {
563 my ( $self, $name, @args ) = @_;
565 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
567 if (($name || '') =~ /^\+(.*)/) {
568 return $self->_process_inherited_attribute($1, @args);
571 return $self->_process_new_attribute($name, @args);
575 sub _process_new_attribute {
576 my ( $self, $name, @args ) = @_;
578 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
581 sub _process_inherited_attribute {
582 my ($self, $attr_name, %options) = @_;
583 my $inherited_attr = $self->find_attribute_by_name($attr_name);
584 (defined $inherited_attr)
585 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
586 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
587 return $inherited_attr->clone_and_inherit_options(%options);
591 # kind of a kludge to handle Class::MOP::Attributes
592 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
596 ## -------------------------------------------------
598 use Moose::Meta::Method::Constructor;
599 use Moose::Meta::Method::Destructor;
601 # This could be done by using SUPER and altering ->options
602 # I am keeping it this way to make it more explicit.
603 sub create_immutable_transformer {
605 my $class = Class::MOP::Immutable->new($self, {
606 read_only => [qw/superclasses/],
613 remove_package_symbol
617 class_precedence_list => 'ARRAY',
618 linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
619 get_all_methods => 'ARRAY',
620 #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
621 compute_all_applicable_attributes => 'ARRAY',
622 get_meta_instance => 'SCALAR',
623 get_method_map => 'SCALAR',
624 calculate_all_roles => 'ARRAY',
627 # this is ugly, but so are typeglobs,
628 # so whattayahgonnadoboutit
631 add_package_symbol => sub {
632 my $original = shift;
633 $self->throw_error("Cannot add package symbols to an immutable metaclass")
634 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
635 goto $original->body;
644 $self->SUPER::make_immutable
646 constructor_class => $self->constructor_class,
647 destructor_class => $self->destructor_class,
648 inline_destructor => 1,
650 # no need to do this,
651 # Moose always does it
652 inline_accessors => 0,
660 my ( $self, @args ) = @_;
661 local $error_level = ($error_level || 0) + 1;
662 $self->raise_error($self->create_error(@args));
666 my ( $self, @args ) = @_;
671 my ( $self, @args ) = @_;
675 local $error_level = ($error_level || 0 ) + 1;
677 if ( @args % 2 == 1 ) {
678 unshift @args, "message";
681 my %args = ( metaclass => $self, last_error => $@, @args );
683 $args{depth} += $error_level;
685 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
687 Class::MOP::load_class($class);
690 Carp::caller_info($args{depth}),
703 Moose::Meta::Class - The Moose metaclass
707 This is a subclass of L<Class::MOP::Class> with Moose specific
710 For the most part, the only time you will ever encounter an
711 instance of this class is if you are doing some serious deep
712 introspection. To really understand this class, you need to refer
713 to the L<Class::MOP::Class> documentation.
723 Overrides original to accept a list of roles to apply to
726 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
728 =item B<create_anon_class>
730 Overrides original to support roles and caching.
732 my $metaclass = Moose::Meta::Class->create_anon_class(
733 superclasses => ['Foo'],
734 roles => [qw/Some Roles Go Here/],
738 =item B<make_immutable>
740 Override original to add default options for inlining destructor
741 and altering the Constructor metaclass.
743 =item B<create_immutable_transformer>
745 Override original to lock C<add_role> and memoize C<calculate_all_roles>
749 We override this method to support the C<trigger> attribute option.
751 =item B<construct_instance>
753 This provides some Moose specific extensions to this method, you
754 almost never call this method directly unless you really know what
757 This method makes sure to handle the moose weak-ref, type-constraint
758 and type coercion features.
760 =item B<get_method_map>
762 This accommodates Moose::Meta::Role::Method instances, which are
763 aliased, instead of added, but still need to be counted as valid
766 =item B<add_override_method_modifier ($name, $method)>
768 This will create an C<override> method modifier for you, and install
771 =item B<add_augment_method_modifier ($name, $method)>
773 This will create an C<augment> method modifier for you, and install
776 =item B<calculate_all_roles>
780 This will return an array of C<Moose::Meta::Role> instances which are
781 attached to this class.
783 =item B<add_role ($role)>
785 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
786 to the list of associated roles.
788 =item B<does_role ($role_name)>
790 This will test if this class C<does> a given C<$role_name>. It will
791 not only check it's local roles, but ask them as well in order to
792 cascade down the role hierarchy.
794 =item B<excludes_role ($role_name)>
796 This will test if this class C<excludes> a given C<$role_name>. It will
797 not only check it's local roles, but ask them as well in order to
798 cascade down the role hierarchy.
800 =item B<add_attribute ($attr_name, %params|$params)>
802 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
803 support for taking the C<$params> as a HASH ref.
805 =item B<constructor_class ($class_name)>
807 =item B<destructor_class ($class_name)>
809 These are the names of classes used when making a class
810 immutable. These default to L<Moose::Meta::Method::Constructor> and
811 L<Moose::Meta::Method::Destructor> respectively. These accessors are
812 read-write, so you can use them to change the class name.
814 =item B<error_class ($class_name)>
816 The name of the class used to throw errors. This default to
817 L<Moose::Error::Default>, which generates an error with a stacktrace
818 just like C<Carp::confess>.
820 =item B<check_metaclass_compatibility>
822 Moose overrides this method from C<Class::MOP::Class> and attempts to
823 fix some incompatibilities before doing the check.
825 =item B<throw_error $message, %extra>
827 Throws the error created by C<create_error> using C<raise_error>
829 =item B<create_error $message, %extra>
831 Creates an error message or object.
833 The default behavior is C<create_error_confess>.
835 If C<error_class> is set uses C<create_error_object>. Otherwise uses
836 C<error_builder> (a code reference or variant name), and calls the appropriate
837 C<create_error_$builder> method.
839 =item B<error_builder $builder_name>
841 Get or set the error builder. Defaults to C<confess>.
843 =item B<error_class $class_name>
845 Get or set the error class. Has no default.
847 =item B<create_error_confess %args>
849 Creates an error using L<Carp/longmess>
851 =item B<create_error_croak %args>
853 Creates an error using L<Carp/shortmess>
855 =item B<create_error_object %args>
857 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
858 to support custom error objects for your meta class.
860 =item B<raise_error $error>
862 Dies with an error object or string.
868 All complex software has bugs lurking in it, and this module is no
869 exception. If you find a bug please either email me, or add the bug
874 Stevan Little E<lt>stevan@iinteractive.comE<gt>
876 =head1 COPYRIGHT AND LICENSE
878 Copyright 2006-2008 by Infinity Interactive, Inc.
880 L<http://www.iinteractive.com>
882 This library is free software; you can redistribute it and/or modify
883 it under the same terms as Perl itself.