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 $AUTHORITY = 'cpan:STEVAN';
17 use Moose::Meta::Method::Overridden;
18 use Moose::Meta::Method::Augmented;
19 use Moose::Error::Default;
20 use Moose::Meta::Class::Immutable::Trait;
21 use Moose::Meta::Method::Constructor;
22 use Moose::Meta::Method::Destructor;
23 use Moose::Meta::Method::Meta;
25 use Class::MOP::MiniTrait;
27 use base 'Class::MOP::Class';
29 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
31 __PACKAGE__->meta->add_attribute('roles' => (
36 __PACKAGE__->meta->add_attribute('role_applications' => (
37 reader => '_get_role_applications',
41 __PACKAGE__->meta->add_attribute(
42 Class::MOP::Attribute->new('immutable_trait' => (
43 accessor => "immutable_trait",
44 default => 'Moose::Meta::Class::Immutable::Trait',
48 __PACKAGE__->meta->add_attribute('constructor_class' => (
49 accessor => 'constructor_class',
50 default => 'Moose::Meta::Method::Constructor',
53 __PACKAGE__->meta->add_attribute('destructor_class' => (
54 accessor => 'destructor_class',
55 default => 'Moose::Meta::Method::Destructor',
58 __PACKAGE__->meta->add_attribute('error_class' => (
59 accessor => 'error_class',
60 default => 'Moose::Error::Default',
66 return Class::MOP::get_metaclass_by_name($pkg)
67 || $class->SUPER::initialize($pkg,
68 'attribute_metaclass' => 'Moose::Meta::Attribute',
69 'method_metaclass' => 'Moose::Meta::Method',
70 'instance_metaclass' => 'Moose::Meta::Instance',
76 my ($class, $package_name, %options) = @_;
78 (ref $options{roles} eq 'ARRAY')
79 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
80 if exists $options{roles};
81 my $roles = delete $options{roles};
83 my $new_meta = $class->SUPER::create($package_name, %options);
86 Moose::Util::apply_all_roles( $new_meta, @$roles );
94 sub create_anon_class {
95 my ($self, %options) = @_;
97 my $cache_ok = delete $options{cache};
100 = _anon_cache_key( $options{superclasses}, $options{roles} );
102 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
103 return $ANON_CLASSES{$cache_key};
106 $options{weaken} = !$cache_ok
107 unless exists $options{weaken};
109 my $new_class = $self->SUPER::create_anon_class(%options);
112 $ANON_CLASSES{$cache_key} = $new_class;
113 weaken($ANON_CLASSES{$cache_key});
119 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
121 sub _anon_cache_key {
122 # Makes something like Super::Class|Super::Class::2=Role|Role::1
124 join( '|', @{ $_[0] || [] } ),
125 join( '|', sort @{ $_[1] || [] } ),
133 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
137 my %existing_classes;
139 %existing_classes = map { $_ => $meta->$_() } qw(
142 wrapped_method_metaclass
149 $cache_key = _anon_cache_key(
150 [ $meta->superclasses ],
151 [ map { $_->name } @{ $meta->roles } ],
152 ) if $meta->is_anon_class;
155 my $new_meta = $self->SUPER::reinitialize(
161 return $new_meta unless defined $cache_key;
163 my $new_cache_key = _anon_cache_key(
164 [ $meta->superclasses ],
165 [ map { $_->name } @{ $meta->roles } ],
168 delete $ANON_CLASSES{$cache_key};
169 $ANON_CLASSES{$new_cache_key} = $new_meta;
170 weaken($ANON_CLASSES{$new_cache_key});
176 my ($self, $role) = @_;
177 (blessed($role) && $role->isa('Moose::Meta::Role'))
178 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
179 push @{$self->roles} => $role;
182 sub role_applications {
185 return @{$self->_get_role_applications};
188 sub add_role_application {
189 my ($self, $application) = @_;
190 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
191 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
192 push @{$self->_get_role_applications} => $application;
195 sub calculate_all_roles {
198 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
201 sub calculate_all_roles_with_inheritance {
204 grep { !$seen{$_->name}++ }
205 map { Class::MOP::class_of($_)->can('calculate_all_roles')
206 ? Class::MOP::class_of($_)->calculate_all_roles
208 $self->linearized_isa;
212 my ($self, $role_name) = @_;
215 || $self->throw_error("You must supply a role name to look for");
217 foreach my $class ($self->class_precedence_list) {
218 my $meta = Class::MOP::class_of($class);
219 # when a Moose metaclass is itself extended with a role,
220 # this check needs to be done since some items in the
221 # class_precedence_list might in fact be Class::MOP
223 next unless $meta && $meta->can('roles');
224 foreach my $role (@{$meta->roles}) {
225 return 1 if $role->does_role($role_name);
232 my ($self, $role_name) = @_;
235 || $self->throw_error("You must supply a role name to look for");
237 foreach my $class ($self->class_precedence_list) {
238 my $meta = Class::MOP::class_of($class);
239 # when a Moose metaclass is itself extended with a role,
240 # this check needs to be done since some items in the
241 # class_precedence_list might in fact be Class::MOP
243 next unless $meta && $meta->can('roles');
244 foreach my $role (@{$meta->roles}) {
245 return 1 if $role->excludes_role($role_name);
253 my $params = @_ == 1 ? $_[0] : {@_};
254 my $object = $self->SUPER::new_object($params);
256 foreach my $attr ( $self->get_all_attributes() ) {
258 next unless $attr->can('has_trigger') && $attr->has_trigger;
260 my $init_arg = $attr->init_arg;
262 next unless defined $init_arg;
264 next unless exists $params->{$init_arg};
270 ? $attr->get_read_method_ref->($object)
271 : $params->{$init_arg}
276 $object->BUILDALL($params) if $object->can('BUILDALL');
281 sub _generate_fallback_constructor {
284 return $class . '->Moose::Object::new(@_)'
289 my ($params, $class) = @_;
291 'my ' . $params . ' = ',
292 $self->_inline_BUILDARGS($class, '@_'),
297 sub _inline_BUILDARGS {
299 my ($class, $args) = @_;
301 my $buildargs = $self->find_method_by_name("BUILDARGS");
304 && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
308 'if (scalar @_ == 1) {',
309 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
310 $self->_inline_throw_error(
311 '"Single parameters to new() must be a HASH ref"',
315 '$params = { %{ $_[0] } };',
319 '"The new() method for ' . $class . ' expects a '
320 . 'hash reference or a key/value list. You passed an '
321 . 'odd number of arguments"',
323 '$params = {@_, undef};',
333 return $class . '->BUILDARGS(' . $args . ')';
337 sub _inline_slot_initializer {
339 my ($attr, $idx) = @_;
343 $self->_inline_check_required_attr($attr),
344 $self->SUPER::_inline_slot_initializer(@_),
348 sub _inline_check_required_attr {
352 return unless defined $attr->init_arg;
353 return unless $attr->can('is_required') && $attr->is_required;
354 return if $attr->has_default || $attr->has_builder;
357 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
358 $self->_inline_throw_error(
359 '"Attribute (' . quotemeta($attr->name) . ') is required"'
365 # XXX: these two are duplicated from cmop, because we have to pass the tc stuff
366 # through to _inline_set_value - this should probably be fixed, but i'm not
367 # quite sure how. -doy
368 sub _inline_init_attr_from_constructor {
370 my ($attr, $idx) = @_;
372 my @initial_value = $attr->_inline_set_value(
374 '$params->{\'' . $attr->init_arg . '\'}',
375 '$type_constraint_bodies[' . $idx . ']',
376 '$type_constraints[' . $idx . ']',
380 push @initial_value, (
381 '$attrs->[' . $idx . ']->set_initial_value(',
383 $attr->_inline_instance_get('$instance'),
385 ) if $attr->has_initializer;
387 return @initial_value;
390 sub _inline_init_attr_from_default {
392 my ($attr, $idx) = @_;
394 my $default = $self->_inline_default_value($attr, $idx);
395 return unless $default;
397 my @initial_value = (
398 'my $default = ' . $default . ';',
399 $attr->_inline_set_value(
402 '$type_constraint_bodies[' . $idx . ']',
403 '$type_constraints[' . $idx . ']',
408 push @initial_value, (
409 '$attrs->[' . $idx . ']->set_initial_value(',
411 $attr->_inline_instance_get('$instance'),
413 ) if $attr->has_initializer;
415 return @initial_value;
418 sub _inline_extra_init {
421 $self->_inline_triggers,
422 $self->_inline_BUILDALL,
426 sub _inline_triggers {
430 my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
431 for my $i (0 .. $#attrs) {
432 my $attr = $attrs[$i];
434 next unless $attr->can('has_trigger') && $attr->has_trigger;
436 my $init_arg = $attr->init_arg;
437 next unless defined $init_arg;
440 'if (exists $params->{\'' . $init_arg . '\'}) {',
441 '$attrs->[' . $i . ']->trigger->(',
443 $attr->_inline_instance_get('$instance') . ',',
448 return @trigger_calls;
451 sub _inline_BUILDALL {
454 my @methods = reverse $self->find_all_methods_by_name('BUILD');
457 foreach my $method (@methods) {
459 '$instance->' . $method->{class} . '::BUILD($params);';
467 my $supers = Data::OptList::mkopt(\@_);
468 foreach my $super (@{ $supers }) {
469 my ($name, $opts) = @{ $super };
470 Class::MOP::load_class($name, $opts);
471 my $meta = Class::MOP::class_of($name);
472 $self->throw_error("You cannot inherit from a Moose Role ($name)")
473 if $meta && $meta->isa('Moose::Meta::Role')
475 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
478 ### ---------------------------------------------
483 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
485 : $self->_process_attribute(@_));
486 $self->SUPER::add_attribute($attr);
487 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
488 # 'bare' and doesn't implement this method
489 if ($attr->can('_check_associated_methods')) {
490 $attr->_check_associated_methods;
495 sub add_override_method_modifier {
496 my ($self, $name, $method, $_super_package) = @_;
498 (!$self->has_method($name))
499 || $self->throw_error("Cannot add an override method if a local method is already present");
501 $self->add_method($name => Moose::Meta::Method::Overridden->new(
504 package => $_super_package, # need this for roles
509 sub add_augment_method_modifier {
510 my ($self, $name, $method) = @_;
511 (!$self->has_method($name))
512 || $self->throw_error("Cannot add an augment method if a local method is already present");
514 $self->add_method($name => Moose::Meta::Method::Augmented->new(
521 ## Private Utility methods ...
523 sub _find_next_method_by_name_which_is_not_overridden {
524 my ($self, $name) = @_;
525 foreach my $method ($self->find_all_methods_by_name($name)) {
526 return $method->{code}
527 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
532 ## Metaclass compatibility
534 sub _base_metaclasses {
536 my %metaclasses = $self->SUPER::_base_metaclasses;
537 for my $class (keys %metaclasses) {
538 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
542 error_class => 'Moose::Error::Default',
546 sub _fix_class_metaclass_incompatibility {
548 my ($super_meta) = @_;
550 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
552 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
554 || confess "Can't fix metaclass incompatibility for "
556 . " because it is not pristine.";
557 my $super_meta_name = $super_meta->_real_ref_name;
558 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
559 my $new_self = $class_meta_subclass_meta_name->reinitialize(
563 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
567 sub _fix_single_metaclass_incompatibility {
569 my ($metaclass_type, $super_meta) = @_;
571 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
573 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
575 || confess "Can't fix metaclass incompatibility for "
577 . " because it is not pristine.";
578 my $super_meta_name = $super_meta->_real_ref_name;
579 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
580 my $new_self = $super_meta->reinitialize(
582 $metaclass_type => $class_specific_meta_subclass_meta_name,
585 $self->_replace_self( $new_self, $super_meta_name );
591 my ( $new_self, $new_class) = @_;
594 bless $self, $new_class;
596 # We need to replace the cached metaclass instance or else when it goes
597 # out of scope Class::MOP::Class destroy's the namespace for the
598 # metaclass's class, causing much havoc.
599 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
600 Class::MOP::store_metaclass_by_name( $self->name, $self );
601 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
604 sub _process_attribute {
605 my ( $self, $name, @args ) = @_;
607 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
609 if (($name || '') =~ /^\+(.*)/) {
610 return $self->_process_inherited_attribute($1, @args);
613 return $self->_process_new_attribute($name, @args);
617 sub _process_new_attribute {
618 my ( $self, $name, @args ) = @_;
620 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
623 sub _process_inherited_attribute {
624 my ($self, $attr_name, %options) = @_;
625 my $inherited_attr = $self->find_attribute_by_name($attr_name);
626 (defined $inherited_attr)
627 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
628 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
629 return $inherited_attr->clone_and_inherit_options(%options);
633 # kind of a kludge to handle Class::MOP::Attributes
634 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
640 sub _immutable_options {
641 my ( $self, @args ) = @_;
643 $self->SUPER::_immutable_options(
644 inline_destructor => 1,
646 # Moose always does this when an attribute is created
647 inline_accessors => 0,
653 ## -------------------------------------------------
658 my ( $self, @args ) = @_;
659 local $error_level = ($error_level || 0) + 1;
660 $self->raise_error($self->create_error(@args));
663 sub _inline_throw_error {
664 my ( $self, $msg, $args ) = @_;
665 "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
669 my ( $self, @args ) = @_;
674 my ( $self, @args ) = @_;
678 local $error_level = ($error_level || 0 ) + 1;
680 if ( @args % 2 == 1 ) {
681 unshift @args, "message";
684 my %args = ( metaclass => $self, last_error => $@, @args );
686 $args{depth} += $error_level;
688 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
690 Class::MOP::load_class($class);
693 Carp::caller_info($args{depth}),
700 # ABSTRACT: The Moose metaclass
708 This class is a subclass of L<Class::MOP::Class> that provides
709 additional Moose-specific functionality.
711 To really understand this class, you will need to start with the
712 L<Class::MOP::Class> documentation. This class can be understood as a
713 set of additional features on top of the basic feature provided by
718 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
724 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
726 This overrides the parent's method in order to provide its own
727 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
728 C<method_metaclass> options.
730 These all default to the appropriate Moose class.
732 =item B<< Moose::Meta::Class->create($package_name, %options) >>
734 This overrides the parent's method in order to accept a C<roles>
735 option. This should be an array reference containing roles
736 that the class does, each optionally followed by a hashref of options
737 (C<-excludes> and C<-alias>).
739 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
741 =item B<< Moose::Meta::Class->create_anon_class >>
743 This overrides the parent's method to accept a C<roles> option, just
746 It also accepts a C<cache> option. If this is true, then the anonymous
747 class will be cached based on its superclasses and roles. If an
748 existing anonymous class in the cache has the same superclasses and
749 roles, it will be reused.
751 my $metaclass = Moose::Meta::Class->create_anon_class(
752 superclasses => ['Foo'],
753 roles => [qw/Some Roles Go Here/],
757 Each entry in both the C<superclasses> and the C<roles> option can be
758 followed by a hash reference with arguments. The C<superclasses>
759 option can be supplied with a L<-version|Class::MOP/Class Loading
760 Options> option that ensures the loaded superclass satisfies the
761 required version. The C<role> option also takes the C<-version> as an
762 argument, but the option hash reference can also contain any other
763 role relevant values like exclusions or parameterized role arguments.
765 =item B<< $metaclass->make_immutable(%options) >>
767 This overrides the parent's method to add a few options. Specifically,
768 it uses the Moose-specific constructor and destructor classes, and
769 enables inlining the destructor.
771 Since Moose always inlines attributes, it sets the C<inline_accessors> option
774 =item B<< $metaclass->new_object(%params) >>
776 This overrides the parent's method in order to add support for
779 =item B<< $metaclass->superclasses(@superclasses) >>
781 This is the accessor allowing you to read or change the parents of
784 Each superclass can be followed by a hash reference containing a
785 L<-version|Class::MOP/Class Loading Options> value. If the version
786 requirement is not satisfied an error will be thrown.
788 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
790 This adds an C<override> method modifier to the package.
792 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
794 This adds an C<augment> method modifier to the package.
796 =item B<< $metaclass->calculate_all_roles >>
798 This will return a unique array of C<Moose::Meta::Role> instances
799 which are attached to this class.
801 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
803 This will return a unique array of C<Moose::Meta::Role> instances
804 which are attached to this class, and each of this class's ancestors.
806 =item B<< $metaclass->add_role($role) >>
808 This takes a L<Moose::Meta::Role> object, and adds it to the class's
809 list of roles. This I<does not> actually apply the role to the class.
811 =item B<< $metaclass->role_applications >>
813 Returns a list of L<Moose::Meta::Role::Application::ToClass>
814 objects, which contain the arguments to role application.
816 =item B<< $metaclass->add_role_application($application) >>
818 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
819 adds it to the class's list of role applications. This I<does not>
820 actually apply any role to the class; it is only for tracking role
823 =item B<< $metaclass->does_role($role) >>
825 This returns a boolean indicating whether or not the class does the specified
826 role. The role provided can be either a role name or a L<Moose::Meta::Role>
827 object. This tests both the class and its parents.
829 =item B<< $metaclass->excludes_role($role_name) >>
831 A class excludes a role if it has already composed a role which
832 excludes the named role. This tests both the class and its parents.
834 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
836 This overrides the parent's method in order to allow the parameters to
837 be provided as a hash reference.
839 =item B<< $metaclass->constructor_class($class_name) >>
841 =item B<< $metaclass->destructor_class($class_name) >>
843 These are the names of classes used when making a class immutable. These
844 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<< $metaclass->error_class($class_name) >>
850 The name of the class used to throw errors. This defaults to
851 L<Moose::Error::Default>, which generates an error with a stacktrace
852 just like C<Carp::confess>.
854 =item B<< $metaclass->throw_error($message, %extra) >>
856 Throws the error created by C<create_error> using C<raise_error>
862 See L<Moose/BUGS> for details on reporting bugs.