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.19';
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;
25 use Moose::Meta::Method::Meta;
27 use Class::MOP::MiniTrait;
29 use base 'Class::MOP::Class';
31 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
33 __PACKAGE__->meta->add_attribute('roles' => (
38 __PACKAGE__->meta->add_attribute('role_applications' => (
39 reader => '_get_role_applications',
43 __PACKAGE__->meta->add_attribute(
44 Class::MOP::Attribute->new('immutable_trait' => (
45 accessor => "immutable_trait",
46 default => 'Moose::Meta::Class::Immutable::Trait',
50 __PACKAGE__->meta->add_attribute('constructor_class' => (
51 accessor => 'constructor_class',
52 default => 'Moose::Meta::Method::Constructor',
55 __PACKAGE__->meta->add_attribute('destructor_class' => (
56 accessor => 'destructor_class',
57 default => 'Moose::Meta::Method::Destructor',
60 __PACKAGE__->meta->add_attribute('error_class' => (
61 accessor => 'error_class',
62 default => 'Moose::Error::Default',
68 return Class::MOP::get_metaclass_by_name($pkg)
69 || $class->SUPER::initialize($pkg,
70 'attribute_metaclass' => 'Moose::Meta::Attribute',
71 'method_metaclass' => 'Moose::Meta::Method',
72 'instance_metaclass' => 'Moose::Meta::Instance',
78 my ($class, $package_name, %options) = @_;
80 (ref $options{roles} eq 'ARRAY')
81 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
82 if exists $options{roles};
83 my $roles = delete $options{roles};
85 my $new_meta = $class->SUPER::create($package_name, %options);
88 Moose::Util::apply_all_roles( $new_meta, @$roles );
96 sub create_anon_class {
97 my ($self, %options) = @_;
99 my $cache_ok = delete $options{cache};
102 = _anon_cache_key( $options{superclasses}, $options{roles} );
104 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
105 return $ANON_CLASSES{$cache_key};
108 $options{weaken} = !$cache_ok
109 unless exists $options{weaken};
111 my $new_class = $self->SUPER::create_anon_class(%options);
114 $ANON_CLASSES{$cache_key} = $new_class;
115 weaken($ANON_CLASSES{$cache_key});
121 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
123 sub _anon_cache_key {
124 # Makes something like Super::Class|Super::Class::2=Role|Role::1
126 join( '|', @{ $_[0] || [] } ),
127 join( '|', sort @{ $_[1] || [] } ),
135 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
139 my %existing_classes;
141 %existing_classes = map { $_ => $meta->$_() } qw(
144 wrapped_method_metaclass
151 $cache_key = _anon_cache_key(
152 [ $meta->superclasses ],
153 [ map { $_->name } @{ $meta->roles } ],
154 ) if $meta->is_anon_class;
157 my $new_meta = $self->SUPER::reinitialize(
163 return $new_meta unless defined $cache_key;
165 my $new_cache_key = _anon_cache_key(
166 [ $meta->superclasses ],
167 [ map { $_->name } @{ $meta->roles } ],
170 delete $ANON_CLASSES{$cache_key};
171 $ANON_CLASSES{$new_cache_key} = $new_meta;
172 weaken($ANON_CLASSES{$new_cache_key});
178 my ($self, $role) = @_;
179 (blessed($role) && $role->isa('Moose::Meta::Role'))
180 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
181 push @{$self->roles} => $role;
184 sub role_applications {
187 return @{$self->_get_role_applications};
190 sub add_role_application {
191 my ($self, $application) = @_;
192 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
193 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
194 push @{$self->_get_role_applications} => $application;
197 sub calculate_all_roles {
200 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
203 sub calculate_all_roles_with_inheritance {
206 grep { !$seen{$_->name}++ }
207 map { Class::MOP::class_of($_)->can('calculate_all_roles')
208 ? Class::MOP::class_of($_)->calculate_all_roles
210 $self->linearized_isa;
214 my ($self, $role_name) = @_;
217 || $self->throw_error("You must supply a role name to look for");
219 foreach my $class ($self->class_precedence_list) {
220 my $meta = Class::MOP::class_of($class);
221 # when a Moose metaclass is itself extended with a role,
222 # this check needs to be done since some items in the
223 # class_precedence_list might in fact be Class::MOP
225 next unless $meta && $meta->can('roles');
226 foreach my $role (@{$meta->roles}) {
227 return 1 if $role->does_role($role_name);
234 my ($self, $role_name) = @_;
237 || $self->throw_error("You must supply a role name to look for");
239 foreach my $class ($self->class_precedence_list) {
240 my $meta = Class::MOP::class_of($class);
241 # when a Moose metaclass is itself extended with a role,
242 # this check needs to be done since some items in the
243 # class_precedence_list might in fact be Class::MOP
245 next unless $meta && $meta->can('roles');
246 foreach my $role (@{$meta->roles}) {
247 return 1 if $role->excludes_role($role_name);
255 my $params = @_ == 1 ? $_[0] : {@_};
256 my $object = $self->SUPER::new_object($params);
258 foreach my $attr ( $self->get_all_attributes() ) {
260 next unless $attr->can('has_trigger') && $attr->has_trigger;
262 my $init_arg = $attr->init_arg;
264 next unless defined $init_arg;
266 next unless exists $params->{$init_arg};
272 ? $attr->get_read_method_ref->($object)
273 : $params->{$init_arg}
278 $object->BUILDALL($params) if $object->can('BUILDALL');
283 sub _generate_fallback_constructor {
286 return $class . '->Moose::Object::new(@_)'
291 my ($params, $class) = @_;
293 'my ' . $params . ' = ',
294 $self->_inline_BUILDARGS($class, '@_'),
299 sub _inline_BUILDARGS {
301 my ($class, $args) = @_;
303 my $buildargs = $self->find_method_by_name("BUILDARGS");
306 && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
310 'if (scalar @_ == 1) {',
311 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
312 $self->_inline_throw_error(
313 '"Single parameters to new() must be a HASH ref"',
317 '$params = { %{ $_[0] } };',
321 '"The new() method for ' . $class . ' expects a '
322 . 'hash reference or a key/value list. You passed an '
323 . 'odd number of arguments"',
325 '$params = {@_, undef};',
335 return $class . '->BUILDARGS(' . $args . ')';
339 sub _inline_slot_initializer {
341 my ($attr, $index) = @_;
343 my @source = ('## ' . $attr->name);
345 push @source, $self->_inline_check_required_attr($attr);
347 if (defined $attr->init_arg) {
349 'if (exists $params->{\'' . $attr->init_arg . '\'}) {',
350 $self->_inline_init_attr_from_constructor($attr, $index),
352 if (my @default = $self->_inline_init_attr_from_default($attr, $index)) {
360 if (my @default = $self->_inline_init_attr_from_default($attr, $index)) {
362 '{', # _init_attr_from_default creates variables
371 sub _inline_check_required_attr {
375 return unless defined $attr->init_arg;
376 return unless $attr->can('is_required') && $attr->is_required;
377 return if $attr->has_default || $attr->has_builder;
380 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
381 $self->_inline_throw_error(
382 '"Attribute (' . quotemeta($attr->name) . ') is required"'
388 sub _inline_init_attr_from_constructor {
390 my ($attr, $index) = @_;
393 'my $val = $params->{\'' . $attr->init_arg . '\'};',
394 $self->_inline_slot_assignment($attr, $index, '$val'),
398 sub _inline_init_attr_from_default {
400 my ($attr, $index) = @_;
402 my $default = $self->_inline_default_value($attr, $index);
403 return unless $default;
406 'my $val = ' . $default . ';',
407 $self->_inline_slot_assignment($attr, $index, '$val'),
411 sub _inline_slot_assignment {
413 my ($attr, $index, $value) = @_;
417 push @source, $self->_inline_type_constraint_and_coercion(
418 $attr, $index, $value,
421 if ($attr->has_initializer) {
423 '$attrs->[' . $index . ']->set_initial_value(',
431 $attr->_inline_instance_set('$instance', $value) . ';',
438 sub _inline_type_constraint_and_coercion {
440 my ($attr, $index, $value) = @_;
442 return unless $attr->can('has_type_constraint')
443 && $attr->has_type_constraint;
447 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
448 push @source => $self->_inline_type_coercion(
449 '$type_constraints[' . $index . ']',
455 push @source => $self->_inline_type_constraint_check(
457 '$type_constraint_bodies[' . $index . ']',
458 '$type_constraints[' . $index . ']',
465 sub _inline_type_coercion {
467 my ($tc_obj, $value, $return_value) = @_;
468 return $return_value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
471 sub _inline_type_constraint_check {
473 my ($attr, $tc_body, $tc_obj, $value) = @_;
475 $self->_inline_throw_error(
476 '"Attribute (' . quotemeta($attr->name) . ') '
477 . 'does not pass the type constraint because: " . '
478 . $tc_obj . '->get_message(' . $value . ')'
480 'unless ' . $tc_body . '->(' . $value . ');'
484 sub _inline_extra_init {
487 $self->_inline_triggers,
488 $self->_inline_BUILDALL,
492 sub _inline_triggers {
496 my @attrs = $self->get_all_attributes;
497 for my $i (0 .. $#attrs) {
498 my $attr = $attrs[$i];
500 next unless $attr->can('has_trigger') && $attr->has_trigger;
502 my $init_arg = $attr->init_arg;
503 next unless defined $init_arg;
506 'if (exists $params->{\'' . $init_arg . '\'}) {',
507 '$attrs->[' . $i . ']->trigger->(',
509 $attr->_inline_instance_get('$instance') . ',',
514 return @trigger_calls;
517 sub _inline_BUILDALL {
520 my @methods = reverse $self->find_all_methods_by_name('BUILD');
523 foreach my $method (@methods) {
525 '$instance->' . $method->{class} . '::BUILD($params);';
533 my $supers = Data::OptList::mkopt(\@_);
534 foreach my $super (@{ $supers }) {
535 my ($name, $opts) = @{ $super };
536 Class::MOP::load_class($name, $opts);
537 my $meta = Class::MOP::class_of($name);
538 $self->throw_error("You cannot inherit from a Moose Role ($name)")
539 if $meta && $meta->isa('Moose::Meta::Role')
541 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
544 ### ---------------------------------------------
549 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
551 : $self->_process_attribute(@_));
552 $self->SUPER::add_attribute($attr);
553 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
554 # 'bare' and doesn't implement this method
555 if ($attr->can('_check_associated_methods')) {
556 $attr->_check_associated_methods;
561 sub add_override_method_modifier {
562 my ($self, $name, $method, $_super_package) = @_;
564 (!$self->has_method($name))
565 || $self->throw_error("Cannot add an override method if a local method is already present");
567 $self->add_method($name => Moose::Meta::Method::Overridden->new(
570 package => $_super_package, # need this for roles
575 sub add_augment_method_modifier {
576 my ($self, $name, $method) = @_;
577 (!$self->has_method($name))
578 || $self->throw_error("Cannot add an augment method if a local method is already present");
580 $self->add_method($name => Moose::Meta::Method::Augmented->new(
587 ## Private Utility methods ...
589 sub _find_next_method_by_name_which_is_not_overridden {
590 my ($self, $name) = @_;
591 foreach my $method ($self->find_all_methods_by_name($name)) {
592 return $method->{code}
593 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
598 ## Metaclass compatibility
600 sub _base_metaclasses {
602 my %metaclasses = $self->SUPER::_base_metaclasses;
603 for my $class (keys %metaclasses) {
604 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
608 error_class => 'Moose::Error::Default',
612 sub _fix_class_metaclass_incompatibility {
614 my ($super_meta) = @_;
616 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
618 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
620 || confess "Can't fix metaclass incompatibility for "
622 . " because it is not pristine.";
623 my $super_meta_name = $super_meta->_real_ref_name;
624 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
625 my $new_self = $class_meta_subclass_meta_name->reinitialize(
629 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
633 sub _fix_single_metaclass_incompatibility {
635 my ($metaclass_type, $super_meta) = @_;
637 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
639 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
641 || confess "Can't fix metaclass incompatibility for "
643 . " because it is not pristine.";
644 my $super_meta_name = $super_meta->_real_ref_name;
645 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
646 my $new_self = $super_meta->reinitialize(
648 $metaclass_type => $class_specific_meta_subclass_meta_name,
651 $self->_replace_self( $new_self, $super_meta_name );
657 my ( $new_self, $new_class) = @_;
660 bless $self, $new_class;
662 # We need to replace the cached metaclass instance or else when it goes
663 # out of scope Class::MOP::Class destroy's the namespace for the
664 # metaclass's class, causing much havoc.
665 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
666 Class::MOP::store_metaclass_by_name( $self->name, $self );
667 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
670 sub _process_attribute {
671 my ( $self, $name, @args ) = @_;
673 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
675 if (($name || '') =~ /^\+(.*)/) {
676 return $self->_process_inherited_attribute($1, @args);
679 return $self->_process_new_attribute($name, @args);
683 sub _process_new_attribute {
684 my ( $self, $name, @args ) = @_;
686 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
689 sub _process_inherited_attribute {
690 my ($self, $attr_name, %options) = @_;
691 my $inherited_attr = $self->find_attribute_by_name($attr_name);
692 (defined $inherited_attr)
693 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
694 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
695 return $inherited_attr->clone_and_inherit_options(%options);
699 # kind of a kludge to handle Class::MOP::Attributes
700 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
706 sub _immutable_options {
707 my ( $self, @args ) = @_;
709 $self->SUPER::_immutable_options(
710 inline_destructor => 1,
712 # Moose always does this when an attribute is created
713 inline_accessors => 0,
719 ## -------------------------------------------------
724 my ( $self, @args ) = @_;
725 local $error_level = ($error_level || 0) + 1;
726 $self->raise_error($self->create_error(@args));
729 sub _inline_throw_error {
730 my ( $self, $msg, $args ) = @_;
731 "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
735 my ( $self, @args ) = @_;
740 my ( $self, @args ) = @_;
744 local $error_level = ($error_level || 0 ) + 1;
746 if ( @args % 2 == 1 ) {
747 unshift @args, "message";
750 my %args = ( metaclass => $self, last_error => $@, @args );
752 $args{depth} += $error_level;
754 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
756 Class::MOP::load_class($class);
759 Carp::caller_info($args{depth}),
772 Moose::Meta::Class - The Moose metaclass
776 This class is a subclass of L<Class::MOP::Class> that provides
777 additional Moose-specific functionality.
779 To really understand this class, you will need to start with the
780 L<Class::MOP::Class> documentation. This class can be understood as a
781 set of additional features on top of the basic feature provided by
786 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
792 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
794 This overrides the parent's method in order to provide its own
795 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
796 C<method_metaclass> options.
798 These all default to the appropriate Moose class.
800 =item B<< Moose::Meta::Class->create($package_name, %options) >>
802 This overrides the parent's method in order to accept a C<roles>
803 option. This should be an array reference containing roles
804 that the class does, each optionally followed by a hashref of options
805 (C<-excludes> and C<-alias>).
807 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
809 =item B<< Moose::Meta::Class->create_anon_class >>
811 This overrides the parent's method to accept a C<roles> option, just
814 It also accepts a C<cache> option. If this is true, then the anonymous
815 class will be cached based on its superclasses and roles. If an
816 existing anonymous class in the cache has the same superclasses and
817 roles, it will be reused.
819 my $metaclass = Moose::Meta::Class->create_anon_class(
820 superclasses => ['Foo'],
821 roles => [qw/Some Roles Go Here/],
825 Each entry in both the C<superclasses> and the C<roles> option can be
826 followed by a hash reference with arguments. The C<superclasses>
827 option can be supplied with a L<-version|Class::MOP/Class Loading
828 Options> option that ensures the loaded superclass satisfies the
829 required version. The C<role> option also takes the C<-version> as an
830 argument, but the option hash reference can also contain any other
831 role relevant values like exclusions or parameterized role arguments.
833 =item B<< $metaclass->make_immutable(%options) >>
835 This overrides the parent's method to add a few options. Specifically,
836 it uses the Moose-specific constructor and destructor classes, and
837 enables inlining the destructor.
839 Since Moose always inlines attributes, it sets the C<inline_accessors> option
842 =item B<< $metaclass->new_object(%params) >>
844 This overrides the parent's method in order to add support for
847 =item B<< $metaclass->superclasses(@superclasses) >>
849 This is the accessor allowing you to read or change the parents of
852 Each superclass can be followed by a hash reference containing a
853 L<-version|Class::MOP/Class Loading Options> value. If the version
854 requirement is not satisfied an error will be thrown.
856 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
858 This adds an C<override> method modifier to the package.
860 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
862 This adds an C<augment> method modifier to the package.
864 =item B<< $metaclass->calculate_all_roles >>
866 This will return a unique array of C<Moose::Meta::Role> instances
867 which are attached to this class.
869 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
871 This will return a unique array of C<Moose::Meta::Role> instances
872 which are attached to this class, and each of this class's ancestors.
874 =item B<< $metaclass->add_role($role) >>
876 This takes a L<Moose::Meta::Role> object, and adds it to the class's
877 list of roles. This I<does not> actually apply the role to the class.
879 =item B<< $metaclass->role_applications >>
881 Returns a list of L<Moose::Meta::Role::Application::ToClass>
882 objects, which contain the arguments to role application.
884 =item B<< $metaclass->add_role_application($application) >>
886 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
887 adds it to the class's list of role applications. This I<does not>
888 actually apply any role to the class; it is only for tracking role
891 =item B<< $metaclass->does_role($role) >>
893 This returns a boolean indicating whether or not the class does the specified
894 role. The role provided can be either a role name or a L<Moose::Meta::Role>
895 object. This tests both the class and its parents.
897 =item B<< $metaclass->excludes_role($role_name) >>
899 A class excludes a role if it has already composed a role which
900 excludes the named role. This tests both the class and its parents.
902 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
904 This overrides the parent's method in order to allow the parameters to
905 be provided as a hash reference.
907 =item B<< $metaclass->constructor_class($class_name) >>
909 =item B<< $metaclass->destructor_class($class_name) >>
911 These are the names of classes used when making a class immutable. These
912 default to L<Moose::Meta::Method::Constructor> and
913 L<Moose::Meta::Method::Destructor> respectively. These accessors are
914 read-write, so you can use them to change the class name.
916 =item B<< $metaclass->error_class($class_name) >>
918 The name of the class used to throw errors. This defaults to
919 L<Moose::Error::Default>, which generates an error with a stacktrace
920 just like C<Carp::confess>.
922 =item B<< $metaclass->throw_error($message, %extra) >>
924 Throws the error created by C<create_error> using C<raise_error>
930 See L<Moose/BUGS> for details on reporting bugs.
934 Stevan Little E<lt>stevan@iinteractive.comE<gt>
936 =head1 COPYRIGHT AND LICENSE
938 Copyright 2006-2010 by Infinity Interactive, Inc.
940 L<http://www.iinteractive.com>
942 This library is free software; you can redistribute it and/or modify
943 it under the same terms as Perl itself.