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 'blessed';
15 use Moose::Meta::Method::Overridden;
16 use Moose::Meta::Method::Augmented;
17 use Moose::Error::Default;
18 use Moose::Meta::Class::Immutable::Trait;
19 use Moose::Meta::Method::Constructor;
20 use Moose::Meta::Method::Destructor;
21 use Moose::Meta::Method::Meta;
23 use Class::MOP::MiniTrait;
25 use base 'Class::MOP::Class';
27 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
29 __PACKAGE__->meta->add_attribute('roles' => (
31 default => sub { [] },
32 Class::MOP::_definition_context(),
35 __PACKAGE__->meta->add_attribute('role_applications' => (
36 reader => '_get_role_applications',
37 default => sub { [] },
38 Class::MOP::_definition_context(),
41 __PACKAGE__->meta->add_attribute(
42 Class::MOP::Attribute->new('immutable_trait' => (
43 accessor => "immutable_trait",
44 default => 'Moose::Meta::Class::Immutable::Trait',
45 Class::MOP::_definition_context(),
49 __PACKAGE__->meta->add_attribute('constructor_class' => (
50 accessor => 'constructor_class',
51 default => 'Moose::Meta::Method::Constructor',
52 Class::MOP::_definition_context(),
55 __PACKAGE__->meta->add_attribute('destructor_class' => (
56 accessor => 'destructor_class',
57 default => 'Moose::Meta::Method::Destructor',
58 Class::MOP::_definition_context(),
61 __PACKAGE__->meta->add_attribute('error_class' => (
62 accessor => 'error_class',
63 default => 'Moose::Error::Default',
64 Class::MOP::_definition_context(),
70 unshift @args, 'package' if @args % 2;
72 my $package = delete $opts{package};
73 return Class::MOP::get_metaclass_by_name($package)
74 || $class->SUPER::initialize($package,
75 'attribute_metaclass' => 'Moose::Meta::Attribute',
76 'method_metaclass' => 'Moose::Meta::Method',
77 'instance_metaclass' => 'Moose::Meta::Instance',
86 unshift @args, 'package' if @args % 2 == 1;
89 (ref $options{roles} eq 'ARRAY')
90 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
91 if exists $options{roles};
93 my $package = delete $options{package};
94 my $roles = delete $options{roles};
96 my $new_meta = $class->SUPER::create($package, %options);
99 Moose::Util::apply_all_roles( $new_meta, @$roles );
105 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
107 sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' }
109 sub _anon_cache_key {
113 my $superclass_key = join('|',
114 map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) }
117 my $roles = Data::OptList::mkopt(($options{roles} || []), {
119 val_test => sub { ref($_[0]) eq 'HASH' },
123 for my $role_spec (@$roles) {
124 my ($role, $params) = @$role_spec;
125 $params = { %$params } if $params;
127 my $key = blessed($role) ? $role->name : $role;
129 if ($params && %$params) {
130 my $alias = delete $params->{'-alias'}
131 || delete $params->{'alias'}
133 my $excludes = delete $params->{'-excludes'}
134 || delete $params->{'excludes'}
136 $excludes = [$excludes] unless ref($excludes) eq 'ARRAY';
139 warn "Roles with parameters cannot be cached. Consider "
140 . "applying the parameters before calling "
141 . "create_anon_class, or using 'weaken => 0' instead";
145 my $alias_key = join('%',
146 map { $_ => $alias->{$_} } sort keys %$alias
148 my $excludes_key = join('%',
151 $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>';
154 push @role_keys, $key;
157 my $role_key = join('|', sort @role_keys);
159 # Makes something like Super::Class|Super::Class::2=Role|Role::1
160 return join('=', $superclass_key, $role_key);
167 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
169 my %existing_classes;
171 %existing_classes = map { $_ => $meta->$_() } qw(
174 wrapped_method_metaclass
182 return $self->SUPER::reinitialize(
190 my ($self, $role) = @_;
191 (blessed($role) && $role->isa('Moose::Meta::Role'))
192 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
193 push @{$self->roles} => $role;
196 sub role_applications {
199 return @{$self->_get_role_applications};
202 sub add_role_application {
203 my ($self, $application) = @_;
204 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
205 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
206 push @{$self->_get_role_applications} => $application;
209 sub calculate_all_roles {
212 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
215 sub calculate_all_roles_with_inheritance {
218 grep { !$seen{$_->name}++ }
219 map { Class::MOP::class_of($_)->can('calculate_all_roles')
220 ? Class::MOP::class_of($_)->calculate_all_roles
222 $self->linearized_isa;
226 my ($self, $role_name) = @_;
229 || $self->throw_error("You must supply a role name to look for");
231 foreach my $class ($self->class_precedence_list) {
232 my $meta = Class::MOP::class_of($class);
233 # when a Moose metaclass is itself extended with a role,
234 # this check needs to be done since some items in the
235 # class_precedence_list might in fact be Class::MOP
237 next unless $meta && $meta->can('roles');
238 foreach my $role (@{$meta->roles}) {
239 return 1 if $role->does_role($role_name);
246 my ($self, $role_name) = @_;
249 || $self->throw_error("You must supply a role name to look for");
251 foreach my $class ($self->class_precedence_list) {
252 my $meta = Class::MOP::class_of($class);
253 # when a Moose metaclass is itself extended with a role,
254 # this check needs to be done since some items in the
255 # class_precedence_list might in fact be Class::MOP
257 next unless $meta && $meta->can('roles');
258 foreach my $role (@{$meta->roles}) {
259 return 1 if $role->excludes_role($role_name);
267 my $params = @_ == 1 ? $_[0] : {@_};
268 my $object = $self->SUPER::new_object($params);
270 foreach my $attr ( $self->get_all_attributes() ) {
272 next unless $attr->can('has_trigger') && $attr->has_trigger;
274 my $init_arg = $attr->init_arg;
276 next unless defined $init_arg;
278 next unless exists $params->{$init_arg};
284 ? $attr->get_read_method_ref->($object)
285 : $params->{$init_arg}
290 $object->BUILDALL($params) if $object->can('BUILDALL');
295 sub _generate_fallback_constructor {
298 return $class . '->Moose::Object::new(@_)'
303 my ($params, $class) = @_;
305 'my ' . $params . ' = ',
306 $self->_inline_BUILDARGS($class, '@_'),
311 sub _inline_BUILDARGS {
313 my ($class, $args) = @_;
315 my $buildargs = $self->find_method_by_name("BUILDARGS");
318 && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
322 'if (scalar @_ == 1) {',
323 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
324 $self->_inline_throw_error(
325 '"Single parameters to new() must be a HASH ref"',
329 '$params = { %{ $_[0] } };',
333 '"The new() method for ' . $class . ' expects a '
334 . 'hash reference or a key/value list. You passed an '
335 . 'odd number of arguments"',
337 '$params = {@_, undef};',
347 return $class . '->BUILDARGS(' . $args . ')';
351 sub _inline_slot_initializer {
353 my ($attr, $idx) = @_;
357 $self->_inline_check_required_attr($attr),
358 $self->SUPER::_inline_slot_initializer(@_),
362 sub _inline_check_required_attr {
366 return unless defined $attr->init_arg;
367 return unless $attr->can('is_required') && $attr->is_required;
368 return if $attr->has_default || $attr->has_builder;
371 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
372 $self->_inline_throw_error(
373 '"Attribute (' . quotemeta($attr->name) . ') is required"'
379 # XXX: these two are duplicated from cmop, because we have to pass the tc stuff
380 # through to _inline_set_value - this should probably be fixed, but i'm not
381 # quite sure how. -doy
382 sub _inline_init_attr_from_constructor {
384 my ($attr, $idx) = @_;
386 my @initial_value = $attr->_inline_set_value(
388 '$params->{\'' . $attr->init_arg . '\'}',
389 '$type_constraint_bodies[' . $idx . ']',
390 '$type_coercions[' . $idx . ']',
391 '$type_constraint_messages[' . $idx . ']',
395 push @initial_value, (
396 '$attrs->[' . $idx . ']->set_initial_value(',
398 $attr->_inline_instance_get('$instance'),
400 ) if $attr->has_initializer;
402 return @initial_value;
405 sub _inline_init_attr_from_default {
407 my ($attr, $idx) = @_;
409 return if $attr->can('is_lazy') && $attr->is_lazy;
410 my $default = $self->_inline_default_value($attr, $idx);
411 return unless $default;
413 my @initial_value = (
414 'my $default = ' . $default . ';',
415 $attr->_inline_set_value(
418 '$type_constraint_bodies[' . $idx . ']',
419 '$type_coercions[' . $idx . ']',
420 '$type_constraint_messages[' . $idx . ']',
425 push @initial_value, (
426 '$attrs->[' . $idx . ']->set_initial_value(',
428 $attr->_inline_instance_get('$instance'),
430 ) if $attr->has_initializer;
432 return @initial_value;
435 sub _inline_extra_init {
438 $self->_inline_triggers,
439 $self->_inline_BUILDALL,
443 sub _inline_triggers {
447 my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
448 for my $i (0 .. $#attrs) {
449 my $attr = $attrs[$i];
451 next unless $attr->can('has_trigger') && $attr->has_trigger;
453 my $init_arg = $attr->init_arg;
454 next unless defined $init_arg;
457 'if (exists $params->{\'' . $init_arg . '\'}) {',
458 '$triggers->[' . $i . ']->(',
460 $attr->_inline_instance_get('$instance') . ',',
465 return @trigger_calls;
468 sub _inline_BUILDALL {
471 my @methods = reverse $self->find_all_methods_by_name('BUILD');
474 foreach my $method (@methods) {
476 '$instance->' . $method->{class} . '::BUILD($params);';
484 my $supers = Data::OptList::mkopt(\@_);
485 foreach my $super (@{ $supers }) {
486 my ($name, $opts) = @{ $super };
487 Class::MOP::load_class($name, $opts);
488 my $meta = Class::MOP::class_of($name);
489 $self->throw_error("You cannot inherit from a Moose Role ($name)")
490 if $meta && $meta->isa('Moose::Meta::Role')
492 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
495 ### ---------------------------------------------
500 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
502 : $self->_process_attribute(@_));
503 $self->SUPER::add_attribute($attr);
504 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
505 # 'bare' and doesn't implement this method
506 if ($attr->can('_check_associated_methods')) {
507 $attr->_check_associated_methods;
512 sub add_override_method_modifier {
513 my ($self, $name, $method, $_super_package) = @_;
515 (!$self->has_method($name))
516 || $self->throw_error("Cannot add an override method if a local method is already present");
518 $self->add_method($name => Moose::Meta::Method::Overridden->new(
521 package => $_super_package, # need this for roles
526 sub add_augment_method_modifier {
527 my ($self, $name, $method) = @_;
528 (!$self->has_method($name))
529 || $self->throw_error("Cannot add an augment method if a local method is already present");
531 $self->add_method($name => Moose::Meta::Method::Augmented->new(
538 ## Private Utility methods ...
540 sub _find_next_method_by_name_which_is_not_overridden {
541 my ($self, $name) = @_;
542 foreach my $method ($self->find_all_methods_by_name($name)) {
543 return $method->{code}
544 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
549 ## Metaclass compatibility
551 sub _base_metaclasses {
553 my %metaclasses = $self->SUPER::_base_metaclasses;
554 for my $class (keys %metaclasses) {
555 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
559 error_class => 'Moose::Error::Default',
563 sub _fix_class_metaclass_incompatibility {
565 my ($super_meta) = @_;
567 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
569 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
571 || confess "Can't fix metaclass incompatibility for "
573 . " because it is not pristine.";
574 my $super_meta_name = $super_meta->_real_ref_name;
575 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
576 my $new_self = $class_meta_subclass_meta_name->reinitialize(
580 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
584 sub _fix_single_metaclass_incompatibility {
586 my ($metaclass_type, $super_meta) = @_;
588 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
590 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
592 || confess "Can't fix metaclass incompatibility for "
594 . " because it is not pristine.";
595 my $super_meta_name = $super_meta->_real_ref_name;
596 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
597 my $new_self = $super_meta->reinitialize(
599 $metaclass_type => $class_specific_meta_subclass_meta_name,
602 $self->_replace_self( $new_self, $super_meta_name );
608 my ( $new_self, $new_class) = @_;
611 bless $self, $new_class;
613 # We need to replace the cached metaclass instance or else when it goes
614 # out of scope Class::MOP::Class destroy's the namespace for the
615 # metaclass's class, causing much havoc.
616 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
617 Class::MOP::store_metaclass_by_name( $self->name, $self );
618 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
621 sub _process_attribute {
622 my ( $self, $name, @args ) = @_;
624 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
626 if (($name || '') =~ /^\+(.*)/) {
627 return $self->_process_inherited_attribute($1, @args);
630 return $self->_process_new_attribute($name, @args);
634 sub _process_new_attribute {
635 my ( $self, $name, @args ) = @_;
637 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
640 sub _process_inherited_attribute {
641 my ($self, $attr_name, %options) = @_;
642 my $inherited_attr = $self->find_attribute_by_name($attr_name);
643 (defined $inherited_attr)
644 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
645 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
646 return $inherited_attr->clone_and_inherit_options(%options);
650 # kind of a kludge to handle Class::MOP::Attributes
651 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
655 # reinitialization support
657 sub _restore_metaobjects_from {
661 $self->SUPER::_restore_metaobjects_from($old_meta);
663 for my $role ( @{ $old_meta->roles } ) {
664 $self->add_role($role);
667 for my $application ( @{ $old_meta->_get_role_applications } ) {
668 $application->class($self);
669 $self->add_role_application ($application);
675 sub _immutable_options {
676 my ( $self, @args ) = @_;
678 $self->SUPER::_immutable_options(
679 inline_destructor => 1,
681 # Moose always does this when an attribute is created
682 inline_accessors => 0,
688 ## -------------------------------------------------
693 my ( $self, @args ) = @_;
694 local $error_level = ($error_level || 0) + 1;
695 $self->raise_error($self->create_error(@args));
698 sub _inline_throw_error {
699 my ( $self, @args ) = @_;
700 $self->_inline_raise_error($self->_inline_create_error(@args));
704 my ( $self, @args ) = @_;
708 sub _inline_raise_error {
709 my ( $self, $message ) = @_;
712 'die ' . $message . ';',
717 my ( $self, @args ) = @_;
721 local $error_level = ($error_level || 0 ) + 1;
723 if ( @args % 2 == 1 ) {
724 unshift @args, "message";
727 my %args = ( metaclass => $self, last_error => $@, @args );
729 $args{depth} += $error_level;
731 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
733 Class::MOP::load_class($class);
736 Carp::caller_info($args{depth}),
741 sub _inline_create_error {
742 my ( $self, $msg, $args ) = @_;
743 # XXX ignore $args for now, nothing currently uses it anyway
753 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
755 Class::MOP::load_class($class);
757 # don't check inheritance here - the intention is that the class needs
758 # to provide a non-inherited inlining method, because falling back to
759 # the default inlining method is most likely going to be wrong
760 # yes, this is a huge hack, but so is the entire error system, so.
761 return '$meta->create_error(' . $msg . ', ' . $args . ');'
762 unless $class->meta->has_method('_inline_new');
765 # XXX ignore this for now too
766 # Carp::caller_info($args{depth}),
773 # ABSTRACT: The Moose metaclass
781 This class is a subclass of L<Class::MOP::Class> that provides
782 additional Moose-specific functionality.
784 To really understand this class, you will need to start with the
785 L<Class::MOP::Class> documentation. This class can be understood as a
786 set of additional features on top of the basic feature provided by
791 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
797 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
799 This overrides the parent's method in order to provide its own
800 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
801 C<method_metaclass> options.
803 These all default to the appropriate Moose class.
805 =item B<< Moose::Meta::Class->create($package_name, %options) >>
807 This overrides the parent's method in order to accept a C<roles>
808 option. This should be an array reference containing roles
809 that the class does, each optionally followed by a hashref of options
810 (C<-excludes> and C<-alias>).
812 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
814 =item B<< Moose::Meta::Class->create_anon_class >>
816 This overrides the parent's method to accept a C<roles> option, just
819 It also accepts a C<cache> option. If this is true, then the anonymous
820 class will be cached based on its superclasses and roles. If an
821 existing anonymous class in the cache has the same superclasses and
822 roles, it will be reused.
824 my $metaclass = Moose::Meta::Class->create_anon_class(
825 superclasses => ['Foo'],
826 roles => [qw/Some Roles Go Here/],
830 Each entry in both the C<superclasses> and the C<roles> option can be
831 followed by a hash reference with arguments. The C<superclasses>
832 option can be supplied with a L<-version|Class::MOP/Class Loading
833 Options> option that ensures the loaded superclass satisfies the
834 required version. The C<role> option also takes the C<-version> as an
835 argument, but the option hash reference can also contain any other
836 role relevant values like exclusions or parameterized role arguments.
838 =item B<< $metaclass->make_immutable(%options) >>
840 This overrides the parent's method to add a few options. Specifically,
841 it uses the Moose-specific constructor and destructor classes, and
842 enables inlining the destructor.
844 Since Moose always inlines attributes, it sets the C<inline_accessors> option
847 =item B<< $metaclass->new_object(%params) >>
849 This overrides the parent's method in order to add support for
852 =item B<< $metaclass->superclasses(@superclasses) >>
854 This is the accessor allowing you to read or change the parents of
857 Each superclass can be followed by a hash reference containing a
858 L<-version|Class::MOP/Class Loading Options> value. If the version
859 requirement is not satisfied an error will be thrown.
861 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
863 This adds an C<override> method modifier to the package.
865 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
867 This adds an C<augment> method modifier to the package.
869 =item B<< $metaclass->calculate_all_roles >>
871 This will return a unique array of C<Moose::Meta::Role> instances
872 which are attached to this class.
874 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
876 This will return a unique array of C<Moose::Meta::Role> instances
877 which are attached to this class, and each of this class's ancestors.
879 =item B<< $metaclass->add_role($role) >>
881 This takes a L<Moose::Meta::Role> object, and adds it to the class's
882 list of roles. This I<does not> actually apply the role to the class.
884 =item B<< $metaclass->role_applications >>
886 Returns a list of L<Moose::Meta::Role::Application::ToClass>
887 objects, which contain the arguments to role application.
889 =item B<< $metaclass->add_role_application($application) >>
891 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
892 adds it to the class's list of role applications. This I<does not>
893 actually apply any role to the class; it is only for tracking role
896 =item B<< $metaclass->does_role($role) >>
898 This returns a boolean indicating whether or not the class does the specified
899 role. The role provided can be either a role name or a L<Moose::Meta::Role>
900 object. This tests both the class and its parents.
902 =item B<< $metaclass->excludes_role($role_name) >>
904 A class excludes a role if it has already composed a role which
905 excludes the named role. This tests both the class and its parents.
907 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
909 This overrides the parent's method in order to allow the parameters to
910 be provided as a hash reference.
912 =item B<< $metaclass->constructor_class($class_name) >>
914 =item B<< $metaclass->destructor_class($class_name) >>
916 These are the names of classes used when making a class immutable. These
917 default to L<Moose::Meta::Method::Constructor> and
918 L<Moose::Meta::Method::Destructor> respectively. These accessors are
919 read-write, so you can use them to change the class name.
921 =item B<< $metaclass->error_class($class_name) >>
923 The name of the class used to throw errors. This defaults to
924 L<Moose::Error::Default>, which generates an error with a stacktrace
925 just like C<Carp::confess>.
927 =item B<< $metaclass->throw_error($message, %extra) >>
929 Throws the error created by C<create_error> using C<raise_error>
935 See L<Moose/BUGS> for details on reporting bugs.