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;
21 use base 'Class::MOP::Class';
23 __PACKAGE__->meta->add_attribute('roles' => (
28 __PACKAGE__->meta->add_attribute('constructor_class' => (
29 accessor => 'constructor_class',
30 default => sub { 'Moose::Meta::Method::Constructor' }
33 __PACKAGE__->meta->add_attribute('destructor_class' => (
34 accessor => 'destructor_class',
35 default => sub { 'Moose::Meta::Method::Destructor' }
38 __PACKAGE__->meta->add_attribute('error_builder' => (
39 reader => 'error_builder',
43 __PACKAGE__->meta->add_attribute('error_class' => (
44 reader => 'error_class',
51 return Class::MOP::get_metaclass_by_name($pkg)
52 || $class->SUPER::initialize($pkg,
53 'attribute_metaclass' => 'Moose::Meta::Attribute',
54 'method_metaclass' => 'Moose::Meta::Method',
55 'instance_metaclass' => 'Moose::Meta::Instance',
61 my ($self, $package_name, %options) = @_;
63 (ref $options{roles} eq 'ARRAY')
64 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
65 if exists $options{roles};
67 my $class = $self->SUPER::create($package_name, %options);
69 if (exists $options{roles}) {
70 Moose::Util::apply_all_roles($class, @{$options{roles}});
76 sub check_metaclass_compatibility {
79 if ( my @supers = $self->superclasses ) {
80 $self->_fix_metaclass_incompatibility(@supers);
83 $self->SUPER::check_metaclass_compatibility(@_);
88 sub create_anon_class {
89 my ($self, %options) = @_;
91 my $cache_ok = delete $options{cache};
93 # something like Super::Class|Super::Class::2=Role|Role::1
94 my $cache_key = join '=' => (
95 join('|', sort @{$options{superclasses} || []}),
96 join('|', sort @{$options{roles} || []}),
99 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
100 return $ANON_CLASSES{$cache_key};
103 my $new_class = $self->SUPER::create_anon_class(%options);
105 $ANON_CLASSES{$cache_key} = $new_class
112 my ($self, $role) = @_;
113 (blessed($role) && $role->isa('Moose::Meta::Role'))
114 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
115 push @{$self->roles} => $role;
118 sub calculate_all_roles {
121 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
125 my ($self, $role_name) = @_;
127 || $self->throw_error("You must supply a role name to look for");
128 foreach my $class ($self->class_precedence_list) {
129 next unless $class->can('meta') && $class->meta->can('roles');
130 foreach my $role (@{$class->meta->roles}) {
131 return 1 if $role->does_role($role_name);
138 my ($self, $role_name) = @_;
140 || $self->throw_error("You must supply a role name to look for");
141 foreach my $class ($self->class_precedence_list) {
142 next unless $class->can('meta');
144 # in the pretty rare instance when a Moose metaclass
145 # is itself extended with a role, this check needs to
146 # be done since some items in the class_precedence_list
147 # might in fact be Class::MOP based still.
148 next unless $class->meta->can('roles');
149 foreach my $role (@{$class->meta->roles}) {
150 return 1 if $role->excludes_role($role_name);
158 my $params = @_ == 1 ? $_[0] : {@_};
159 my $self = $class->SUPER::new_object($params);
160 foreach my $attr ($class->compute_all_applicable_attributes()) {
161 # if we have a trigger, then ...
162 if ($attr->can('has_trigger') && $attr->has_trigger) {
163 # make sure we have an init-arg ...
164 if (defined(my $init_arg = $attr->init_arg)) {
165 # now make sure an init-arg was passes ...
166 if (exists $params->{$init_arg}) {
167 # and if get here, fire the trigger
170 # check if there is a coercion
171 ($attr->should_coerce
172 # and if so, we need to grab the
173 # value that is actually been stored
174 ? $attr->get_read_method_ref->($self)
175 # otherwise, just get the value from
176 # the constructor params
177 : $params->{$init_arg}),
187 sub construct_instance {
189 my $params = @_ == 1 ? $_[0] : {@_};
190 my $meta_instance = $class->get_meta_instance;
192 # the code below is almost certainly incorrect
193 # but this is foreign inheritence, so we might
194 # have to kludge it in the end.
195 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
196 foreach my $attr ($class->compute_all_applicable_attributes()) {
197 $attr->initialize_instance_slot($meta_instance, $instance, $params);
207 my $current = Class::MOP::check_package_cache_flag($self->name);
209 if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
210 return $self->{'methods'};
213 $self->{_package_cache_flag} = $current;
215 my $map = $self->{'methods'};
217 my $class_name = $self->name;
218 my $method_metaclass = $self->method_metaclass;
220 my %all_code = $self->get_all_package_symbols('CODE');
222 foreach my $symbol (keys %all_code) {
223 my $code = $all_code{$symbol};
225 next if exists $map->{$symbol} &&
226 defined $map->{$symbol} &&
227 $map->{$symbol}->body == $code;
229 my ($pkg, $name) = Class::MOP::get_code_info($code);
231 if ($pkg->can('meta')
233 # we don't know what ->meta we are calling
234 # here, so we need to be careful cause it
235 # just might blow up at us, or just complain
236 # loudly (in the case of Curses.pm) so we
237 # just be a little overly cautious here.
239 && eval { no warnings; blessed($pkg->meta) }
240 && $pkg->meta->isa('Moose::Meta::Role')) {
241 #my $role = $pkg->meta->name;
242 #next unless $self->does_role($role);
247 # in 5.10 constant.pm the constants show up
248 # as being in the right package, but in pre-5.10
249 # they show up as constant::__ANON__ so we
250 # make an exception here to be sure that things
251 # work as expected in both.
253 unless ($pkg eq 'constant' && $name eq '__ANON__') {
254 next if ($pkg || '') ne $class_name ||
255 (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
260 $map->{$symbol} = $method_metaclass->wrap(
262 package_name => $class_name,
270 ### ---------------------------------------------
274 $self->SUPER::add_attribute(
275 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
277 : $self->_process_attribute(@_))
281 sub add_override_method_modifier {
282 my ($self, $name, $method, $_super_package) = @_;
284 (!$self->has_method($name))
285 || $self->throw_error("Cannot add an override method if a local method is already present");
287 $self->add_method($name => Moose::Meta::Method::Overriden->new(
290 package => $_super_package, # need this for roles
295 sub add_augment_method_modifier {
296 my ($self, $name, $method) = @_;
297 (!$self->has_method($name))
298 || $self->throw_error("Cannot add an augment method if a local method is already present");
300 $self->add_method($name => Moose::Meta::Method::Augmented->new(
307 ## Private Utility methods ...
309 sub _find_next_method_by_name_which_is_not_overridden {
310 my ($self, $name) = @_;
311 foreach my $method ($self->find_all_methods_by_name($name)) {
312 return $method->{code}
313 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
318 sub _fix_metaclass_incompatibility {
319 my ($self, @superclasses) = @_;
321 foreach my $super (@superclasses) {
322 next if $self->_superclass_meta_is_compatible($super);
324 unless ( $self->is_pristine ) {
326 "Cannot attempt to reinitialize metaclass for "
328 . ", it isn't pristine" );
331 $self->_reconcile_with_superclass_meta($super);
335 sub _superclass_meta_is_compatible {
336 my ($self, $super) = @_;
338 my $super_meta = Class::MOP::Class->initialize($super)
341 next unless $super_meta->isa("Class::MOP::Class");
344 = $super_meta->is_immutable
345 ? $super_meta->get_mutable_metaclass_name
349 if $self->isa($super_meta_name)
351 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
354 # I don't want to have to type this >1 time
356 qw( attribute_metaclass method_metaclass instance_metaclass constructor_class destructor_class );
358 sub _reconcile_with_superclass_meta {
359 my ($self, $super) = @_;
361 my $super_meta = $super->meta;
364 = $super_meta->is_immutable
365 ? $super_meta->get_mutable_metaclass_name
368 my $self_metaclass = ref $self;
370 # If neither of these is true we have a more serious
371 # incompatibility that we just cannot fix (yet?).
372 if ( $super_meta_name->isa( ref $self )
373 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
374 $self->_reinitialize_with($super_meta);
376 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
377 $self->_reconcile_role_differences($super_meta);
381 sub _reinitialize_with {
382 my ( $self, $new_meta ) = @_;
384 my $new_self = $new_meta->reinitialize(
386 attribute_metaclass => $new_meta->attribute_metaclass,
387 method_metaclass => $new_meta->method_metaclass,
388 instance_metaclass => $new_meta->instance_metaclass,
391 $new_self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class );
395 bless $self, ref $new_self;
397 # We need to replace the cached metaclass instance or else when it
398 # goes out of scope Class::MOP::Class destroy's the namespace for
399 # the metaclass's class, causing much havoc.
400 Class::MOP::store_metaclass_by_name( $self->name, $self );
401 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
404 # In the more complex case, we share a common ancestor with our
405 # superclass's metaclass, but each metaclass (ours and the parent's)
406 # has a different set of roles applied. We reconcile this by first
407 # reinitializing into the parent class, and _then_ applying our own
409 sub _all_metaclasses_differ_by_roles_only {
410 my ($self, $super_meta) = @_;
413 [ ref $self, ref $super_meta ],
414 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
417 next if $pair->[0] eq $pair->[1];
419 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
420 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
423 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
425 return unless $common_ancestor;
428 unless _is_role_only_subclass_of(
432 && _is_role_only_subclass_of(
441 # This, and some other functions, could be called as methods, but
442 # they're not for two reasons. One, we just end up ignoring the first
443 # argument, because we can't call these directly on one of the real
444 # arguments, because one of them could be a Class::MOP::Class object
445 # and not a Moose::Meta::Class. Second, only a completely insane
446 # person would attempt to subclass this stuff!
447 sub _find_common_ancestor {
448 my ($meta1, $meta2) = @_;
450 # FIXME? This doesn't account for multiple inheritance (not sure
451 # if it needs to though). For example, is somewhere in $meta1's
452 # history it inherits from both ClassA and ClassB, and $meta
453 # inherits from ClassB & ClassA, does it matter? And what crazy
454 # fool would do that anyway?
456 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
458 return first { $meta1_parents{$_} } $meta2->linearized_isa;
461 sub _is_role_only_subclass_of {
462 my ($meta, $ancestor) = @_;
464 return 1 if $meta->name eq $ancestor;
466 my @roles = _all_roles_until( $meta, $ancestor );
468 my %role_packages = map { $_->name => 1 } @roles;
470 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
472 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
474 for my $method ( $meta->get_all_methods() ) {
475 next if $method->name eq 'meta';
476 next if $method->can('associated_attribute');
479 if $role_packages{ $method->original_package_name }
480 || $shared_ancestors{ $method->original_package_name };
485 # FIXME - this really isn't right. Just because an attribute is
486 # defined in a role doesn't mean it isn't _also_ defined in the
488 for my $attr ( $meta->get_all_attributes ) {
489 next if $shared_ancestors{ $attr->associated_class->name };
491 next if any { $_->has_attribute( $attr->name ) } @roles;
502 return _all_roles_until($meta);
505 sub _all_roles_until {
506 my ($meta, $stop_at_class) = @_;
508 return unless $meta->can('calculate_all_roles');
510 my @roles = $meta->calculate_all_roles;
512 for my $class ( $meta->linearized_isa ) {
513 last if $stop_at_class && $stop_at_class eq $class;
515 my $meta = Class::MOP::Class->initialize($class);
516 last unless $meta->can('calculate_all_roles');
518 push @roles, $meta->calculate_all_roles;
524 sub _reconcile_role_differences {
525 my ($self, $super_meta) = @_;
527 my $self_meta = $self->meta;
531 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
532 $roles{metaclass_roles} = \@roles;
535 for my $thing (@MetaClassTypes) {
536 my $name = $self->$thing();
538 my $thing_meta = Class::MOP::Class->initialize($name);
540 my @roles = map { $_->name } _all_roles($thing_meta)
543 $roles{ $thing . '_roles' } = \@roles;
546 $self->_reinitialize_with($super_meta);
548 Moose::Util::MetaRole::apply_metaclass_roles(
549 for_class => $self->name,
557 # this was crap anyway, see
558 # Moose::Util::apply_all_roles
560 sub _apply_all_roles {
561 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
564 sub _process_attribute {
565 my ( $self, $name, @args ) = @_;
567 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
569 if ($name =~ /^\+(.*)/) {
570 return $self->_process_inherited_attribute($1, @args);
573 return $self->_process_new_attribute($name, @args);
577 sub _process_new_attribute {
578 my ( $self, $name, @args ) = @_;
580 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
583 sub _process_inherited_attribute {
584 my ($self, $attr_name, %options) = @_;
585 my $inherited_attr = $self->find_attribute_by_name($attr_name);
586 (defined $inherited_attr)
587 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
588 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
589 return $inherited_attr->clone_and_inherit_options(%options);
593 # kind of a kludge to handle Class::MOP::Attributes
594 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
598 ## -------------------------------------------------
600 use Moose::Meta::Method::Constructor;
601 use Moose::Meta::Method::Destructor;
603 # This could be done by using SUPER and altering ->options
604 # I am keeping it this way to make it more explicit.
605 sub create_immutable_transformer {
607 my $class = Class::MOP::Immutable->new($self, {
608 read_only => [qw/superclasses/],
615 remove_package_symbol
619 class_precedence_list => 'ARRAY',
620 linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
621 get_all_methods => 'ARRAY',
622 #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
623 compute_all_applicable_attributes => 'ARRAY',
624 get_meta_instance => 'SCALAR',
625 get_method_map => 'SCALAR',
626 calculate_all_roles => 'ARRAY',
629 # this is ugly, but so are typeglobs,
630 # so whattayahgonnadoboutit
633 add_package_symbol => sub {
634 my $original = shift;
635 $self->throw_error("Cannot add package symbols to an immutable metaclass")
636 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
637 goto $original->body;
646 $self->SUPER::make_immutable
648 constructor_class => $self->constructor_class,
649 destructor_class => $self->destructor_class,
650 inline_destructor => 1,
652 # no need to do this,
653 # Moose always does it
654 inline_accessors => 0,
659 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
664 my ( $self, @args ) = @_;
666 $self->raise_error($self->create_error(@args));
670 my ( $self, @args ) = @_;
675 my ( $self, @args ) = @_;
679 local $level = $level + 1;
682 if ( @args % 2 == 1 ) {
683 unshift @args, "message";
686 my %args = ( Carp::caller_info($level), metaclass => $self, error => $@, @args );
688 if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
689 return $self->create_error_object( %args, class => $class );
691 my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
693 my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
695 : ( $self->can("create_error_$builder") || "create_error_confess" ));
697 return $self->$builder_method(%args);
701 sub create_error_object {
702 my ( $self, %args ) = @_;
704 my $class = delete $args{class};
708 depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
712 sub create_error_croak {
713 my ( $self, @args ) = @_;
714 $self->_create_error_carpmess( @args );
717 sub create_error_confess {
718 my ( $self, @args ) = @_;
719 $self->_create_error_carpmess( @args, longmess => 1 );
722 sub _create_error_carpmess {
723 my ( $self, %args ) = @_;
725 my $carp_level = $level + 1 + ( $args{depth} || 1 );
726 local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
728 my @args = exists $args{message} ? $args{message} : ();
730 if ( $args{longmess} || $Carp::Verbose ) {
731 local $Carp::CarpLevel = ( $Carp::CarpLevel || 0 ) + $carp_level;
732 return Carp::longmess(@args);
734 return Carp::ret_summary($carp_level, @args);
746 Moose::Meta::Class - The Moose metaclass
750 This is a subclass of L<Class::MOP::Class> with Moose specific
753 For the most part, the only time you will ever encounter an
754 instance of this class is if you are doing some serious deep
755 introspection. To really understand this class, you need to refer
756 to the L<Class::MOP::Class> documentation.
766 Overrides original to accept a list of roles to apply to
769 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
771 =item B<create_anon_class>
773 Overrides original to support roles and caching.
775 my $metaclass = Moose::Meta::Class->create_anon_class(
776 superclasses => ['Foo'],
777 roles => [qw/Some Roles Go Here/],
781 =item B<make_immutable>
783 Override original to add default options for inlining destructor
784 and altering the Constructor metaclass.
786 =item B<create_immutable_transformer>
788 Override original to lock C<add_role> and memoize C<calculate_all_roles>
792 We override this method to support the C<trigger> attribute option.
794 =item B<construct_instance>
796 This provides some Moose specific extensions to this method, you
797 almost never call this method directly unless you really know what
800 This method makes sure to handle the moose weak-ref, type-constraint
801 and type coercion features.
803 =item B<get_method_map>
805 This accommodates Moose::Meta::Role::Method instances, which are
806 aliased, instead of added, but still need to be counted as valid
809 =item B<add_override_method_modifier ($name, $method)>
811 This will create an C<override> method modifier for you, and install
814 =item B<add_augment_method_modifier ($name, $method)>
816 This will create an C<augment> method modifier for you, and install
819 =item B<calculate_all_roles>
823 This will return an array of C<Moose::Meta::Role> instances which are
824 attached to this class.
826 =item B<add_role ($role)>
828 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
829 to the list of associated roles.
831 =item B<does_role ($role_name)>
833 This will test if this class C<does> a given C<$role_name>. It will
834 not only check it's local roles, but ask them as well in order to
835 cascade down the role hierarchy.
837 =item B<excludes_role ($role_name)>
839 This will test if this class C<excludes> a given C<$role_name>. It will
840 not only check it's local roles, but ask them as well in order to
841 cascade down the role hierarchy.
843 =item B<add_attribute ($attr_name, %params|$params)>
845 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
846 support for taking the C<$params> as a HASH ref.
848 =item B<constructor_class ($class_name)>
850 =item B<destructor_class ($class_name)>
852 These are the names of classes used when making a class
853 immutable. These default to L<Moose::Meta::Method::Constructor> and
854 L<Moose::Meta::Method::Destructor> respectively. These accessors are
855 read-write, so you can use them to change the class name.
857 =item B<check_metaclass_compatibility>
859 Moose overrides this method from C<Class::MOP::Class> and attempts to
860 fix some incompatibilities before doing the check.
862 =item B<throw_error $message, %extra>
864 Throws the error created by C<create_error> using C<raise_error>
866 =item B<create_error $message, %extra>
868 Creates an error message or object.
870 The default behavior is C<create_error_confess>.
872 If C<error_class> is set uses C<create_error_object>. Otherwise uses
873 C<error_builder> (a code reference or variant name), and calls the appropriate
874 C<create_error_$builder> method.
876 =item B<error_builder $builder_name>
878 Get or set the error builder. Defaults to C<confess>.
880 =item B<error_class $class_name>
882 Get or set the error class. Has no default.
884 =item B<create_error_confess %args>
886 Creates an error using L<Carp/longmess>
888 =item B<create_error_croak %args>
890 Creates an error using L<Carp/shortmess>
892 =item B<create_error_object %args>
894 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
895 to support custom error objects for your meta class.
897 =item B<raise_error $error>
899 Dies with an error object or string.
905 All complex software has bugs lurking in it, and this module is no
906 exception. If you find a bug please either email me, or add the bug
911 Stevan Little E<lt>stevan@iinteractive.comE<gt>
913 =head1 COPYRIGHT AND LICENSE
915 Copyright 2006-2008 by Infinity Interactive, Inc.
917 L<http://www.iinteractive.com>
919 This library is free software; you can redistribute it and/or modify
920 it under the same terms as Perl itself.