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 = $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 return $self->_reconcile_with_superclass_meta($super);
334 sub _superclass_meta_is_compatible {
335 my ($self, $super) = @_;
337 my $super_meta = Class::MOP::Class->initialize($super)
340 next unless $super_meta->isa("Class::MOP::Class");
343 = $super_meta->is_immutable
344 ? $super_meta->get_mutable_metaclass_name
348 if $self->isa($super_meta_name)
350 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
353 # I don't want to have to type this >1 time
355 qw( attribute_metaclass method_metaclass instance_metaclass constructor_class destructor_class );
357 sub _reconcile_with_superclass_meta {
358 my ($self, $super) = @_;
360 my $super_meta = $super->meta;
363 = $super_meta->is_immutable
364 ? $super_meta->get_mutable_metaclass_name
367 my $self_metaclass = ref $self;
369 # If neither of these is true we have a more serious
370 # incompatibility that we just cannot fix (yet?).
371 if ( $super_meta_name->isa( ref $self )
372 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
373 return $self->_reinitialize_with($super_meta);
375 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
376 return $self->_reconcile_role_differences($super_meta);
382 sub _reinitialize_with {
383 my ( $self, $new_meta ) = @_;
385 $self = $new_meta->reinitialize(
387 attribute_metaclass => $new_meta->attribute_metaclass,
388 method_metaclass => $new_meta->method_metaclass,
389 instance_metaclass => $new_meta->instance_metaclass,
392 $self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class );
397 # In the more complex case, we share a common ancestor with our
398 # superclass's metaclass, but each metaclass (ours and the parent's)
399 # has a different set of roles applied. We reconcile this by first
400 # reinitializing into the parent class, and _then_ applying our own
402 sub _all_metaclasses_differ_by_roles_only {
403 my ($self, $super_meta) = @_;
406 [ ref $self, ref $super_meta ],
407 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
410 next if $pair->[0] eq $pair->[1];
412 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
413 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
416 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
418 return unless $common_ancestor;
421 unless _is_role_only_subclass_of(
425 && _is_role_only_subclass_of(
434 # This, and some other functions, could be called as methods, but
435 # they're not for two reasons. One, we just end up ignoring the first
436 # argument, because we can't call these directly on one of the real
437 # arguments, because one of them could be a Class::MOP::Class object
438 # and not a Moose::Meta::Class. Second, only a completely insane
439 # person would attempt to subclass this stuff!
440 sub _find_common_ancestor {
441 my ($meta1, $meta2) = @_;
443 # FIXME? This doesn't account for multiple inheritance (not sure
444 # if it needs to though). For example, is somewhere in $meta1's
445 # history it inherits from both ClassA and ClassB, and $meta
446 # inherits from ClassB & ClassA, does it matter? And what crazy
447 # fool would do that anyway?
449 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
451 return first { $meta1_parents{$_} } $meta2->linearized_isa;
454 sub _is_role_only_subclass_of {
455 my ($meta, $ancestor) = @_;
457 return 1 if $meta->name eq $ancestor;
459 my @roles = _all_roles_until( $meta, $ancestor );
461 my %role_packages = map { $_->name => 1 } @roles;
463 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
465 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
467 for my $method ( $meta->get_all_methods() ) {
468 next if $method->name eq 'meta';
469 next if $method->can('associated_attribute');
472 if $role_packages{ $method->original_package_name }
473 || $shared_ancestors{ $method->original_package_name };
478 # FIXME - this really isn't right. Just because an attribute is
479 # defined in a role doesn't mean it isn't _also_ defined in the
481 for my $attr ( $meta->get_all_attributes ) {
482 next if $shared_ancestors{ $attr->associated_class->name };
484 next if any { $_->has_attribute( $attr->name ) } @roles;
495 return _all_roles_until($meta);
498 sub _all_roles_until {
499 my ($meta, $stop_at_class) = @_;
501 return unless $meta->can('calculate_all_roles');
503 my @roles = $meta->calculate_all_roles;
505 for my $class ( $meta->linearized_isa ) {
506 last if $stop_at_class && $stop_at_class eq $class;
508 my $meta = Class::MOP::Class->initialize($class);
509 last unless $meta->can('calculate_all_roles');
511 push @roles, $meta->calculate_all_roles;
517 sub _reconcile_role_differences {
518 my ($self, $super_meta) = @_;
520 my $self_meta = $self->meta;
524 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
525 $roles{metaclass_roles} = \@roles;
528 for my $thing (@MetaClassTypes) {
529 my $name = $self->$thing();
531 my $thing_meta = Class::MOP::Class->initialize($name);
533 my @roles = map { $_->name } _all_roles($thing_meta)
536 $roles{ $thing . '_roles' } = \@roles;
539 $self = $self->_reinitialize_with($super_meta);
541 Moose::Util::MetaRole::apply_metaclass_roles(
542 for_class => $self->name,
550 # this was crap anyway, see
551 # Moose::Util::apply_all_roles
553 sub _apply_all_roles {
554 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
557 sub _process_attribute {
558 my ( $self, $name, @args ) = @_;
560 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
562 if ($name =~ /^\+(.*)/) {
563 return $self->_process_inherited_attribute($1, @args);
566 return $self->_process_new_attribute($name, @args);
570 sub _process_new_attribute {
571 my ( $self, $name, @args ) = @_;
573 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
576 sub _process_inherited_attribute {
577 my ($self, $attr_name, %options) = @_;
578 my $inherited_attr = $self->find_attribute_by_name($attr_name);
579 (defined $inherited_attr)
580 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
581 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
582 return $inherited_attr->clone_and_inherit_options(%options);
586 # kind of a kludge to handle Class::MOP::Attributes
587 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
591 ## -------------------------------------------------
593 use Moose::Meta::Method::Constructor;
594 use Moose::Meta::Method::Destructor;
596 # This could be done by using SUPER and altering ->options
597 # I am keeping it this way to make it more explicit.
598 sub create_immutable_transformer {
600 my $class = Class::MOP::Immutable->new($self, {
601 read_only => [qw/superclasses/],
608 remove_package_symbol
612 class_precedence_list => 'ARRAY',
613 linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
614 get_all_methods => 'ARRAY',
615 #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
616 compute_all_applicable_attributes => 'ARRAY',
617 get_meta_instance => 'SCALAR',
618 get_method_map => 'SCALAR',
619 calculate_all_roles => 'ARRAY',
622 # this is ugly, but so are typeglobs,
623 # so whattayahgonnadoboutit
626 add_package_symbol => sub {
627 my $original = shift;
628 $self->throw_error("Cannot add package symbols to an immutable metaclass")
629 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
630 goto $original->body;
639 $self->SUPER::make_immutable
641 constructor_class => $self->constructor_class,
642 destructor_class => $self->destructor_class,
643 inline_destructor => 1,
645 # no need to do this,
646 # Moose always does it
647 inline_accessors => 0,
652 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
657 my ( $self, @args ) = @_;
659 $self->raise_error($self->create_error(@args));
663 my ( $self, @args ) = @_;
668 my ( $self, @args ) = @_;
670 if ( @args % 2 == 1 ) {
671 unshift @args, "message";
674 my %args = ( meta => $self, error => $@, @args );
676 local $level = $level + 1;
678 if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
679 return $self->create_error_object( %args, class => $class );
681 my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
683 my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
685 : ( $self->can("create_error_$builder") || "create_error_confess" ));
687 return $self->$builder_method(%args);
691 sub create_error_object {
692 my ( $self, %args ) = @_;
694 my $class = delete $args{class};
698 depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
702 sub create_error_croak {
703 my ( $self, @args ) = @_;
704 $self->_create_error_carpmess( @args );
707 sub create_error_confess {
708 my ( $self, @args ) = @_;
709 $self->_create_error_carpmess( @args, longmess => 1 );
712 sub _create_error_carpmess {
713 my ( $self, %args ) = @_;
715 my $carp_level = $level + 1 + ( $args{depth} || 1 );
717 local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
718 local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
720 my @args = exists $args{message} ? $args{message} : ();
722 if ( $args{longmess} ) {
723 return Carp::longmess(@args);
725 return Carp::shortmess(@args);
737 Moose::Meta::Class - The Moose metaclass
741 This is a subclass of L<Class::MOP::Class> with Moose specific
744 For the most part, the only time you will ever encounter an
745 instance of this class is if you are doing some serious deep
746 introspection. To really understand this class, you need to refer
747 to the L<Class::MOP::Class> documentation.
757 Overrides original to accept a list of roles to apply to
760 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
762 =item B<create_anon_class>
764 Overrides original to support roles and caching.
766 my $metaclass = Moose::Meta::Class->create_anon_class(
767 superclasses => ['Foo'],
768 roles => [qw/Some Roles Go Here/],
772 =item B<make_immutable>
774 Override original to add default options for inlining destructor
775 and altering the Constructor metaclass.
777 =item B<create_immutable_transformer>
779 Override original to lock C<add_role> and memoize C<calculate_all_roles>
783 We override this method to support the C<trigger> attribute option.
785 =item B<construct_instance>
787 This provides some Moose specific extensions to this method, you
788 almost never call this method directly unless you really know what
791 This method makes sure to handle the moose weak-ref, type-constraint
792 and type coercion features.
794 =item B<get_method_map>
796 This accommodates Moose::Meta::Role::Method instances, which are
797 aliased, instead of added, but still need to be counted as valid
800 =item B<add_override_method_modifier ($name, $method)>
802 This will create an C<override> method modifier for you, and install
805 =item B<add_augment_method_modifier ($name, $method)>
807 This will create an C<augment> method modifier for you, and install
810 =item B<calculate_all_roles>
814 This will return an array of C<Moose::Meta::Role> instances which are
815 attached to this class.
817 =item B<add_role ($role)>
819 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
820 to the list of associated roles.
822 =item B<does_role ($role_name)>
824 This will test if this class C<does> a given C<$role_name>. It will
825 not only check it's local roles, but ask them as well in order to
826 cascade down the role hierarchy.
828 =item B<excludes_role ($role_name)>
830 This will test if this class C<excludes> a given C<$role_name>. It will
831 not only check it's local roles, but ask them as well in order to
832 cascade down the role hierarchy.
834 =item B<add_attribute ($attr_name, %params|$params)>
836 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
837 support for taking the C<$params> as a HASH ref.
839 =item B<constructor_class ($class_name)>
841 =item B<destructor_class ($class_name)>
843 These are the names of classes used when making a class
844 immutable. These default to L<Moose::Meta::Method::Constructor> and
845 L<Moose::Meta::Method::Destructor> respectively. These accessors are
846 read-write, so you can use them to change the class name.
848 =item B<throw_error $message, %extra>
850 Throws the error created by C<create_error> using C<raise_error>
852 =item B<create_error $message, %extra>
854 Creates an error message or object.
856 The default behavior is C<create_error_confess>.
858 If C<error_class> is set uses C<create_error_object>. Otherwise uses
859 C<error_builder> (a code reference or variant name), and calls the appropriate
860 C<create_error_$builder> method.
862 =item B<error_builder $builder_name>
864 Get or set the error builder. Defaults to C<confess>.
866 =item B<error_class $class_name>
868 Get or set the error class. Has no default.
870 =item B<create_error_confess %args>
872 Creates an error using L<Carp/longmess>
874 =item B<create_error_croak %args>
876 Creates an error using L<Carp/shortmess>
878 =item B<create_error_object %args>
880 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
881 to support custom error objects for your meta class.
883 =item B<raise_error $error>
885 Dies with an error object or string.
891 All complex software has bugs lurking in it, and this module is no
892 exception. If you find a bug please either email me, or add the bug
897 Stevan Little E<lt>stevan@iinteractive.comE<gt>
899 =head1 COPYRIGHT AND LICENSE
901 Copyright 2006-2008 by Infinity Interactive, Inc.
903 L<http://www.iinteractive.com>
905 This library is free software; you can redistribute it and/or modify
906 it under the same terms as Perl itself.