2 package Moose::Meta::Class;
9 use Carp qw( confess );
11 use List::Util qw( first );
12 use List::MoreUtils qw( any all uniq first_index );
13 use Scalar::Util 'weaken', 'blessed';
15 our $VERSION = '1.14';
16 $VERSION = eval $VERSION;
17 our $AUTHORITY = 'cpan:STEVAN';
19 use Moose::Meta::Method::Overridden;
20 use Moose::Meta::Method::Augmented;
21 use Moose::Error::Default;
22 use Moose::Meta::Class::Immutable::Trait;
23 use Moose::Meta::Method::Constructor;
24 use Moose::Meta::Method::Destructor;
26 use Class::MOP::MiniTrait;
28 use base 'Class::MOP::Class';
30 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
32 __PACKAGE__->meta->add_attribute('roles' => (
37 __PACKAGE__->meta->add_attribute('role_applications' => (
38 reader => '_get_role_applications',
42 __PACKAGE__->meta->add_attribute(
43 Class::MOP::Attribute->new('immutable_trait' => (
44 accessor => "immutable_trait",
45 default => 'Moose::Meta::Class::Immutable::Trait',
49 __PACKAGE__->meta->add_attribute('constructor_class' => (
50 accessor => 'constructor_class',
51 default => 'Moose::Meta::Method::Constructor',
54 __PACKAGE__->meta->add_attribute('destructor_class' => (
55 accessor => 'destructor_class',
56 default => 'Moose::Meta::Method::Destructor',
59 __PACKAGE__->meta->add_attribute('error_class' => (
60 accessor => 'error_class',
61 default => 'Moose::Error::Default',
67 return Class::MOP::get_metaclass_by_name($pkg)
68 || $class->SUPER::initialize($pkg,
69 'attribute_metaclass' => 'Moose::Meta::Attribute',
70 'method_metaclass' => 'Moose::Meta::Method',
71 'instance_metaclass' => 'Moose::Meta::Instance',
77 my ($class, $package_name, %options) = @_;
79 (ref $options{roles} eq 'ARRAY')
80 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
81 if exists $options{roles};
82 my $roles = delete $options{roles};
84 my $new_meta = $class->SUPER::create($package_name, %options);
87 Moose::Util::apply_all_roles( $new_meta, @$roles );
95 sub create_anon_class {
96 my ($self, %options) = @_;
98 my $cache_ok = delete $options{cache};
101 = _anon_cache_key( $options{superclasses}, $options{roles} );
103 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
104 return $ANON_CLASSES{$cache_key};
107 my $new_class = $self->SUPER::create_anon_class(%options);
109 $ANON_CLASSES{$cache_key} = $new_class
115 sub _anon_cache_key {
116 # Makes something like Super::Class|Super::Class::2=Role|Role::1
118 join( '|', @{ $_[0] || [] } ),
119 join( '|', sort @{ $_[1] || [] } ),
127 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
131 my %existing_classes;
133 %existing_classes = map { $_ => $meta->$_() } qw(
136 wrapped_method_metaclass
143 $cache_key = _anon_cache_key(
144 [ $meta->superclasses ],
145 [ map { $_->name } @{ $meta->roles } ],
146 ) if $meta->is_anon_class;
149 my $new_meta = $self->SUPER::reinitialize(
155 return $new_meta unless defined $cache_key;
157 my $new_cache_key = _anon_cache_key(
158 [ $meta->superclasses ],
159 [ map { $_->name } @{ $meta->roles } ],
162 delete $ANON_CLASSES{$cache_key};
163 $ANON_CLASSES{$new_cache_key} = $new_meta;
169 my ($self, $role) = @_;
170 (blessed($role) && $role->isa('Moose::Meta::Role'))
171 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
172 push @{$self->roles} => $role;
175 sub role_applications {
178 return @{$self->_get_role_applications};
181 sub add_role_application {
182 my ($self, $application) = @_;
183 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
184 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
185 push @{$self->_get_role_applications} => $application;
188 sub calculate_all_roles {
191 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
194 sub calculate_all_roles_with_inheritance {
197 grep { !$seen{$_->name}++ }
198 map { Class::MOP::class_of($_)->can('calculate_all_roles')
199 ? Class::MOP::class_of($_)->calculate_all_roles
201 $self->linearized_isa;
205 my ($self, $role_name) = @_;
208 || $self->throw_error("You must supply a role name to look for");
210 foreach my $class ($self->class_precedence_list) {
211 my $meta = Class::MOP::class_of($class);
212 # when a Moose metaclass is itself extended with a role,
213 # this check needs to be done since some items in the
214 # class_precedence_list might in fact be Class::MOP
216 next unless $meta && $meta->can('roles');
217 foreach my $role (@{$meta->roles}) {
218 return 1 if $role->does_role($role_name);
225 my ($self, $role_name) = @_;
228 || $self->throw_error("You must supply a role name to look for");
230 foreach my $class ($self->class_precedence_list) {
231 my $meta = Class::MOP::class_of($class);
232 # when a Moose metaclass is itself extended with a role,
233 # this check needs to be done since some items in the
234 # class_precedence_list might in fact be Class::MOP
236 next unless $meta && $meta->can('roles');
237 foreach my $role (@{$meta->roles}) {
238 return 1 if $role->excludes_role($role_name);
246 my $params = @_ == 1 ? $_[0] : {@_};
247 my $object = $self->SUPER::new_object($params);
249 foreach my $attr ( $self->get_all_attributes() ) {
251 next unless $attr->can('has_trigger') && $attr->has_trigger;
253 my $init_arg = $attr->init_arg;
255 next unless defined $init_arg;
257 next unless exists $params->{$init_arg};
263 ? $attr->get_read_method_ref->($object)
264 : $params->{$init_arg}
269 $object->BUILDALL($params) if $object->can('BUILDALL');
276 my $supers = Data::OptList::mkopt(\@_);
277 foreach my $super (@{ $supers }) {
278 my ($name, $opts) = @{ $super };
279 Class::MOP::load_class($name, $opts);
280 my $meta = Class::MOP::class_of($name);
281 $self->throw_error("You cannot inherit from a Moose Role ($name)")
282 if $meta && $meta->isa('Moose::Meta::Role')
284 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
287 ### ---------------------------------------------
292 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
294 : $self->_process_attribute(@_));
295 $self->SUPER::add_attribute($attr);
296 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
297 # 'bare' and doesn't implement this method
298 if ($attr->can('_check_associated_methods')) {
299 $attr->_check_associated_methods;
304 sub add_override_method_modifier {
305 my ($self, $name, $method, $_super_package) = @_;
307 (!$self->has_method($name))
308 || $self->throw_error("Cannot add an override method if a local method is already present");
310 $self->add_method($name => Moose::Meta::Method::Overridden->new(
313 package => $_super_package, # need this for roles
318 sub add_augment_method_modifier {
319 my ($self, $name, $method) = @_;
320 (!$self->has_method($name))
321 || $self->throw_error("Cannot add an augment method if a local method is already present");
323 $self->add_method($name => Moose::Meta::Method::Augmented->new(
330 ## Private Utility methods ...
332 sub _find_next_method_by_name_which_is_not_overridden {
333 my ($self, $name) = @_;
334 foreach my $method ($self->find_all_methods_by_name($name)) {
335 return $method->{code}
336 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
341 ## Metaclass compatibility
343 sub _base_metaclasses {
345 my %metaclasses = $self->SUPER::_base_metaclasses;
346 for my $class (keys %metaclasses) {
347 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
351 error_class => 'Moose::Error::Default',
355 sub _can_fix_metaclass_incompatibility {
357 return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
358 return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
361 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
363 my ($super_meta) = @_;
365 return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
367 my %base_metaclass = $self->_base_metaclasses;
368 for my $metaclass_type (keys %base_metaclass) {
369 next unless defined $self->$metaclass_type;
370 return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
376 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
378 my ($super_meta) = @_;
380 my $super_meta_name = $super_meta->_real_ref_name;
382 return Moose::Util::_classes_differ_by_roles_only(
388 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
390 my ($metaclass_type, $super_meta) = @_;
392 my $class_specific_meta_name = $self->$metaclass_type;
393 return unless $super_meta->can($metaclass_type);
394 my $super_specific_meta_name = $super_meta->$metaclass_type;
395 my %metaclasses = $self->_base_metaclasses;
397 return Moose::Util::_classes_differ_by_roles_only(
398 $class_specific_meta_name,
399 $super_specific_meta_name,
403 sub _fix_class_metaclass_incompatibility {
405 my ($super_meta) = @_;
407 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
409 if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
411 || confess "Can't fix metaclass incompatibility for "
413 . " because it is not pristine.";
414 my $super_meta_name = $super_meta->_real_ref_name;
415 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
416 my $new_self = $class_meta_subclass_meta_name->reinitialize(
420 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
424 sub _fix_single_metaclass_incompatibility {
426 my ($metaclass_type, $super_meta) = @_;
428 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
430 if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
432 || confess "Can't fix metaclass incompatibility for "
434 . " because it is not pristine.";
435 my $super_meta_name = $super_meta->_real_ref_name;
436 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
437 my $new_self = $super_meta->reinitialize(
439 $metaclass_type => $class_specific_meta_subclass_meta_name,
442 $self->_replace_self( $new_self, $super_meta_name );
448 my ( $new_self, $new_class) = @_;
451 bless $self, $new_class;
453 # We need to replace the cached metaclass instance or else when it goes
454 # out of scope Class::MOP::Class destroy's the namespace for the
455 # metaclass's class, causing much havoc.
456 Class::MOP::store_metaclass_by_name( $self->name, $self );
457 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
460 sub _process_attribute {
461 my ( $self, $name, @args ) = @_;
463 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
465 if (($name || '') =~ /^\+(.*)/) {
466 return $self->_process_inherited_attribute($1, @args);
469 return $self->_process_new_attribute($name, @args);
473 sub _process_new_attribute {
474 my ( $self, $name, @args ) = @_;
476 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
479 sub _process_inherited_attribute {
480 my ($self, $attr_name, %options) = @_;
481 my $inherited_attr = $self->find_attribute_by_name($attr_name);
482 (defined $inherited_attr)
483 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
484 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
485 return $inherited_attr->clone_and_inherit_options(%options);
489 # kind of a kludge to handle Class::MOP::Attributes
490 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
496 sub _immutable_options {
497 my ( $self, @args ) = @_;
499 $self->SUPER::_immutable_options(
500 inline_destructor => 1,
502 # Moose always does this when an attribute is created
503 inline_accessors => 0,
509 ## -------------------------------------------------
514 my ( $self, @args ) = @_;
515 local $error_level = ($error_level || 0) + 1;
516 $self->raise_error($self->create_error(@args));
520 my ( $self, @args ) = @_;
525 my ( $self, @args ) = @_;
529 local $error_level = ($error_level || 0 ) + 1;
531 if ( @args % 2 == 1 ) {
532 unshift @args, "message";
535 my %args = ( metaclass => $self, last_error => $@, @args );
537 $args{depth} += $error_level;
539 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
541 Class::MOP::load_class($class);
544 Carp::caller_info($args{depth}),
557 Moose::Meta::Class - The Moose metaclass
561 This class is a subclass of L<Class::MOP::Class> that provides
562 additional Moose-specific functionality.
564 To really understand this class, you will need to start with the
565 L<Class::MOP::Class> documentation. This class can be understood as a
566 set of additional features on top of the basic feature provided by
571 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
577 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
579 This overrides the parent's method in order to provide its own
580 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
581 C<method_metaclass> options.
583 These all default to the appropriate Moose class.
585 =item B<< Moose::Meta::Class->create($package_name, %options) >>
587 This overrides the parent's method in order to accept a C<roles>
588 option. This should be an array reference containing roles
589 that the class does, each optionally followed by a hashref of options
590 (C<-excludes> and C<-alias>).
592 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
594 =item B<< Moose::Meta::Class->create_anon_class >>
596 This overrides the parent's method to accept a C<roles> option, just
599 It also accepts a C<cache> option. If this is true, then the anonymous
600 class will be cached based on its superclasses and roles. If an
601 existing anonymous class in the cache has the same superclasses and
602 roles, it will be reused.
604 my $metaclass = Moose::Meta::Class->create_anon_class(
605 superclasses => ['Foo'],
606 roles => [qw/Some Roles Go Here/],
610 Each entry in both the C<superclasses> and the C<roles> option can be
611 followed by a hash reference with arguments. The C<superclasses>
612 option can be supplied with a L<-version|Class::MOP/Class Loading
613 Options> option that ensures the loaded superclass satisfies the
614 required version. The C<role> option also takes the C<-version> as an
615 argument, but the option hash reference can also contain any other
616 role relevant values like exclusions or parameterized role arguments.
618 =item B<< $metaclass->make_immutable(%options) >>
620 This overrides the parent's method to add a few options. Specifically,
621 it uses the Moose-specific constructor and destructor classes, and
622 enables inlining the destructor.
624 Since Moose always inlines attributes, it sets the C<inline_accessors> option
627 =item B<< $metaclass->new_object(%params) >>
629 This overrides the parent's method in order to add support for
632 =item B<< $metaclass->superclasses(@superclasses) >>
634 This is the accessor allowing you to read or change the parents of
637 Each superclass can be followed by a hash reference containing a
638 L<-version|Class::MOP/Class Loading Options> value. If the version
639 requirement is not satisfied an error will be thrown.
641 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
643 This adds an C<override> method modifier to the package.
645 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
647 This adds an C<augment> method modifier to the package.
649 =item B<< $metaclass->calculate_all_roles >>
651 This will return a unique array of C<Moose::Meta::Role> instances
652 which are attached to this class.
654 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
656 This will return a unique array of C<Moose::Meta::Role> instances
657 which are attached to this class, and each of this class's ancestors.
659 =item B<< $metaclass->add_role($role) >>
661 This takes a L<Moose::Meta::Role> object, and adds it to the class's
662 list of roles. This I<does not> actually apply the role to the class.
664 =item B<< $metaclass->role_applications >>
666 Returns a list of L<Moose::Meta::Role::Application::ToClass>
667 objects, which contain the arguments to role application.
669 =item B<< $metaclass->add_role_application($application) >>
671 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
672 adds it to the class's list of role applications. This I<does not>
673 actually apply any role to the class; it is only for tracking role
676 =item B<< $metaclass->does_role($role) >>
678 This returns a boolean indicating whether or not the class does the specified
679 role. The role provided can be either a role name or a L<Moose::Meta::Role>
680 object. This tests both the class and its parents.
682 =item B<< $metaclass->excludes_role($role_name) >>
684 A class excludes a role if it has already composed a role which
685 excludes the named role. This tests both the class and its parents.
687 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
689 This overrides the parent's method in order to allow the parameters to
690 be provided as a hash reference.
692 =item B<< $metaclass->constructor_class($class_name) >>
694 =item B<< $metaclass->destructor_class($class_name) >>
696 These are the names of classes used when making a class immutable. These
697 default to L<Moose::Meta::Method::Constructor> and
698 L<Moose::Meta::Method::Destructor> respectively. These accessors are
699 read-write, so you can use them to change the class name.
701 =item B<< $metaclass->error_class($class_name) >>
703 The name of the class used to throw errors. This defaults to
704 L<Moose::Error::Default>, which generates an error with a stacktrace
705 just like C<Carp::confess>.
707 =item B<< $metaclass->throw_error($message, %extra) >>
709 Throws the error created by C<create_error> using C<raise_error>
715 See L<Moose/BUGS> for details on reporting bugs.
719 Stevan Little E<lt>stevan@iinteractive.comE<gt>
721 =head1 COPYRIGHT AND LICENSE
723 Copyright 2006-2010 by Infinity Interactive, Inc.
725 L<http://www.iinteractive.com>
727 This library is free software; you can redistribute it and/or modify
728 it under the same terms as Perl itself.