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, $idx) = @_;
345 $self->_inline_check_required_attr($attr),
346 $self->SUPER::_inline_slot_initializer(@_),
350 sub _inline_check_required_attr {
354 return unless defined $attr->init_arg;
355 return unless $attr->can('is_required') && $attr->is_required;
356 return if $attr->has_default || $attr->has_builder;
359 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
360 $self->_inline_throw_error(
361 '"Attribute (' . quotemeta($attr->name) . ') is required"'
367 sub _inline_init_attr_from_constructor {
369 my ($attr, $idx) = @_;
371 my @initial_value = $attr->_inline_set_value(
373 '$params->{\'' . $attr->init_arg . '\'}',
374 '$type_constraint_bodies[' . $idx . ']',
375 '$type_constraints[' . $idx . ']',
379 push @initial_value, (
380 '$attrs->[' . $idx . ']->set_initial_value(',
382 $attr->_inline_instance_get('$instance'),
384 ) if $attr->has_initializer;
386 return @initial_value;
389 sub _inline_init_attr_from_default {
391 my ($attr, $idx) = @_;
393 my $default = $self->_inline_default_value($attr, $idx);
394 return unless $default;
396 my @initial_value = (
397 'my $default = ' . $default . ';',
398 $attr->_inline_set_value(
401 '$type_constraint_bodies[' . $idx . ']',
402 '$type_constraints[' . $idx . ']',
407 push @initial_value, (
408 '$attrs->[' . $idx . ']->set_initial_value(',
410 $attr->_inline_instance_get('$instance'),
412 ) if $attr->has_initializer;
414 return @initial_value;
417 sub _inline_extra_init {
420 $self->_inline_triggers,
421 $self->_inline_BUILDALL,
425 sub _inline_triggers {
429 my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
430 for my $i (0 .. $#attrs) {
431 my $attr = $attrs[$i];
433 next unless $attr->can('has_trigger') && $attr->has_trigger;
435 my $init_arg = $attr->init_arg;
436 next unless defined $init_arg;
439 'if (exists $params->{\'' . $init_arg . '\'}) {',
440 '$attrs->[' . $i . ']->trigger->(',
442 $attr->_inline_instance_get('$instance') . ',',
447 return @trigger_calls;
450 sub _inline_BUILDALL {
453 my @methods = reverse $self->find_all_methods_by_name('BUILD');
456 foreach my $method (@methods) {
458 '$instance->' . $method->{class} . '::BUILD($params);';
466 my $supers = Data::OptList::mkopt(\@_);
467 foreach my $super (@{ $supers }) {
468 my ($name, $opts) = @{ $super };
469 Class::MOP::load_class($name, $opts);
470 my $meta = Class::MOP::class_of($name);
471 $self->throw_error("You cannot inherit from a Moose Role ($name)")
472 if $meta && $meta->isa('Moose::Meta::Role')
474 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
477 ### ---------------------------------------------
482 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
484 : $self->_process_attribute(@_));
485 $self->SUPER::add_attribute($attr);
486 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
487 # 'bare' and doesn't implement this method
488 if ($attr->can('_check_associated_methods')) {
489 $attr->_check_associated_methods;
494 sub add_override_method_modifier {
495 my ($self, $name, $method, $_super_package) = @_;
497 (!$self->has_method($name))
498 || $self->throw_error("Cannot add an override method if a local method is already present");
500 $self->add_method($name => Moose::Meta::Method::Overridden->new(
503 package => $_super_package, # need this for roles
508 sub add_augment_method_modifier {
509 my ($self, $name, $method) = @_;
510 (!$self->has_method($name))
511 || $self->throw_error("Cannot add an augment method if a local method is already present");
513 $self->add_method($name => Moose::Meta::Method::Augmented->new(
520 ## Private Utility methods ...
522 sub _find_next_method_by_name_which_is_not_overridden {
523 my ($self, $name) = @_;
524 foreach my $method ($self->find_all_methods_by_name($name)) {
525 return $method->{code}
526 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
531 ## Metaclass compatibility
533 sub _base_metaclasses {
535 my %metaclasses = $self->SUPER::_base_metaclasses;
536 for my $class (keys %metaclasses) {
537 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
541 error_class => 'Moose::Error::Default',
545 sub _fix_class_metaclass_incompatibility {
547 my ($super_meta) = @_;
549 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
551 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
553 || confess "Can't fix metaclass incompatibility for "
555 . " because it is not pristine.";
556 my $super_meta_name = $super_meta->_real_ref_name;
557 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
558 my $new_self = $class_meta_subclass_meta_name->reinitialize(
562 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
566 sub _fix_single_metaclass_incompatibility {
568 my ($metaclass_type, $super_meta) = @_;
570 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
572 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
574 || confess "Can't fix metaclass incompatibility for "
576 . " because it is not pristine.";
577 my $super_meta_name = $super_meta->_real_ref_name;
578 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
579 my $new_self = $super_meta->reinitialize(
581 $metaclass_type => $class_specific_meta_subclass_meta_name,
584 $self->_replace_self( $new_self, $super_meta_name );
590 my ( $new_self, $new_class) = @_;
593 bless $self, $new_class;
595 # We need to replace the cached metaclass instance or else when it goes
596 # out of scope Class::MOP::Class destroy's the namespace for the
597 # metaclass's class, causing much havoc.
598 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
599 Class::MOP::store_metaclass_by_name( $self->name, $self );
600 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
603 sub _process_attribute {
604 my ( $self, $name, @args ) = @_;
606 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
608 if (($name || '') =~ /^\+(.*)/) {
609 return $self->_process_inherited_attribute($1, @args);
612 return $self->_process_new_attribute($name, @args);
616 sub _process_new_attribute {
617 my ( $self, $name, @args ) = @_;
619 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
622 sub _process_inherited_attribute {
623 my ($self, $attr_name, %options) = @_;
624 my $inherited_attr = $self->find_attribute_by_name($attr_name);
625 (defined $inherited_attr)
626 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
627 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
628 return $inherited_attr->clone_and_inherit_options(%options);
632 # kind of a kludge to handle Class::MOP::Attributes
633 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
639 sub _immutable_options {
640 my ( $self, @args ) = @_;
642 $self->SUPER::_immutable_options(
643 inline_destructor => 1,
645 # Moose always does this when an attribute is created
646 inline_accessors => 0,
652 ## -------------------------------------------------
657 my ( $self, @args ) = @_;
658 local $error_level = ($error_level || 0) + 1;
659 $self->raise_error($self->create_error(@args));
662 sub _inline_throw_error {
663 my ( $self, $msg, $args ) = @_;
664 "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
668 my ( $self, @args ) = @_;
673 my ( $self, @args ) = @_;
677 local $error_level = ($error_level || 0 ) + 1;
679 if ( @args % 2 == 1 ) {
680 unshift @args, "message";
683 my %args = ( metaclass => $self, last_error => $@, @args );
685 $args{depth} += $error_level;
687 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
689 Class::MOP::load_class($class);
692 Carp::caller_info($args{depth}),
705 Moose::Meta::Class - The Moose metaclass
709 This class is a subclass of L<Class::MOP::Class> that provides
710 additional Moose-specific functionality.
712 To really understand this class, you will need to start with the
713 L<Class::MOP::Class> documentation. This class can be understood as a
714 set of additional features on top of the basic feature provided by
719 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
725 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
727 This overrides the parent's method in order to provide its own
728 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
729 C<method_metaclass> options.
731 These all default to the appropriate Moose class.
733 =item B<< Moose::Meta::Class->create($package_name, %options) >>
735 This overrides the parent's method in order to accept a C<roles>
736 option. This should be an array reference containing roles
737 that the class does, each optionally followed by a hashref of options
738 (C<-excludes> and C<-alias>).
740 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
742 =item B<< Moose::Meta::Class->create_anon_class >>
744 This overrides the parent's method to accept a C<roles> option, just
747 It also accepts a C<cache> option. If this is true, then the anonymous
748 class will be cached based on its superclasses and roles. If an
749 existing anonymous class in the cache has the same superclasses and
750 roles, it will be reused.
752 my $metaclass = Moose::Meta::Class->create_anon_class(
753 superclasses => ['Foo'],
754 roles => [qw/Some Roles Go Here/],
758 Each entry in both the C<superclasses> and the C<roles> option can be
759 followed by a hash reference with arguments. The C<superclasses>
760 option can be supplied with a L<-version|Class::MOP/Class Loading
761 Options> option that ensures the loaded superclass satisfies the
762 required version. The C<role> option also takes the C<-version> as an
763 argument, but the option hash reference can also contain any other
764 role relevant values like exclusions or parameterized role arguments.
766 =item B<< $metaclass->make_immutable(%options) >>
768 This overrides the parent's method to add a few options. Specifically,
769 it uses the Moose-specific constructor and destructor classes, and
770 enables inlining the destructor.
772 Since Moose always inlines attributes, it sets the C<inline_accessors> option
775 =item B<< $metaclass->new_object(%params) >>
777 This overrides the parent's method in order to add support for
780 =item B<< $metaclass->superclasses(@superclasses) >>
782 This is the accessor allowing you to read or change the parents of
785 Each superclass can be followed by a hash reference containing a
786 L<-version|Class::MOP/Class Loading Options> value. If the version
787 requirement is not satisfied an error will be thrown.
789 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
791 This adds an C<override> method modifier to the package.
793 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
795 This adds an C<augment> method modifier to the package.
797 =item B<< $metaclass->calculate_all_roles >>
799 This will return a unique array of C<Moose::Meta::Role> instances
800 which are attached to this class.
802 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
804 This will return a unique array of C<Moose::Meta::Role> instances
805 which are attached to this class, and each of this class's ancestors.
807 =item B<< $metaclass->add_role($role) >>
809 This takes a L<Moose::Meta::Role> object, and adds it to the class's
810 list of roles. This I<does not> actually apply the role to the class.
812 =item B<< $metaclass->role_applications >>
814 Returns a list of L<Moose::Meta::Role::Application::ToClass>
815 objects, which contain the arguments to role application.
817 =item B<< $metaclass->add_role_application($application) >>
819 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
820 adds it to the class's list of role applications. This I<does not>
821 actually apply any role to the class; it is only for tracking role
824 =item B<< $metaclass->does_role($role) >>
826 This returns a boolean indicating whether or not the class does the specified
827 role. The role provided can be either a role name or a L<Moose::Meta::Role>
828 object. This tests both the class and its parents.
830 =item B<< $metaclass->excludes_role($role_name) >>
832 A class excludes a role if it has already composed a role which
833 excludes the named role. This tests both the class and its parents.
835 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
837 This overrides the parent's method in order to allow the parameters to
838 be provided as a hash reference.
840 =item B<< $metaclass->constructor_class($class_name) >>
842 =item B<< $metaclass->destructor_class($class_name) >>
844 These are the names of classes used when making a class immutable. These
845 default to L<Moose::Meta::Method::Constructor> and
846 L<Moose::Meta::Method::Destructor> respectively. These accessors are
847 read-write, so you can use them to change the class name.
849 =item B<< $metaclass->error_class($class_name) >>
851 The name of the class used to throw errors. This defaults to
852 L<Moose::Error::Default>, which generates an error with a stacktrace
853 just like C<Carp::confess>.
855 =item B<< $metaclass->throw_error($message, %extra) >>
857 Throws the error created by C<create_error> using C<raise_error>
863 See L<Moose/BUGS> for details on reporting bugs.
867 Stevan Little E<lt>stevan@iinteractive.comE<gt>
869 =head1 COPYRIGHT AND LICENSE
871 Copyright 2006-2010 by Infinity Interactive, Inc.
873 L<http://www.iinteractive.com>
875 This library is free software; you can redistribute it and/or modify
876 it under the same terms as Perl itself.