2 package Moose::Meta::Class;
10 use List::Util qw( first );
11 use List::MoreUtils qw( any all uniq );
12 use Scalar::Util 'weaken', 'blessed';
14 our $VERSION = '0.77';
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 => 'role_applications',
38 __PACKAGE__->meta->add_attribute(
39 Class::MOP::Attribute->new('immutable_trait' => (
40 accessor => "immutable_trait",
41 default => 'Moose::Meta::Class::Immutable::Trait',
45 __PACKAGE__->meta->add_attribute('constructor_class' => (
46 accessor => 'constructor_class',
47 default => 'Moose::Meta::Method::Constructor',
50 __PACKAGE__->meta->add_attribute('destructor_class' => (
51 accessor => 'destructor_class',
52 default => 'Moose::Meta::Method::Destructor',
55 __PACKAGE__->meta->add_attribute('error_class' => (
56 accessor => 'error_class',
57 default => 'Moose::Error::Default',
63 return Class::MOP::get_metaclass_by_name($pkg)
64 || $class->SUPER::initialize($pkg,
65 'attribute_metaclass' => 'Moose::Meta::Attribute',
66 'method_metaclass' => 'Moose::Meta::Method',
67 'instance_metaclass' => 'Moose::Meta::Instance',
72 sub _immutable_options {
73 my ( $self, @args ) = @_;
75 $self->SUPER::_immutable_options(
76 inline_destructor => 1,
78 # Moose always does this when an attribute is created
79 inline_accessors => 0,
86 my ($self, $package_name, %options) = @_;
88 (ref $options{roles} eq 'ARRAY')
89 || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
90 if exists $options{roles};
91 my $roles = delete $options{roles};
93 my $class = $self->SUPER::create($package_name, %options);
96 Moose::Util::apply_all_roles( $class, @$roles );
102 sub _check_metaclass_compatibility {
105 if ( my @supers = $self->superclasses ) {
106 $self->_fix_metaclass_incompatibility(@supers);
109 $self->SUPER::_check_metaclass_compatibility(@_);
114 sub create_anon_class {
115 my ($self, %options) = @_;
117 my $cache_ok = delete $options{cache};
119 # something like Super::Class|Super::Class::2=Role|Role::1
120 my $cache_key = join '=' => (
121 join('|', @{$options{superclasses} || []}),
122 join('|', sort @{$options{roles} || []}),
125 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
126 return $ANON_CLASSES{$cache_key};
129 my $new_class = $self->SUPER::create_anon_class(%options);
131 $ANON_CLASSES{$cache_key} = $new_class
138 my ($self, $role) = @_;
139 (blessed($role) && $role->isa('Moose::Meta::Role'))
140 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
141 push @{$self->roles} => $role;
144 sub add_role_application {
145 my ($self, $application) = @_;
146 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
147 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
148 push @{$self->role_applications} => $application;
151 sub calculate_all_roles {
154 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
158 my ($self, $role_name) = @_;
161 || $self->throw_error("You must supply a role name to look for");
163 foreach my $class ($self->class_precedence_list) {
164 my $meta = Class::MOP::class_of($class);
165 # when a Moose metaclass is itself extended with a role,
166 # this check needs to be done since some items in the
167 # class_precedence_list might in fact be Class::MOP
169 next unless $meta && $meta->can('roles');
170 foreach my $role (@{$meta->roles}) {
171 return 1 if $role->does_role($role_name);
178 my ($self, $role_name) = @_;
181 || $self->throw_error("You must supply a role name to look for");
183 foreach my $class ($self->class_precedence_list) {
184 my $meta = Class::MOP::class_of($class);
185 # when a Moose metaclass is itself extended with a role,
186 # this check needs to be done since some items in the
187 # class_precedence_list might in fact be Class::MOP
189 next unless $meta && $meta->can('roles');
190 foreach my $role (@{$meta->roles}) {
191 return 1 if $role->excludes_role($role_name);
199 my $params = @_ == 1 ? $_[0] : {@_};
200 my $self = $class->SUPER::new_object($params);
202 foreach my $attr ( $class->get_all_attributes() ) {
204 next unless $attr->can('has_trigger') && $attr->has_trigger;
206 my $init_arg = $attr->init_arg;
208 next unless defined $init_arg;
210 next unless exists $params->{$init_arg};
216 ? $attr->get_read_method_ref->($self)
217 : $params->{$init_arg}
225 sub _construct_instance {
227 my $params = @_ == 1 ? $_[0] : {@_};
228 my $meta_instance = $class->get_meta_instance;
230 # the code below is almost certainly incorrect
231 # but this is foreign inheritance, so we might
232 # have to kludge it in the end.
233 my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
234 foreach my $attr ($class->get_all_attributes()) {
235 $attr->initialize_instance_slot($meta_instance, $instance, $params);
243 foreach my $super (@supers) {
244 my $meta = Class::MOP::load_class($super);
245 Moose->throw_error("You cannot inherit from a Moose Role ($super)")
246 if $meta && $meta->isa('Moose::Meta::Role')
248 return $self->SUPER::superclasses(@supers);
251 ### ---------------------------------------------
255 $self->SUPER::add_attribute(
256 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
258 : $self->_process_attribute(@_))
262 sub add_override_method_modifier {
263 my ($self, $name, $method, $_super_package) = @_;
265 (!$self->has_method($name))
266 || $self->throw_error("Cannot add an override method if a local method is already present");
268 $self->add_method($name => Moose::Meta::Method::Overridden->new(
271 package => $_super_package, # need this for roles
276 sub add_augment_method_modifier {
277 my ($self, $name, $method) = @_;
278 (!$self->has_method($name))
279 || $self->throw_error("Cannot add an augment method if a local method is already present");
281 $self->add_method($name => Moose::Meta::Method::Augmented->new(
288 ## Private Utility methods ...
290 sub _find_next_method_by_name_which_is_not_overridden {
291 my ($self, $name) = @_;
292 foreach my $method ($self->find_all_methods_by_name($name)) {
293 return $method->{code}
294 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
299 sub _fix_metaclass_incompatibility {
300 my ($self, @superclasses) = @_;
302 foreach my $super (@superclasses) {
303 next if $self->_superclass_meta_is_compatible($super);
305 unless ( $self->is_pristine ) {
307 "Cannot attempt to reinitialize metaclass for "
309 . ", it isn't pristine" );
312 $self->_reconcile_with_superclass_meta($super);
316 sub _superclass_meta_is_compatible {
317 my ($self, $super) = @_;
319 my $super_meta = Class::MOP::Class->initialize($super)
322 next unless $super_meta->isa("Class::MOP::Class");
325 = $super_meta->is_immutable
326 ? $super_meta->get_mutable_metaclass_name
330 if $self->isa($super_meta_name)
332 $self->instance_metaclass->isa( $super_meta->instance_metaclass );
335 # I don't want to have to type this >1 time
337 qw( attribute_metaclass
339 wrapped_method_metaclass
345 sub _reconcile_with_superclass_meta {
346 my ($self, $super) = @_;
348 my $super_meta = Class::MOP::class_of($super);
351 = $super_meta->is_immutable
352 ? $super_meta->get_mutable_metaclass_name
355 my $self_metaclass = ref $self;
357 # If neither of these is true we have a more serious
358 # incompatibility that we just cannot fix (yet?).
359 if ( $super_meta_name->isa( ref $self )
360 && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
361 $self->_reinitialize_with($super_meta);
363 elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
364 $self->_reconcile_role_differences($super_meta);
368 sub _reinitialize_with {
369 my ( $self, $new_meta ) = @_;
371 my $new_self = $new_meta->reinitialize(
373 attribute_metaclass => $new_meta->attribute_metaclass,
374 method_metaclass => $new_meta->method_metaclass,
375 instance_metaclass => $new_meta->instance_metaclass,
378 $new_self->$_( $new_meta->$_ )
379 for qw( constructor_class destructor_class error_class );
383 bless $self, ref $new_self;
385 # We need to replace the cached metaclass instance or else when it
386 # goes out of scope Class::MOP::Class destroy's the namespace for
387 # the metaclass's class, causing much havoc.
388 Class::MOP::store_metaclass_by_name( $self->name, $self );
389 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
392 # In the more complex case, we share a common ancestor with our
393 # superclass's metaclass, but each metaclass (ours and the parent's)
394 # has a different set of roles applied. We reconcile this by first
395 # reinitializing into the parent class, and _then_ applying our own
397 sub _all_metaclasses_differ_by_roles_only {
398 my ($self, $super_meta) = @_;
401 [ ref $self, ref $super_meta ],
402 map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
405 next if $pair->[0] eq $pair->[1];
407 my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] );
408 my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
411 = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
413 return unless $common_ancestor;
416 unless _is_role_only_subclass_of(
420 && _is_role_only_subclass_of(
429 # This, and some other functions, could be called as methods, but
430 # they're not for two reasons. One, we just end up ignoring the first
431 # argument, because we can't call these directly on one of the real
432 # arguments, because one of them could be a Class::MOP::Class object
433 # and not a Moose::Meta::Class. Second, only a completely insane
434 # person would attempt to subclass this stuff!
435 sub _find_common_ancestor {
436 my ($meta1, $meta2) = @_;
438 # FIXME? This doesn't account for multiple inheritance (not sure
439 # if it needs to though). For example, is somewhere in $meta1's
440 # history it inherits from both ClassA and ClassB, and $meta2
441 # inherits from ClassB & ClassA, does it matter? And what crazy
442 # fool would do that anyway?
444 my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
446 return first { $meta1_parents{$_} } $meta2->linearized_isa;
449 sub _is_role_only_subclass_of {
450 my ($meta, $ancestor) = @_;
452 return 1 if $meta->name eq $ancestor;
454 my @roles = _all_roles_until( $meta, $ancestor );
456 my %role_packages = map { $_->name => 1 } @roles;
458 my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
460 my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
462 for my $method ( $meta->get_all_methods() ) {
463 next if $method->name eq 'meta';
464 next if $method->can('associated_attribute');
467 if $role_packages{ $method->original_package_name }
468 || $shared_ancestors{ $method->original_package_name };
473 # FIXME - this really isn't right. Just because an attribute is
474 # defined in a role doesn't mean it isn't _also_ defined in the
476 for my $attr ( $meta->get_all_attributes ) {
477 next if $shared_ancestors{ $attr->associated_class->name };
479 next if any { $_->has_attribute( $attr->name ) } @roles;
490 return _all_roles_until($meta);
493 sub _all_roles_until {
494 my ($meta, $stop_at_class) = @_;
496 return unless $meta->can('calculate_all_roles');
498 my @roles = $meta->calculate_all_roles;
500 for my $class ( $meta->linearized_isa ) {
501 last if $stop_at_class && $stop_at_class eq $class;
503 my $meta = Class::MOP::Class->initialize($class);
504 last unless $meta->can('calculate_all_roles');
506 push @roles, $meta->calculate_all_roles;
512 sub _reconcile_role_differences {
513 my ($self, $super_meta) = @_;
515 my $self_meta = Class::MOP::class_of($self);
519 if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
520 $roles{metaclass_roles} = \@roles;
523 for my $thing (@MetaClassTypes) {
524 my $name = $self->$thing();
526 my $thing_meta = Class::MOP::Class->initialize($name);
528 my @roles = map { $_->name } _all_roles($thing_meta)
531 $roles{ $thing . '_roles' } = \@roles;
534 $self->_reinitialize_with($super_meta);
536 Moose::Util::MetaRole::apply_metaclass_roles(
537 for_class => $self->name,
544 sub _process_attribute {
545 my ( $self, $name, @args ) = @_;
547 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
549 if (($name || '') =~ /^\+(.*)/) {
550 return $self->_process_inherited_attribute($1, @args);
553 return $self->_process_new_attribute($name, @args);
557 sub _process_new_attribute {
558 my ( $self, $name, @args ) = @_;
560 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
563 sub _process_inherited_attribute {
564 my ($self, $attr_name, %options) = @_;
565 my $inherited_attr = $self->find_attribute_by_name($attr_name);
566 (defined $inherited_attr)
567 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
568 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
569 return $inherited_attr->clone_and_inherit_options(%options);
573 # kind of a kludge to handle Class::MOP::Attributes
574 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
578 ## -------------------------------------------------
583 my ( $self, @args ) = @_;
584 local $error_level = ($error_level || 0) + 1;
585 $self->raise_error($self->create_error(@args));
589 my ( $self, @args ) = @_;
594 my ( $self, @args ) = @_;
598 local $error_level = ($error_level || 0 ) + 1;
600 if ( @args % 2 == 1 ) {
601 unshift @args, "message";
604 my %args = ( metaclass => $self, last_error => $@, @args );
606 $args{depth} += $error_level;
608 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
610 Class::MOP::load_class($class);
613 Carp::caller_info($args{depth}),
626 Moose::Meta::Class - The Moose metaclass
630 This class is a subclass of L<Class::MOP::Class> that provides
631 additional Moose-specific functionality.
633 To really understand this class, you will need to start with the
634 L<Class::MOP::Class> documentation. This class can be understood as a
635 set of additional features on top of the basic feature provided by
640 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
646 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
648 This overrides the parent's method in order to provide its own
649 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
650 C<method_metaclass> options.
652 These all default to the appropriate Moose class.
654 =item B<< Moose::Meta::Class->create($package_name, %options) >>
656 This overrides the parent's method in order to accept a C<roles>
657 option. This should be an array reference containing one more roles
660 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
662 =item B<< Moose::Meta::Class->create_anon_class >>
664 This overrides the parent's method to accept a C<roles> option, just
667 It also accepts a C<cache> option. If this is true, then the anonymous
668 class will be cached based on its superclasses and roles. If an
669 existing anonymous class in the cache has the same superclasses and
670 roles, it will be reused.
672 my $metaclass = Moose::Meta::Class->create_anon_class(
673 superclasses => ['Foo'],
674 roles => [qw/Some Roles Go Here/],
678 =item B<< $metaclass->make_immutable(%options) >>
680 This overrides the parent's method to add a few options. Specifically,
681 it uses the Moose-specific constructor and destructor classes, and
682 enables inlining the destructor.
684 Also, since Moose always inlines attributes, it sets the
685 C<inline_accessors> option to false.
687 =item B<< $metaclass->new_object(%params) >>
689 This overrides the parent's method in order to add support for
692 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
694 This adds an C<override> method modifier to the package.
696 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
698 This adds an C<augment> method modifier to the package.
700 =item B<< $metaclass->calculate_all_roles >>
702 This will return a unique array of C<Moose::Meta::Role> instances
703 which are attached to this class.
705 =item B<< $metaclass->add_role($role) >>
707 This takes a L<Moose::Meta::Role> object, and adds it to the class's
708 list of roles. This I<does not> actually apply the role to the class.
710 =item B<< $metaclass->does_role($role_name) >>
712 This returns a boolean indicating whether or not the class does the
713 specified role. This tests both the class and its parents.
715 =item B<< $metaclass->excludes_role($role_name) >>
717 A class excludes a role if it has already composed a role which
718 excludes the named role. This tests both the class and its parents.
720 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
722 This overrides the parent's method in order to allow the parameters to
723 be provided as a hash reference.
725 =item B<< $metaclass->constructor_class ($class_name) >>
727 =item B<< $metaclass->destructor_class ($class_name) >>
729 These are the names of classes used when making a class
730 immutable. These default to L<Moose::Meta::Method::Constructor> and
731 L<Moose::Meta::Method::Destructor> respectively. These accessors are
732 read-write, so you can use them to change the class name.
734 =item B<< $metaclass->error_class($class_name) >>
736 The name of the class used to throw errors. This defaults to
737 L<Moose::Error::Default>, which generates an error with a stacktrace
738 just like C<Carp::confess>.
740 =item B<< $metaclass->throw_error($message, %extra) >>
742 Throws the error created by C<create_error> using C<raise_error>
748 All complex software has bugs lurking in it, and this module is no
749 exception. If you find a bug please either email me, or add the bug
754 Stevan Little E<lt>stevan@iinteractive.comE<gt>
756 =head1 COPYRIGHT AND LICENSE
758 Copyright 2006-2009 by Infinity Interactive, Inc.
760 L<http://www.iinteractive.com>
762 This library is free software; you can redistribute it and/or modify
763 it under the same terms as Perl itself.