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' => (
34 __PACKAGE__->meta->add_attribute('role_applications' => (
35 reader => '_get_role_applications',
39 __PACKAGE__->meta->add_attribute(
40 Class::MOP::Attribute->new('immutable_trait' => (
41 accessor => "immutable_trait",
42 default => 'Moose::Meta::Class::Immutable::Trait',
46 __PACKAGE__->meta->add_attribute('constructor_class' => (
47 accessor => 'constructor_class',
48 default => 'Moose::Meta::Method::Constructor',
51 __PACKAGE__->meta->add_attribute('destructor_class' => (
52 accessor => 'destructor_class',
53 default => 'Moose::Meta::Method::Destructor',
56 __PACKAGE__->meta->add_attribute('error_class' => (
57 accessor => 'error_class',
58 default => 'Moose::Error::Default',
64 unshift @args, 'package' if @args % 2;
66 my $package = delete $opts{package};
67 return Class::MOP::get_metaclass_by_name($package)
68 || $class->SUPER::initialize($package,
69 'attribute_metaclass' => 'Moose::Meta::Attribute',
70 'method_metaclass' => 'Moose::Meta::Method',
71 'instance_metaclass' => 'Moose::Meta::Instance',
80 unshift @args, 'package' if @args % 2 == 1;
83 (ref $options{roles} eq 'ARRAY')
84 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
85 if exists $options{roles};
87 my $package = delete $options{package};
88 my $roles = delete $options{roles};
90 my $new_meta = $class->SUPER::create($package, %options);
93 Moose::Util::apply_all_roles( $new_meta, @$roles );
99 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
101 sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' }
103 sub _anon_cache_key {
107 my $superclass_key = join('|',
108 map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) }
111 my $roles = Data::OptList::mkopt(($options{roles} || []), {
113 val_test => sub { ref($_[0]) eq 'HASH' },
117 for my $role_spec (@$roles) {
118 my ($role, $params) = @$role_spec;
119 $params = { %$params } if $params;
121 my $key = blessed($role) ? $role->name : $role;
123 if ($params && %$params) {
124 my $alias = delete $params->{'-alias'}
125 || delete $params->{'alias'}
127 my $excludes = delete $params->{'-excludes'}
128 || delete $params->{'excludes'}
130 $excludes = [$excludes] unless ref($excludes) eq 'ARRAY';
133 warn "Roles with parameters cannot be cached. Consider "
134 . "applying the parameters before calling "
135 . "create_anon_class, or using 'weaken => 0' instead";
139 my $alias_key = join('%',
140 map { $_ => $alias->{$_} } sort keys %$alias
142 my $excludes_key = join('%',
145 $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>';
148 push @role_keys, $key;
151 my $role_key = join('|', sort @role_keys);
153 # Makes something like Super::Class|Super::Class::2=Role|Role::1
154 return join('=', $superclass_key, $role_key);
161 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
163 my %existing_classes;
165 %existing_classes = map { $_ => $meta->$_() } qw(
168 wrapped_method_metaclass
176 return $self->SUPER::reinitialize(
184 my ($self, $role) = @_;
185 (blessed($role) && $role->isa('Moose::Meta::Role'))
186 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
187 push @{$self->roles} => $role;
190 sub role_applications {
193 return @{$self->_get_role_applications};
196 sub add_role_application {
197 my ($self, $application) = @_;
198 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
199 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
200 push @{$self->_get_role_applications} => $application;
203 sub calculate_all_roles {
206 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
209 sub calculate_all_roles_with_inheritance {
212 grep { !$seen{$_->name}++ }
213 map { Class::MOP::class_of($_)->can('calculate_all_roles')
214 ? Class::MOP::class_of($_)->calculate_all_roles
216 $self->linearized_isa;
220 my ($self, $role_name) = @_;
223 || $self->throw_error("You must supply a role name to look for");
225 foreach my $class ($self->class_precedence_list) {
226 my $meta = Class::MOP::class_of($class);
227 # when a Moose metaclass is itself extended with a role,
228 # this check needs to be done since some items in the
229 # class_precedence_list might in fact be Class::MOP
231 next unless $meta && $meta->can('roles');
232 foreach my $role (@{$meta->roles}) {
233 return 1 if $role->does_role($role_name);
240 my ($self, $role_name) = @_;
243 || $self->throw_error("You must supply a role name to look for");
245 foreach my $class ($self->class_precedence_list) {
246 my $meta = Class::MOP::class_of($class);
247 # when a Moose metaclass is itself extended with a role,
248 # this check needs to be done since some items in the
249 # class_precedence_list might in fact be Class::MOP
251 next unless $meta && $meta->can('roles');
252 foreach my $role (@{$meta->roles}) {
253 return 1 if $role->excludes_role($role_name);
261 my $params = @_ == 1 ? $_[0] : {@_};
262 my $object = $self->SUPER::new_object($params);
264 foreach my $attr ( $self->get_all_attributes() ) {
266 next unless $attr->can('has_trigger') && $attr->has_trigger;
268 my $init_arg = $attr->init_arg;
270 next unless defined $init_arg;
272 next unless exists $params->{$init_arg};
278 ? $attr->get_read_method_ref->($object)
279 : $params->{$init_arg}
284 $object->BUILDALL($params) if $object->can('BUILDALL');
289 sub _generate_fallback_constructor {
292 return $class . '->Moose::Object::new(@_)'
297 my ($params, $class) = @_;
299 'my ' . $params . ' = ',
300 $self->_inline_BUILDARGS($class, '@_'),
305 sub _inline_BUILDARGS {
307 my ($class, $args) = @_;
309 my $buildargs = $self->find_method_by_name("BUILDARGS");
312 && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
316 'if (scalar @_ == 1) {',
317 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
318 $self->_inline_throw_error(
319 '"Single parameters to new() must be a HASH ref"',
323 '$params = { %{ $_[0] } };',
327 '"The new() method for ' . $class . ' expects a '
328 . 'hash reference or a key/value list. You passed an '
329 . 'odd number of arguments"',
331 '$params = {@_, undef};',
341 return $class . '->BUILDARGS(' . $args . ')';
345 sub _inline_slot_initializer {
347 my ($attr, $idx) = @_;
351 $self->_inline_check_required_attr($attr),
352 $self->SUPER::_inline_slot_initializer(@_),
356 sub _inline_check_required_attr {
360 return unless defined $attr->init_arg;
361 return unless $attr->can('is_required') && $attr->is_required;
362 return if $attr->has_default || $attr->has_builder;
365 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
366 $self->_inline_throw_error(
367 '"Attribute (' . quotemeta($attr->name) . ') is required"'
373 # XXX: these two are duplicated from cmop, because we have to pass the tc stuff
374 # through to _inline_set_value - this should probably be fixed, but i'm not
375 # quite sure how. -doy
376 sub _inline_init_attr_from_constructor {
378 my ($attr, $idx) = @_;
380 my @initial_value = $attr->_inline_set_value(
382 '$params->{\'' . $attr->init_arg . '\'}',
383 '$type_constraint_bodies[' . $idx . ']',
384 '$type_constraints[' . $idx . ']',
388 push @initial_value, (
389 '$attrs->[' . $idx . ']->set_initial_value(',
391 $attr->_inline_instance_get('$instance'),
393 ) if $attr->has_initializer;
395 return @initial_value;
398 sub _inline_init_attr_from_default {
400 my ($attr, $idx) = @_;
402 return if $attr->can('is_lazy') && $attr->is_lazy;
403 my $default = $self->_inline_default_value($attr, $idx);
404 return unless $default;
406 my @initial_value = (
407 'my $default = ' . $default . ';',
408 $attr->_inline_set_value(
411 '$type_constraint_bodies[' . $idx . ']',
412 '$type_constraints[' . $idx . ']',
417 push @initial_value, (
418 '$attrs->[' . $idx . ']->set_initial_value(',
420 $attr->_inline_instance_get('$instance'),
422 ) if $attr->has_initializer;
424 return @initial_value;
427 sub _inline_extra_init {
430 $self->_inline_triggers,
431 $self->_inline_BUILDALL,
435 sub _inline_triggers {
439 my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
440 for my $i (0 .. $#attrs) {
441 my $attr = $attrs[$i];
443 next unless $attr->can('has_trigger') && $attr->has_trigger;
445 my $init_arg = $attr->init_arg;
446 next unless defined $init_arg;
449 'if (exists $params->{\'' . $init_arg . '\'}) {',
450 '$attrs->[' . $i . ']->trigger->(',
452 $attr->_inline_instance_get('$instance') . ',',
457 return @trigger_calls;
460 sub _inline_BUILDALL {
463 my @methods = reverse $self->find_all_methods_by_name('BUILD');
466 foreach my $method (@methods) {
468 '$instance->' . $method->{class} . '::BUILD($params);';
476 my $supers = Data::OptList::mkopt(\@_);
477 foreach my $super (@{ $supers }) {
478 my ($name, $opts) = @{ $super };
479 Class::MOP::load_class($name, $opts);
480 my $meta = Class::MOP::class_of($name);
481 $self->throw_error("You cannot inherit from a Moose Role ($name)")
482 if $meta && $meta->isa('Moose::Meta::Role')
484 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
487 ### ---------------------------------------------
492 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
494 : $self->_process_attribute(@_));
495 $self->SUPER::add_attribute($attr);
496 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
497 # 'bare' and doesn't implement this method
498 if ($attr->can('_check_associated_methods')) {
499 $attr->_check_associated_methods;
504 sub add_override_method_modifier {
505 my ($self, $name, $method, $_super_package) = @_;
507 (!$self->has_method($name))
508 || $self->throw_error("Cannot add an override method if a local method is already present");
510 $self->add_method($name => Moose::Meta::Method::Overridden->new(
513 package => $_super_package, # need this for roles
518 sub add_augment_method_modifier {
519 my ($self, $name, $method) = @_;
520 (!$self->has_method($name))
521 || $self->throw_error("Cannot add an augment method if a local method is already present");
523 $self->add_method($name => Moose::Meta::Method::Augmented->new(
530 ## Private Utility methods ...
532 sub _find_next_method_by_name_which_is_not_overridden {
533 my ($self, $name) = @_;
534 foreach my $method ($self->find_all_methods_by_name($name)) {
535 return $method->{code}
536 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
541 ## Metaclass compatibility
543 sub _base_metaclasses {
545 my %metaclasses = $self->SUPER::_base_metaclasses;
546 for my $class (keys %metaclasses) {
547 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
551 error_class => 'Moose::Error::Default',
555 sub _fix_class_metaclass_incompatibility {
557 my ($super_meta) = @_;
559 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
561 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
563 || confess "Can't fix metaclass incompatibility for "
565 . " because it is not pristine.";
566 my $super_meta_name = $super_meta->_real_ref_name;
567 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
568 my $new_self = $class_meta_subclass_meta_name->reinitialize(
572 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
576 sub _fix_single_metaclass_incompatibility {
578 my ($metaclass_type, $super_meta) = @_;
580 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
582 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
584 || confess "Can't fix metaclass incompatibility for "
586 . " because it is not pristine.";
587 my $super_meta_name = $super_meta->_real_ref_name;
588 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
589 my $new_self = $super_meta->reinitialize(
591 $metaclass_type => $class_specific_meta_subclass_meta_name,
594 $self->_replace_self( $new_self, $super_meta_name );
600 my ( $new_self, $new_class) = @_;
603 bless $self, $new_class;
605 # We need to replace the cached metaclass instance or else when it goes
606 # out of scope Class::MOP::Class destroy's the namespace for the
607 # metaclass's class, causing much havoc.
608 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
609 Class::MOP::store_metaclass_by_name( $self->name, $self );
610 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
613 sub _process_attribute {
614 my ( $self, $name, @args ) = @_;
616 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
618 if (($name || '') =~ /^\+(.*)/) {
619 return $self->_process_inherited_attribute($1, @args);
622 return $self->_process_new_attribute($name, @args);
626 sub _process_new_attribute {
627 my ( $self, $name, @args ) = @_;
629 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
632 sub _process_inherited_attribute {
633 my ($self, $attr_name, %options) = @_;
634 my $inherited_attr = $self->find_attribute_by_name($attr_name);
635 (defined $inherited_attr)
636 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
637 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
638 return $inherited_attr->clone_and_inherit_options(%options);
642 # kind of a kludge to handle Class::MOP::Attributes
643 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
647 # reinitialization support
649 sub _restore_metaobjects_from {
653 $self->SUPER::_restore_metaobjects_from($old_meta);
655 for my $role ( @{ $old_meta->roles } ) {
656 $self->add_role($role);
659 for my $application ( @{ $old_meta->_get_role_applications } ) {
660 $application->class($self);
661 $self->add_role_application ($application);
667 sub _immutable_options {
668 my ( $self, @args ) = @_;
670 $self->SUPER::_immutable_options(
671 inline_destructor => 1,
673 # Moose always does this when an attribute is created
674 inline_accessors => 0,
680 ## -------------------------------------------------
685 my ( $self, @args ) = @_;
686 local $error_level = ($error_level || 0) + 1;
687 $self->raise_error($self->create_error(@args));
690 sub _inline_throw_error {
691 my ( $self, $msg, $args ) = @_;
692 "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
696 my ( $self, @args ) = @_;
701 my ( $self, @args ) = @_;
705 local $error_level = ($error_level || 0 ) + 1;
707 if ( @args % 2 == 1 ) {
708 unshift @args, "message";
711 my %args = ( metaclass => $self, last_error => $@, @args );
713 $args{depth} += $error_level;
715 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
717 Class::MOP::load_class($class);
720 Carp::caller_info($args{depth}),
727 # ABSTRACT: The Moose metaclass
735 This class is a subclass of L<Class::MOP::Class> that provides
736 additional Moose-specific functionality.
738 To really understand this class, you will need to start with the
739 L<Class::MOP::Class> documentation. This class can be understood as a
740 set of additional features on top of the basic feature provided by
745 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
751 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
753 This overrides the parent's method in order to provide its own
754 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
755 C<method_metaclass> options.
757 These all default to the appropriate Moose class.
759 =item B<< Moose::Meta::Class->create($package_name, %options) >>
761 This overrides the parent's method in order to accept a C<roles>
762 option. This should be an array reference containing roles
763 that the class does, each optionally followed by a hashref of options
764 (C<-excludes> and C<-alias>).
766 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
768 =item B<< Moose::Meta::Class->create_anon_class >>
770 This overrides the parent's method to accept a C<roles> option, just
773 It also accepts a C<cache> option. If this is true, then the anonymous
774 class will be cached based on its superclasses and roles. If an
775 existing anonymous class in the cache has the same superclasses and
776 roles, it will be reused.
778 my $metaclass = Moose::Meta::Class->create_anon_class(
779 superclasses => ['Foo'],
780 roles => [qw/Some Roles Go Here/],
784 Each entry in both the C<superclasses> and the C<roles> option can be
785 followed by a hash reference with arguments. The C<superclasses>
786 option can be supplied with a L<-version|Class::MOP/Class Loading
787 Options> option that ensures the loaded superclass satisfies the
788 required version. The C<role> option also takes the C<-version> as an
789 argument, but the option hash reference can also contain any other
790 role relevant values like exclusions or parameterized role arguments.
792 =item B<< $metaclass->make_immutable(%options) >>
794 This overrides the parent's method to add a few options. Specifically,
795 it uses the Moose-specific constructor and destructor classes, and
796 enables inlining the destructor.
798 Since Moose always inlines attributes, it sets the C<inline_accessors> option
801 =item B<< $metaclass->new_object(%params) >>
803 This overrides the parent's method in order to add support for
806 =item B<< $metaclass->superclasses(@superclasses) >>
808 This is the accessor allowing you to read or change the parents of
811 Each superclass can be followed by a hash reference containing a
812 L<-version|Class::MOP/Class Loading Options> value. If the version
813 requirement is not satisfied an error will be thrown.
815 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
817 This adds an C<override> method modifier to the package.
819 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
821 This adds an C<augment> method modifier to the package.
823 =item B<< $metaclass->calculate_all_roles >>
825 This will return a unique array of C<Moose::Meta::Role> instances
826 which are attached to this class.
828 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
830 This will return a unique array of C<Moose::Meta::Role> instances
831 which are attached to this class, and each of this class's ancestors.
833 =item B<< $metaclass->add_role($role) >>
835 This takes a L<Moose::Meta::Role> object, and adds it to the class's
836 list of roles. This I<does not> actually apply the role to the class.
838 =item B<< $metaclass->role_applications >>
840 Returns a list of L<Moose::Meta::Role::Application::ToClass>
841 objects, which contain the arguments to role application.
843 =item B<< $metaclass->add_role_application($application) >>
845 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
846 adds it to the class's list of role applications. This I<does not>
847 actually apply any role to the class; it is only for tracking role
850 =item B<< $metaclass->does_role($role) >>
852 This returns a boolean indicating whether or not the class does the specified
853 role. The role provided can be either a role name or a L<Moose::Meta::Role>
854 object. This tests both the class and its parents.
856 =item B<< $metaclass->excludes_role($role_name) >>
858 A class excludes a role if it has already composed a role which
859 excludes the named role. This tests both the class and its parents.
861 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
863 This overrides the parent's method in order to allow the parameters to
864 be provided as a hash reference.
866 =item B<< $metaclass->constructor_class($class_name) >>
868 =item B<< $metaclass->destructor_class($class_name) >>
870 These are the names of classes used when making a class immutable. These
871 default to L<Moose::Meta::Method::Constructor> and
872 L<Moose::Meta::Method::Destructor> respectively. These accessors are
873 read-write, so you can use them to change the class name.
875 =item B<< $metaclass->error_class($class_name) >>
877 The name of the class used to throw errors. This defaults to
878 L<Moose::Error::Default>, which generates an error with a stacktrace
879 just like C<Carp::confess>.
881 =item B<< $metaclass->throw_error($message, %extra) >>
883 Throws the error created by C<create_error> using C<raise_error>
889 See L<Moose/BUGS> for details on reporting bugs.