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}});
78 sub create_anon_class {
79 my ($self, %options) = @_;
81 my $cache_ok = delete $options{cache};
83 # something like Super::Class|Super::Class::2=Role|Role::1
84 my $cache_key = join '=' => (
85 join('|', sort @{$options{superclasses} || []}),
86 join('|', sort @{$options{roles} || []}),
89 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
90 return $ANON_CLASSES{$cache_key};
93 my $new_class = $self->SUPER::create_anon_class(%options);
95 $ANON_CLASSES{$cache_key} = $new_class
102 my ($self, $role) = @_;
103 (blessed($role) && $role->isa('Moose::Meta::Role'))
104 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
105 push @{$self->roles} => $role;
108 sub calculate_all_roles {
111 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
115 my ($self, $role_name) = @_;
117 || $self->throw_error("You must supply a role name to look for");
118 foreach my $class ($self->class_precedence_list) {
119 next unless $class->can('meta') && $class->meta->can('roles');
120 foreach my $role (@{$class->meta->roles}) {
121 return 1 if $role->does_role($role_name);
128 my ($self, $role_name) = @_;
130 || $self->throw_error("You must supply a role name to look for");
131 foreach my $class ($self->class_precedence_list) {
132 next unless $class->can('meta');
134 # in the pretty rare instance when a Moose metaclass
135 # is itself extended with a role, this check needs to
136 # be done since some items in the class_precedence_list
137 # might in fact be Class::MOP based still.
138 next unless $class->meta->can('roles');
139 foreach my $role (@{$class->meta->roles}) {
140 return 1 if $role->excludes_role($role_name);
148 my $params = @_ == 1 ? $_[0] : {@_};
149 my $self = $class->SUPER::new_object($params);
150 foreach my $attr ($class->compute_all_applicable_attributes()) {
151 # if we have a trigger, then ...
152 if ($attr->can('has_trigger') && $attr->has_trigger) {
153 # make sure we have an init-arg ...
154 if (defined(my $init_arg = $attr->init_arg)) {
155 # now make sure an init-arg was passes ...
156 if (exists $params->{$init_arg}) {
157 # and if get here, fire the trigger
160 # check if there is a coercion
161 ($attr->should_coerce
162 # and if so, we need to grab the
163 # value that is actually been stored
164 ? $attr->get_read_method_ref->($self)
165 # otherwise, just get the value from
166 # the constructor params
167 : $params->{$init_arg}),
177 sub construct_instance {
179 my $params = @_ == 1 ? $_[0] : {@_};
180 my $meta_instance = $class->get_meta_instance;
182 # the code below is almost certainly incorrect
183 # but this is foreign inheritence, so we might
184 # have to kludge it in the end.
185 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
186 foreach my $attr ($class->compute_all_applicable_attributes()) {
187 $attr->initialize_instance_slot($meta_instance, $instance, $params);
197 my $current = Class::MOP::check_package_cache_flag($self->name);
199 if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
200 return $self->{'methods'};
203 $self->{_package_cache_flag} = $current;
205 my $map = $self->{'methods'};
207 my $class_name = $self->name;
208 my $method_metaclass = $self->method_metaclass;
210 my %all_code = $self->get_all_package_symbols('CODE');
212 foreach my $symbol (keys %all_code) {
213 my $code = $all_code{$symbol};
215 next if exists $map->{$symbol} &&
216 defined $map->{$symbol} &&
217 $map->{$symbol}->body == $code;
219 my ($pkg, $name) = Class::MOP::get_code_info($code);
221 if ($pkg->can('meta')
223 # we don't know what ->meta we are calling
224 # here, so we need to be careful cause it
225 # just might blow up at us, or just complain
226 # loudly (in the case of Curses.pm) so we
227 # just be a little overly cautious here.
229 && eval { no warnings; blessed($pkg->meta) }
230 && $pkg->meta->isa('Moose::Meta::Role')) {
231 #my $role = $pkg->meta->name;
232 #next unless $self->does_role($role);
237 # in 5.10 constant.pm the constants show up
238 # as being in the right package, but in pre-5.10
239 # they show up as constant::__ANON__ so we
240 # make an exception here to be sure that things
241 # work as expected in both.
243 unless ($pkg eq 'constant' && $name eq '__ANON__') {
244 next if ($pkg || '') ne $class_name ||
245 (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
250 $map->{$symbol} = $method_metaclass->wrap(
252 package_name => $class_name,
260 ### ---------------------------------------------
264 $self->SUPER::add_attribute(
265 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
267 : $self->_process_attribute(@_))
271 sub add_override_method_modifier {
272 my ($self, $name, $method, $_super_package) = @_;
274 (!$self->has_method($name))
275 || $self->throw_error("Cannot add an override method if a local method is already present");
277 $self->add_method($name => Moose::Meta::Method::Overriden->new(
280 package => $_super_package, # need this for roles
285 sub add_augment_method_modifier {
286 my ($self, $name, $method) = @_;
287 (!$self->has_method($name))
288 || $self->throw_error("Cannot add an augment method if a local method is already present");
290 $self->add_method($name => Moose::Meta::Method::Augmented->new(
297 ## Private Utility methods ...
299 sub _find_next_method_by_name_which_is_not_overridden {
300 my ($self, $name) = @_;
301 foreach my $method ($self->find_all_methods_by_name($name)) {
302 return $method->{code}
303 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
308 sub _fix_metaclass_incompatability {
309 my ($self, @superclasses) = @_;
311 foreach my $super (@superclasses) {
312 next if $self->_superclass_meta_is_compatible($super);
314 unless ( $self->is_pristine ) {
316 "Cannot attempt to reinitialize metaclass for "
318 . ", it isn't pristine" );
321 return $self->_reconcile_with_superclass_meta($super);
327 sub _superclass_meta_is_compatible {
328 my ($self, $super) = @_;
330 my $super_meta = Class::MOP::Class->initialize($super)
333 next unless $super_meta->isa("Class::MOP::Class");
336 = $super_meta->is_immutable
337 ? $super_meta->get_mutable_metaclass_name
341 if $self->isa($super_meta_name)
343 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
346 # I don't want to have to type this >1 time
348 qw( attribute_metaclass method_metaclass instance_metaclass constructor_class destructor_class );
350 sub _reconcile_with_superclass_meta {
351 my ($self, $super) = @_;
353 my $super_meta = $super->meta;
355 my $super_metaclass_name
356 = $super_meta->is_immutable
357 ? $super_meta->get_mutable_metaclass_name
360 my $self_metaclass = ref $self;
362 # If neither of these is true we have a more serious
363 # incompatibility that we just cannot fix (yet?).
364 if ( $super_metaclass_name->isa( ref $self )
365 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
366 return $self->_reinitialize_with($super_meta);
368 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
369 return $self->_reconcile_role_differences($super_meta);
375 sub _reinitialize_with {
376 my ( $self, $new_meta ) = @_;
378 $self = $new_meta->reinitialize(
380 attribute_metaclass => $new_meta->attribute_metaclass,
381 method_metaclass => $new_meta->method_metaclass,
382 instance_metaclass => $new_meta->instance_metaclass,
385 $self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class );
390 # In the more complex case, we share a common ancestor with our
391 # superclass's metaclass, but each metaclass (ours and the parent's)
392 # has a different set of roles applied. We reconcile this by first
393 # reinitializing into the parent class, and _then_ applying our own
395 sub _all_metaclasses_differ_by_roles_only {
396 my ($self, $super_meta) = @_;
399 [ ref $self, ref $super_meta ],
400 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
403 next if $pair->[0] eq $pair->[1];
405 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
406 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
409 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
411 return unless $common_ancestor;
414 unless _is_role_only_subclass_of(
418 && _is_role_only_subclass_of(
427 # This, and some other functions, could be called as methods, but
428 # they're not for two reasons. One, we just end up ignoring the first
429 # argument, because we can't call these directly on one of the real
430 # arguments, because one of them could be a Class::MOP::Class object
431 # and not a Moose::Meta::Class. Second, only a completely insane
432 # person would attempt to subclass this stuff!
433 sub _find_common_ancestor {
434 my ($meta1, $meta2) = @_;
436 # FIXME? This doesn't account for multiple inheritance (not sure
437 # if it needs to though). For example, is somewhere in $meta1's
438 # history it inherits from both ClassA and ClassB, and $meta
439 # inherits from ClassB & ClassA, does it matter? And what crazy
440 # fool would do that anyway?
442 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
444 return first { $meta1_parents{$_} } $meta2->linearized_isa;
447 sub _is_role_only_subclass_of {
448 my ($meta, $ancestor) = @_;
450 return 1 if $meta->name eq $ancestor;
452 my @roles = _all_roles_until( $meta, $ancestor );
454 my %role_packages = map { $_->name => 1 } @roles;
456 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
458 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
460 for my $method ( $meta->get_all_methods() ) {
461 next if $method->name eq 'meta';
462 next if $method->can('associated_attribute');
465 if $role_packages{ $method->original_package_name }
466 || $shared_ancestors{ $method->original_package_name };
471 # FIXME - this really isn't right. Just because an attribute is
472 # defined in a role doesn't mean it isn't _also_ defined in the
474 for my $attr ( $meta->get_all_attributes ) {
475 next if $shared_ancestors{ $attr->associated_class->name };
477 next if any { $_->has_attribute( $attr->name ) } @roles;
488 return _all_roles_until($meta);
491 sub _all_roles_until {
492 my ($meta, $stop_at_class) = @_;
494 return unless $meta->can('calculate_all_roles');
496 my @roles = $meta->calculate_all_roles;
498 for my $class ( $meta->linearized_isa ) {
499 last if $stop_at_class && $stop_at_class eq $class;
501 my $meta = Class::MOP::Class->initialize($class);
502 last unless $meta->can('calculate_all_roles');
504 push @roles, $meta->calculate_all_roles;
510 sub _reconcile_role_differences {
511 my ($self, $super_meta) = @_;
513 my $self_meta = $self->meta;
517 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
518 $roles{metaclass_roles} = \@roles;
521 for my $thing (@MetaClassTypes) {
522 my $name = $self->$thing();
524 my $thing_meta = Class::MOP::Class->initialize($name);
526 my @roles = map { $_->name } _all_roles($thing_meta)
529 $roles{ $thing . '_roles' } = \@roles;
532 $self = $self->_reinitialize_with($super_meta);
534 Moose::Util::MetaRole::apply_metaclass_roles(
535 for_class => $self->name,
543 # this was crap anyway, see
544 # Moose::Util::apply_all_roles
546 sub _apply_all_roles {
547 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
550 sub _process_attribute {
551 my ( $self, $name, @args ) = @_;
553 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
555 if ($name =~ /^\+(.*)/) {
556 return $self->_process_inherited_attribute($1, @args);
559 return $self->_process_new_attribute($name, @args);
563 sub _process_new_attribute {
564 my ( $self, $name, @args ) = @_;
566 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
569 sub _process_inherited_attribute {
570 my ($self, $attr_name, %options) = @_;
571 my $inherited_attr = $self->find_attribute_by_name($attr_name);
572 (defined $inherited_attr)
573 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
574 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
575 return $inherited_attr->clone_and_inherit_options(%options);
579 # kind of a kludge to handle Class::MOP::Attributes
580 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
584 ## -------------------------------------------------
586 use Moose::Meta::Method::Constructor;
587 use Moose::Meta::Method::Destructor;
589 # This could be done by using SUPER and altering ->options
590 # I am keeping it this way to make it more explicit.
591 sub create_immutable_transformer {
593 my $class = Class::MOP::Immutable->new($self, {
594 read_only => [qw/superclasses/],
601 remove_package_symbol
605 class_precedence_list => 'ARRAY',
606 linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
607 get_all_methods => 'ARRAY',
608 #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future
609 compute_all_applicable_attributes => 'ARRAY',
610 get_meta_instance => 'SCALAR',
611 get_method_map => 'SCALAR',
612 calculate_all_roles => 'ARRAY',
615 # this is ugly, but so are typeglobs,
616 # so whattayahgonnadoboutit
619 add_package_symbol => sub {
620 my $original = shift;
621 $self->throw_error("Cannot add package symbols to an immutable metaclass")
622 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
623 goto $original->body;
632 $self->SUPER::make_immutable
634 constructor_class => $self->constructor_class,
635 destructor_class => $self->destructor_class,
636 inline_destructor => 1,
638 # no need to do this,
639 # Moose always does it
640 inline_accessors => 0,
645 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
650 my ( $self, @args ) = @_;
652 $self->raise_error($self->create_error(@args));
656 my ( $self, @args ) = @_;
661 my ( $self, @args ) = @_;
663 if ( @args % 2 == 1 ) {
664 unshift @args, "message";
667 my %args = ( meta => $self, error => $@, @args );
669 local $level = $level + 1;
671 if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
672 return $self->create_error_object( %args, class => $class );
674 my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
676 my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
678 : ( $self->can("create_error_$builder") || "create_error_confess" ));
680 return $self->$builder_method(%args);
684 sub create_error_object {
685 my ( $self, %args ) = @_;
687 my $class = delete $args{class};
691 depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
695 sub create_error_croak {
696 my ( $self, @args ) = @_;
697 $self->_create_error_carpmess( @args );
700 sub create_error_confess {
701 my ( $self, @args ) = @_;
702 $self->_create_error_carpmess( @args, longmess => 1 );
705 sub _create_error_carpmess {
706 my ( $self, %args ) = @_;
708 my $carp_level = $level + 1 + ( $args{depth} || 1 );
710 local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
711 local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
713 my @args = exists $args{message} ? $args{message} : ();
715 if ( $args{longmess} ) {
716 return Carp::longmess(@args);
718 return Carp::shortmess(@args);
730 Moose::Meta::Class - The Moose metaclass
734 This is a subclass of L<Class::MOP::Class> with Moose specific
737 For the most part, the only time you will ever encounter an
738 instance of this class is if you are doing some serious deep
739 introspection. To really understand this class, you need to refer
740 to the L<Class::MOP::Class> documentation.
750 Overrides original to accept a list of roles to apply to
753 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
755 =item B<create_anon_class>
757 Overrides original to support roles and caching.
759 my $metaclass = Moose::Meta::Class->create_anon_class(
760 superclasses => ['Foo'],
761 roles => [qw/Some Roles Go Here/],
765 =item B<make_immutable>
767 Override original to add default options for inlining destructor
768 and altering the Constructor metaclass.
770 =item B<create_immutable_transformer>
772 Override original to lock C<add_role> and memoize C<calculate_all_roles>
776 We override this method to support the C<trigger> attribute option.
778 =item B<construct_instance>
780 This provides some Moose specific extensions to this method, you
781 almost never call this method directly unless you really know what
784 This method makes sure to handle the moose weak-ref, type-constraint
785 and type coercion features.
787 =item B<get_method_map>
789 This accommodates Moose::Meta::Role::Method instances, which are
790 aliased, instead of added, but still need to be counted as valid
793 =item B<add_override_method_modifier ($name, $method)>
795 This will create an C<override> method modifier for you, and install
798 =item B<add_augment_method_modifier ($name, $method)>
800 This will create an C<augment> method modifier for you, and install
803 =item B<calculate_all_roles>
807 This will return an array of C<Moose::Meta::Role> instances which are
808 attached to this class.
810 =item B<add_role ($role)>
812 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
813 to the list of associated roles.
815 =item B<does_role ($role_name)>
817 This will test if this class C<does> a given C<$role_name>. It will
818 not only check it's local roles, but ask them as well in order to
819 cascade down the role hierarchy.
821 =item B<excludes_role ($role_name)>
823 This will test if this class C<excludes> a given C<$role_name>. It will
824 not only check it's local roles, but ask them as well in order to
825 cascade down the role hierarchy.
827 =item B<add_attribute ($attr_name, %params|$params)>
829 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
830 support for taking the C<$params> as a HASH ref.
832 =item B<constructor_class ($class_name)>
834 =item B<destructor_class ($class_name)>
836 These are the names of classes used when making a class
837 immutable. These default to L<Moose::Meta::Method::Constructor> and
838 L<Moose::Meta::Method::Destructor> respectively. These accessors are
839 read-write, so you can use them to change the class name.
841 =item B<throw_error $message, %extra>
843 Throws the error created by C<create_error> using C<raise_error>
845 =item B<create_error $message, %extra>
847 Creates an error message or object.
849 The default behavior is C<create_error_confess>.
851 If C<error_class> is set uses C<create_error_object>. Otherwise uses
852 C<error_builder> (a code reference or variant name), and calls the appropriate
853 C<create_error_$builder> method.
855 =item B<error_builder $builder_name>
857 Get or set the error builder. Defaults to C<confess>.
859 =item B<error_class $class_name>
861 Get or set the error class. Has no default.
863 =item B<create_error_confess %args>
865 Creates an error using L<Carp/longmess>
867 =item B<create_error_croak %args>
869 Creates an error using L<Carp/shortmess>
871 =item B<create_error_object %args>
873 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
874 to support custom error objects for your meta class.
876 =item B<raise_error $error>
878 Dies with an error object or string.
884 All complex software has bugs lurking in it, and this module is no
885 exception. If you find a bug please either email me, or add the bug
890 Stevan Little E<lt>stevan@iinteractive.comE<gt>
892 =head1 COPYRIGHT AND LICENSE
894 Copyright 2006-2008 by Infinity Interactive, Inc.
896 L<http://www.iinteractive.com>
898 This library is free software; you can redistribute it and/or modify
899 it under the same terms as Perl itself.