2 package Moose::Meta::Class;
10 use List::Util qw( first );
11 use List::MoreUtils qw( any all uniq first_index );
12 use Scalar::Util 'weaken', 'blessed';
14 our $VERSION = '0.92';
15 $VERSION = eval $VERSION;
16 our $AUTHORITY = 'cpan:STEVAN';
18 use Moose::Meta::Method::Overridden;
19 use Moose::Meta::Method::Augmented;
20 use Moose::Error::Default;
21 use Moose::Meta::Class::Immutable::Trait;
22 use Moose::Meta::Method::Constructor;
23 use Moose::Meta::Method::Destructor;
25 use base 'Class::MOP::Class';
27 __PACKAGE__->meta->add_attribute('roles' => (
32 __PACKAGE__->meta->add_attribute('role_applications' => (
33 reader => '_get_role_applications',
37 __PACKAGE__->meta->add_attribute(
38 Class::MOP::Attribute->new('immutable_trait' => (
39 accessor => "immutable_trait",
40 default => 'Moose::Meta::Class::Immutable::Trait',
44 __PACKAGE__->meta->add_attribute('constructor_class' => (
45 accessor => 'constructor_class',
46 default => 'Moose::Meta::Method::Constructor',
49 __PACKAGE__->meta->add_attribute('destructor_class' => (
50 accessor => 'destructor_class',
51 default => 'Moose::Meta::Method::Destructor',
54 __PACKAGE__->meta->add_attribute('error_class' => (
55 accessor => 'error_class',
56 default => 'Moose::Error::Default',
62 return Class::MOP::get_metaclass_by_name($pkg)
63 || $class->SUPER::initialize($pkg,
64 'attribute_metaclass' => 'Moose::Meta::Attribute',
65 'method_metaclass' => 'Moose::Meta::Method',
66 'instance_metaclass' => 'Moose::Meta::Instance',
71 sub _immutable_options {
72 my ( $self, @args ) = @_;
74 $self->SUPER::_immutable_options(
75 inline_destructor => 1,
77 # Moose always does this when an attribute is created
78 inline_accessors => 0,
85 my ($self, $package_name, %options) = @_;
87 (ref $options{roles} eq 'ARRAY')
88 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
89 if exists $options{roles};
90 my $roles = delete $options{roles};
92 my $class = $self->SUPER::create($package_name, %options);
95 Moose::Util::apply_all_roles( $class, @$roles );
101 sub _check_metaclass_compatibility {
104 if ( my @supers = $self->superclasses ) {
105 $self->_fix_metaclass_incompatibility(@supers);
108 $self->SUPER::_check_metaclass_compatibility(@_);
113 sub create_anon_class {
114 my ($self, %options) = @_;
116 my $cache_ok = delete $options{cache};
118 # something like Super::Class|Super::Class::2=Role|Role::1
119 my $cache_key = join '=' => (
120 join('|', @{$options{superclasses} || []}),
121 join('|', sort @{$options{roles} || []}),
124 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
125 return $ANON_CLASSES{$cache_key};
128 my $new_class = $self->SUPER::create_anon_class(%options);
130 $ANON_CLASSES{$cache_key} = $new_class
137 my ($self, $role) = @_;
138 (blessed($role) && $role->isa('Moose::Meta::Role'))
139 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
140 push @{$self->roles} => $role;
143 sub role_applications {
146 return @{$self->_get_role_applications};
149 sub add_role_application {
150 my ($self, $application) = @_;
151 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
152 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
153 push @{$self->_get_role_applications} => $application;
156 sub calculate_all_roles {
159 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
163 my ($self, $role_name) = @_;
166 || $self->throw_error("You must supply a role name to look for");
168 foreach my $class ($self->class_precedence_list) {
169 my $meta = Class::MOP::class_of($class);
170 # when a Moose metaclass is itself extended with a role,
171 # this check needs to be done since some items in the
172 # class_precedence_list might in fact be Class::MOP
174 next unless $meta && $meta->can('roles');
175 foreach my $role (@{$meta->roles}) {
176 return 1 if $role->does_role($role_name);
183 my ($self, $role_name) = @_;
186 || $self->throw_error("You must supply a role name to look for");
188 foreach my $class ($self->class_precedence_list) {
189 my $meta = Class::MOP::class_of($class);
190 # when a Moose metaclass is itself extended with a role,
191 # this check needs to be done since some items in the
192 # class_precedence_list might in fact be Class::MOP
194 next unless $meta && $meta->can('roles');
195 foreach my $role (@{$meta->roles}) {
196 return 1 if $role->excludes_role($role_name);
204 my $params = @_ == 1 ? $_[0] : {@_};
205 my $self = $class->SUPER::new_object($params);
207 foreach my $attr ( $class->get_all_attributes() ) {
209 next unless $attr->can('has_trigger') && $attr->has_trigger;
211 my $init_arg = $attr->init_arg;
213 next unless defined $init_arg;
215 next unless exists $params->{$init_arg};
221 ? $attr->get_read_method_ref->($self)
222 : $params->{$init_arg}
233 foreach my $super (@supers) {
234 Class::MOP::load_class($super);
235 my $meta = Class::MOP::class_of($super);
236 $self->throw_error("You cannot inherit from a Moose Role ($super)")
237 if $meta && $meta->isa('Moose::Meta::Role')
239 return $self->SUPER::superclasses(@supers);
242 ### ---------------------------------------------
247 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
249 : $self->_process_attribute(@_));
250 $self->SUPER::add_attribute($attr);
251 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
252 # 'bare' and doesn't implement this method
253 if ($attr->can('_check_associated_methods')) {
254 $attr->_check_associated_methods;
259 sub add_override_method_modifier {
260 my ($self, $name, $method, $_super_package) = @_;
262 (!$self->has_method($name))
263 || $self->throw_error("Cannot add an override method if a local method is already present");
265 $self->add_method($name => Moose::Meta::Method::Overridden->new(
268 package => $_super_package, # need this for roles
273 sub add_augment_method_modifier {
274 my ($self, $name, $method) = @_;
275 (!$self->has_method($name))
276 || $self->throw_error("Cannot add an augment method if a local method is already present");
278 $self->add_method($name => Moose::Meta::Method::Augmented->new(
285 ## Private Utility methods ...
287 sub _find_next_method_by_name_which_is_not_overridden {
288 my ($self, $name) = @_;
289 foreach my $method ($self->find_all_methods_by_name($name)) {
290 return $method->{code}
291 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
296 sub _fix_metaclass_incompatibility {
297 my ($self, @superclasses) = @_;
299 $self->_fix_one_incompatible_metaclass($_)
300 for map { Moose::Meta::Class->initialize($_) } @superclasses;
303 sub _fix_one_incompatible_metaclass {
304 my ($self, $meta) = @_;
306 return if $self->_superclass_meta_is_compatible($meta);
308 unless ( $self->is_pristine ) {
310 "Cannot attempt to reinitialize metaclass for "
312 . ", it isn't pristine" );
315 $self->_reconcile_with_superclass_meta($meta);
318 sub _superclass_meta_is_compatible {
319 my ($self, $super_meta) = @_;
321 next unless $super_meta->isa("Class::MOP::Class");
324 = $super_meta->is_immutable
325 ? $super_meta->_get_mutable_metaclass_name
329 if $self->isa($super_meta_name)
331 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
334 # I don't want to have to type this >1 time
336 qw( attribute_metaclass
338 wrapped_method_metaclass
344 sub _reconcile_with_superclass_meta {
345 my ($self, $super_meta) = @_;
348 = $super_meta->is_immutable
349 ? $super_meta->_get_mutable_metaclass_name
352 my $self_metaclass = ref $self;
354 # If neither of these is true we have a more serious
355 # incompatibility that we just cannot fix (yet?).
356 if ( $super_meta_name->isa( ref $self )
357 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
358 $self->_reinitialize_with($super_meta);
360 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
361 $self->_reconcile_role_differences($super_meta);
365 sub _reinitialize_with {
366 my ( $self, $new_meta ) = @_;
368 my $new_self = $new_meta->reinitialize(
370 attribute_metaclass => $new_meta->attribute_metaclass,
371 method_metaclass => $new_meta->method_metaclass,
372 instance_metaclass => $new_meta->instance_metaclass,
375 $new_self->$_( $new_meta->$_ )
376 for qw( constructor_class destructor_class error_class );
380 bless $self, ref $new_self;
382 # We need to replace the cached metaclass instance or else when it
383 # goes out of scope Class::MOP::Class destroy's the namespace for
384 # the metaclass's class, causing much havoc.
385 Class::MOP::store_metaclass_by_name( $self->name, $self );
386 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
389 # In the more complex case, we share a common ancestor with our
390 # superclass's metaclass, but each metaclass (ours and the parent's)
391 # has a different set of roles applied. We reconcile this by first
392 # reinitializing into the parent class, and _then_ applying our own
394 sub _all_metaclasses_differ_by_roles_only {
395 my ($self, $super_meta) = @_;
398 [ ref $self, ref $super_meta ],
399 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
402 next if $pair->[0] eq $pair->[1];
404 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
405 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
408 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
410 return unless $common_ancestor;
413 unless _is_role_only_subclass_of(
417 && _is_role_only_subclass_of(
426 # This, and some other functions, could be called as methods, but
427 # they're not for two reasons. One, we just end up ignoring the first
428 # argument, because we can't call these directly on one of the real
429 # arguments, because one of them could be a Class::MOP::Class object
430 # and not a Moose::Meta::Class. Second, only a completely insane
431 # person would attempt to subclass this stuff!
432 sub _find_common_ancestor {
433 my ($meta1, $meta2) = @_;
435 # FIXME? This doesn't account for multiple inheritance (not sure
436 # if it needs to though). For example, is somewhere in $meta1's
437 # history it inherits from both ClassA and ClassB, and $meta2
438 # inherits from ClassB & ClassA, does it matter? And what crazy
439 # fool would do that anyway?
441 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
443 return first { $meta1_parents{$_} } $meta2->linearized_isa;
446 sub _is_role_only_subclass_of {
447 my ($meta, $ancestor) = @_;
449 return 1 if $meta->name eq $ancestor;
451 my @roles = _all_roles_until( $meta, $ancestor );
453 my %role_packages = map { $_->name => 1 } @roles;
455 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
457 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
459 for my $method ( $meta->get_all_methods() ) {
460 next if $method->name eq 'meta';
461 next if $method->can('associated_attribute');
464 if $role_packages{ $method->original_package_name }
465 || $shared_ancestors{ $method->original_package_name };
470 # FIXME - this really isn't right. Just because an attribute is
471 # defined in a role doesn't mean it isn't _also_ defined in the
473 for my $attr ( $meta->get_all_attributes ) {
474 next if $shared_ancestors{ $attr->associated_class->name };
476 next if any { $_->has_attribute( $attr->name ) } @roles;
487 return _all_roles_until($meta);
490 sub _all_roles_until {
491 my ($meta, $stop_at_class) = @_;
493 return unless $meta->can('calculate_all_roles');
495 my @roles = $meta->calculate_all_roles;
497 for my $class ( $meta->linearized_isa ) {
498 last if $stop_at_class && $stop_at_class eq $class;
500 my $meta = Class::MOP::Class->initialize($class);
501 last unless $meta->can('calculate_all_roles');
503 push @roles, $meta->calculate_all_roles;
509 sub _reconcile_role_differences {
510 my ($self, $super_meta) = @_;
512 my $self_meta = Class::MOP::class_of($self);
516 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
517 $roles{metaclass_roles} = \@roles;
520 for my $thing (@MetaClassTypes) {
521 my $name = $self->$thing();
523 my $thing_meta = Class::MOP::Class->initialize($name);
525 my @roles = map { $_->name } _all_roles($thing_meta)
528 $roles{ $thing . '_roles' } = \@roles;
531 $self->_reinitialize_with($super_meta);
533 Moose::Util::MetaRole::apply_metaclass_roles(
534 for_class => $self->name,
541 sub _process_attribute {
542 my ( $self, $name, @args ) = @_;
544 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
546 if (($name || '') =~ /^\+(.*)/) {
547 return $self->_process_inherited_attribute($1, @args);
550 return $self->_process_new_attribute($name, @args);
554 sub _process_new_attribute {
555 my ( $self, $name, @args ) = @_;
557 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
560 sub _process_inherited_attribute {
561 my ($self, $attr_name, %options) = @_;
562 my $inherited_attr = $self->find_attribute_by_name($attr_name);
563 (defined $inherited_attr)
564 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
565 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
566 return $inherited_attr->clone_and_inherit_options(%options);
570 # kind of a kludge to handle Class::MOP::Attributes
571 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
575 ## -------------------------------------------------
580 my ( $self, @args ) = @_;
581 local $error_level = ($error_level || 0) + 1;
582 $self->raise_error($self->create_error(@args));
586 my ( $self, @args ) = @_;
591 my ( $self, @args ) = @_;
595 local $error_level = ($error_level || 0 ) + 1;
597 if ( @args % 2 == 1 ) {
598 unshift @args, "message";
601 my %args = ( metaclass => $self, last_error => $@, @args );
603 $args{depth} += $error_level;
605 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
607 Class::MOP::load_class($class);
610 Carp::caller_info($args{depth}),
623 Moose::Meta::Class - The Moose metaclass
627 This class is a subclass of L<Class::MOP::Class> that provides
628 additional Moose-specific functionality.
630 To really understand this class, you will need to start with the
631 L<Class::MOP::Class> documentation. This class can be understood as a
632 set of additional features on top of the basic feature provided by
637 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
643 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
645 This overrides the parent's method in order to provide its own
646 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
647 C<method_metaclass> options.
649 These all default to the appropriate Moose class.
651 =item B<< Moose::Meta::Class->create($package_name, %options) >>
653 This overrides the parent's method in order to accept a C<roles>
654 option. This should be an array reference containing roles
655 that the class does, each optionally followed by a hashref of options
656 (C<-excludes> and C<-alias>).
658 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
660 =item B<< Moose::Meta::Class->create_anon_class >>
662 This overrides the parent's method to accept a C<roles> option, just
665 It also accepts a C<cache> option. If this is true, then the anonymous
666 class will be cached based on its superclasses and roles. If an
667 existing anonymous class in the cache has the same superclasses and
668 roles, it will be reused.
670 my $metaclass = Moose::Meta::Class->create_anon_class(
671 superclasses => ['Foo'],
672 roles => [qw/Some Roles Go Here/],
676 =item B<< $metaclass->make_immutable(%options) >>
678 This overrides the parent's method to add a few options. Specifically,
679 it uses the Moose-specific constructor and destructor classes, and
680 enables inlining the destructor.
682 Also, since Moose always inlines attributes, it sets the
683 C<inline_accessors> option to false.
685 =item B<< $metaclass->new_object(%params) >>
687 This overrides the parent's method in order to add support for
690 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
692 This adds an C<override> method modifier to the package.
694 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
696 This adds an C<augment> method modifier to the package.
698 =item B<< $metaclass->calculate_all_roles >>
700 This will return a unique array of C<Moose::Meta::Role> instances
701 which are attached to this class.
703 =item B<< $metaclass->add_role($role) >>
705 This takes a L<Moose::Meta::Role> object, and adds it to the class's
706 list of roles. This I<does not> actually apply the role to the class.
708 =item B<< $metaclass->role_applications >>
710 Returns a list of L<Moose::Meta::Role::Application::ToClass>
711 objects, which contain the arguments to role application.
713 =item B<< $metaclass->add_role_application($application) >>
715 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
716 adds it to the class's list of role applications. This I<does not>
717 actually apply any role to the class; it is only for tracking role
720 =item B<< $metaclass->does_role($role_name) >>
722 This returns a boolean indicating whether or not the class does the
723 specified role. This tests both the class and its parents.
725 =item B<< $metaclass->excludes_role($role_name) >>
727 A class excludes a role if it has already composed a role which
728 excludes the named role. This tests both the class and its parents.
730 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
732 This overrides the parent's method in order to allow the parameters to
733 be provided as a hash reference.
735 =item B<< $metaclass->constructor_class ($class_name) >>
737 =item B<< $metaclass->destructor_class ($class_name) >>
739 These are the names of classes used when making a class
740 immutable. These default to L<Moose::Meta::Method::Constructor> and
741 L<Moose::Meta::Method::Destructor> respectively. These accessors are
742 read-write, so you can use them to change the class name.
744 =item B<< $metaclass->error_class($class_name) >>
746 The name of the class used to throw errors. This defaults to
747 L<Moose::Error::Default>, which generates an error with a stacktrace
748 just like C<Carp::confess>.
750 =item B<< $metaclass->throw_error($message, %extra) >>
752 Throws the error created by C<create_error> using C<raise_error>
758 All complex software has bugs lurking in it, and this module is no
759 exception. If you find a bug please either email me, or add the bug
764 Stevan Little E<lt>stevan@iinteractive.comE<gt>
766 =head1 COPYRIGHT AND LICENSE
768 Copyright 2006-2009 by Infinity Interactive, Inc.
770 L<http://www.iinteractive.com>
772 This library is free software; you can redistribute it and/or modify
773 it under the same terms as Perl itself.