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 $super = delete $options{superclasses};
69 my $class = $self->SUPER::create($package_name, %options);
71 if ( my @super = @{ $super || [] } ) {
72 $class->_fix_metaclass_incompatibility(@super);
73 $class->superclasses(@super);
76 if (exists $options{roles}) {
77 Moose::Util::apply_all_roles($class, @{$options{roles}});
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 # FIXME? This seems to be necessary in some cases because of how
395 # Class::MOP::Class->construct_class_instance will weaken the
396 # metaclass store entry for an anonymous class. However, if that
397 # anonymous class is a metaclass's metaclass, we don't want it
398 # going out of scope. I'm not sure this is the right fix at all.
399 Class::MOP::store_metaclass_by_name( $self->name, $self );
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 = $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,
657 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
662 my ( $self, @args ) = @_;
664 $self->raise_error($self->create_error(@args));
668 my ( $self, @args ) = @_;
673 my ( $self, @args ) = @_;
675 if ( @args % 2 == 1 ) {
676 unshift @args, "message";
679 my %args = ( meta => $self, error => $@, @args );
681 local $level = $level + 1;
683 if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
684 return $self->create_error_object( %args, class => $class );
686 my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
688 my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
690 : ( $self->can("create_error_$builder") || "create_error_confess" ));
692 return $self->$builder_method(%args);
696 sub create_error_object {
697 my ( $self, %args ) = @_;
699 my $class = delete $args{class};
703 depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
707 sub create_error_croak {
708 my ( $self, @args ) = @_;
709 $self->_create_error_carpmess( @args );
712 sub create_error_confess {
713 my ( $self, @args ) = @_;
714 $self->_create_error_carpmess( @args, longmess => 1 );
717 sub _create_error_carpmess {
718 my ( $self, %args ) = @_;
720 my $carp_level = $level + 1 + ( $args{depth} || 1 );
722 local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
723 local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
725 my @args = exists $args{message} ? $args{message} : ();
727 if ( $args{longmess} ) {
728 return Carp::longmess(@args);
730 return Carp::shortmess(@args);
742 Moose::Meta::Class - The Moose metaclass
746 This is a subclass of L<Class::MOP::Class> with Moose specific
749 For the most part, the only time you will ever encounter an
750 instance of this class is if you are doing some serious deep
751 introspection. To really understand this class, you need to refer
752 to the L<Class::MOP::Class> documentation.
762 Overrides original to accept a list of roles to apply to
765 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
767 =item B<create_anon_class>
769 Overrides original to support roles and caching.
771 my $metaclass = Moose::Meta::Class->create_anon_class(
772 superclasses => ['Foo'],
773 roles => [qw/Some Roles Go Here/],
777 =item B<make_immutable>
779 Override original to add default options for inlining destructor
780 and altering the Constructor metaclass.
782 =item B<create_immutable_transformer>
784 Override original to lock C<add_role> and memoize C<calculate_all_roles>
788 We override this method to support the C<trigger> attribute option.
790 =item B<construct_instance>
792 This provides some Moose specific extensions to this method, you
793 almost never call this method directly unless you really know what
796 This method makes sure to handle the moose weak-ref, type-constraint
797 and type coercion features.
799 =item B<get_method_map>
801 This accommodates Moose::Meta::Role::Method instances, which are
802 aliased, instead of added, but still need to be counted as valid
805 =item B<add_override_method_modifier ($name, $method)>
807 This will create an C<override> method modifier for you, and install
810 =item B<add_augment_method_modifier ($name, $method)>
812 This will create an C<augment> method modifier for you, and install
815 =item B<calculate_all_roles>
819 This will return an array of C<Moose::Meta::Role> instances which are
820 attached to this class.
822 =item B<add_role ($role)>
824 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
825 to the list of associated roles.
827 =item B<does_role ($role_name)>
829 This will test if this class C<does> a given C<$role_name>. It will
830 not only check it's local roles, but ask them as well in order to
831 cascade down the role hierarchy.
833 =item B<excludes_role ($role_name)>
835 This will test if this class C<excludes> a given C<$role_name>. It will
836 not only check it's local roles, but ask them as well in order to
837 cascade down the role hierarchy.
839 =item B<add_attribute ($attr_name, %params|$params)>
841 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
842 support for taking the C<$params> as a HASH ref.
844 =item B<constructor_class ($class_name)>
846 =item B<destructor_class ($class_name)>
848 These are the names of classes used when making a class
849 immutable. These default to L<Moose::Meta::Method::Constructor> and
850 L<Moose::Meta::Method::Destructor> respectively. These accessors are
851 read-write, so you can use them to change the class name.
853 =item B<throw_error $message, %extra>
855 Throws the error created by C<create_error> using C<raise_error>
857 =item B<create_error $message, %extra>
859 Creates an error message or object.
861 The default behavior is C<create_error_confess>.
863 If C<error_class> is set uses C<create_error_object>. Otherwise uses
864 C<error_builder> (a code reference or variant name), and calls the appropriate
865 C<create_error_$builder> method.
867 =item B<error_builder $builder_name>
869 Get or set the error builder. Defaults to C<confess>.
871 =item B<error_class $class_name>
873 Get or set the error class. Has no default.
875 =item B<create_error_confess %args>
877 Creates an error using L<Carp/longmess>
879 =item B<create_error_croak %args>
881 Creates an error using L<Carp/shortmess>
883 =item B<create_error_object %args>
885 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
886 to support custom error objects for your meta class.
888 =item B<raise_error $error>
890 Dies with an error object or string.
896 All complex software has bugs lurking in it, and this module is no
897 exception. If you find a bug please either email me, or add the bug
902 Stevan Little E<lt>stevan@iinteractive.comE<gt>
904 =head1 COPYRIGHT AND LICENSE
906 Copyright 2006-2008 by Infinity Interactive, Inc.
908 L<http://www.iinteractive.com>
910 This library is free software; you can redistribute it and/or modify
911 it under the same terms as Perl itself.