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.9900';
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 # XXX: these two are duplicated from cmop, because we have to pass the tc stuff
368 # through to _inline_set_value - this should probably be fixed, but i'm not
369 # quite sure how. -doy
370 sub _inline_init_attr_from_constructor {
372 my ($attr, $idx) = @_;
374 my @initial_value = $attr->_inline_set_value(
376 '$params->{\'' . $attr->init_arg . '\'}',
377 '$type_constraint_bodies[' . $idx . ']',
378 '$type_constraints[' . $idx . ']',
382 push @initial_value, (
383 '$attrs->[' . $idx . ']->set_initial_value(',
385 $attr->_inline_instance_get('$instance'),
387 ) if $attr->has_initializer;
389 return @initial_value;
392 sub _inline_init_attr_from_default {
394 my ($attr, $idx) = @_;
396 my $default = $self->_inline_default_value($attr, $idx);
397 return unless $default;
399 my @initial_value = (
400 'my $default = ' . $default . ';',
401 $attr->_inline_set_value(
404 '$type_constraint_bodies[' . $idx . ']',
405 '$type_constraints[' . $idx . ']',
410 push @initial_value, (
411 '$attrs->[' . $idx . ']->set_initial_value(',
413 $attr->_inline_instance_get('$instance'),
415 ) if $attr->has_initializer;
417 return @initial_value;
420 sub _inline_extra_init {
423 $self->_inline_triggers,
424 $self->_inline_BUILDALL,
428 sub _inline_triggers {
432 my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
433 for my $i (0 .. $#attrs) {
434 my $attr = $attrs[$i];
436 next unless $attr->can('has_trigger') && $attr->has_trigger;
438 my $init_arg = $attr->init_arg;
439 next unless defined $init_arg;
442 'if (exists $params->{\'' . $init_arg . '\'}) {',
443 '$attrs->[' . $i . ']->trigger->(',
445 $attr->_inline_instance_get('$instance') . ',',
450 return @trigger_calls;
453 sub _inline_BUILDALL {
456 my @methods = reverse $self->find_all_methods_by_name('BUILD');
459 foreach my $method (@methods) {
461 '$instance->' . $method->{class} . '::BUILD($params);';
469 my $supers = Data::OptList::mkopt(\@_);
470 foreach my $super (@{ $supers }) {
471 my ($name, $opts) = @{ $super };
472 Class::MOP::load_class($name, $opts);
473 my $meta = Class::MOP::class_of($name);
474 $self->throw_error("You cannot inherit from a Moose Role ($name)")
475 if $meta && $meta->isa('Moose::Meta::Role')
477 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
480 ### ---------------------------------------------
485 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
487 : $self->_process_attribute(@_));
488 $self->SUPER::add_attribute($attr);
489 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
490 # 'bare' and doesn't implement this method
491 if ($attr->can('_check_associated_methods')) {
492 $attr->_check_associated_methods;
497 sub add_override_method_modifier {
498 my ($self, $name, $method, $_super_package) = @_;
500 (!$self->has_method($name))
501 || $self->throw_error("Cannot add an override method if a local method is already present");
503 $self->add_method($name => Moose::Meta::Method::Overridden->new(
506 package => $_super_package, # need this for roles
511 sub add_augment_method_modifier {
512 my ($self, $name, $method) = @_;
513 (!$self->has_method($name))
514 || $self->throw_error("Cannot add an augment method if a local method is already present");
516 $self->add_method($name => Moose::Meta::Method::Augmented->new(
523 ## Private Utility methods ...
525 sub _find_next_method_by_name_which_is_not_overridden {
526 my ($self, $name) = @_;
527 foreach my $method ($self->find_all_methods_by_name($name)) {
528 return $method->{code}
529 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
534 ## Metaclass compatibility
536 sub _base_metaclasses {
538 my %metaclasses = $self->SUPER::_base_metaclasses;
539 for my $class (keys %metaclasses) {
540 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
544 error_class => 'Moose::Error::Default',
548 sub _fix_class_metaclass_incompatibility {
550 my ($super_meta) = @_;
552 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
554 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
556 || confess "Can't fix metaclass incompatibility for "
558 . " because it is not pristine.";
559 my $super_meta_name = $super_meta->_real_ref_name;
560 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
561 my $new_self = $class_meta_subclass_meta_name->reinitialize(
565 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
569 sub _fix_single_metaclass_incompatibility {
571 my ($metaclass_type, $super_meta) = @_;
573 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
575 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
577 || confess "Can't fix metaclass incompatibility for "
579 . " because it is not pristine.";
580 my $super_meta_name = $super_meta->_real_ref_name;
581 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
582 my $new_self = $super_meta->reinitialize(
584 $metaclass_type => $class_specific_meta_subclass_meta_name,
587 $self->_replace_self( $new_self, $super_meta_name );
593 my ( $new_self, $new_class) = @_;
596 bless $self, $new_class;
598 # We need to replace the cached metaclass instance or else when it goes
599 # out of scope Class::MOP::Class destroy's the namespace for the
600 # metaclass's class, causing much havoc.
601 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
602 Class::MOP::store_metaclass_by_name( $self->name, $self );
603 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
606 sub _process_attribute {
607 my ( $self, $name, @args ) = @_;
609 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
611 if (($name || '') =~ /^\+(.*)/) {
612 return $self->_process_inherited_attribute($1, @args);
615 return $self->_process_new_attribute($name, @args);
619 sub _process_new_attribute {
620 my ( $self, $name, @args ) = @_;
622 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
625 sub _process_inherited_attribute {
626 my ($self, $attr_name, %options) = @_;
627 my $inherited_attr = $self->find_attribute_by_name($attr_name);
628 (defined $inherited_attr)
629 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
630 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
631 return $inherited_attr->clone_and_inherit_options(%options);
635 # kind of a kludge to handle Class::MOP::Attributes
636 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
642 sub _immutable_options {
643 my ( $self, @args ) = @_;
645 $self->SUPER::_immutable_options(
646 inline_destructor => 1,
648 # Moose always does this when an attribute is created
649 inline_accessors => 0,
655 ## -------------------------------------------------
660 my ( $self, @args ) = @_;
661 local $error_level = ($error_level || 0) + 1;
662 $self->raise_error($self->create_error(@args));
665 sub _inline_throw_error {
666 my ( $self, $msg, $args ) = @_;
667 "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
671 my ( $self, @args ) = @_;
676 my ( $self, @args ) = @_;
680 local $error_level = ($error_level || 0 ) + 1;
682 if ( @args % 2 == 1 ) {
683 unshift @args, "message";
686 my %args = ( metaclass => $self, last_error => $@, @args );
688 $args{depth} += $error_level;
690 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
692 Class::MOP::load_class($class);
695 Carp::caller_info($args{depth}),
708 Moose::Meta::Class - The Moose metaclass
712 This class is a subclass of L<Class::MOP::Class> that provides
713 additional Moose-specific functionality.
715 To really understand this class, you will need to start with the
716 L<Class::MOP::Class> documentation. This class can be understood as a
717 set of additional features on top of the basic feature provided by
722 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
728 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
730 This overrides the parent's method in order to provide its own
731 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
732 C<method_metaclass> options.
734 These all default to the appropriate Moose class.
736 =item B<< Moose::Meta::Class->create($package_name, %options) >>
738 This overrides the parent's method in order to accept a C<roles>
739 option. This should be an array reference containing roles
740 that the class does, each optionally followed by a hashref of options
741 (C<-excludes> and C<-alias>).
743 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
745 =item B<< Moose::Meta::Class->create_anon_class >>
747 This overrides the parent's method to accept a C<roles> option, just
750 It also accepts a C<cache> option. If this is true, then the anonymous
751 class will be cached based on its superclasses and roles. If an
752 existing anonymous class in the cache has the same superclasses and
753 roles, it will be reused.
755 my $metaclass = Moose::Meta::Class->create_anon_class(
756 superclasses => ['Foo'],
757 roles => [qw/Some Roles Go Here/],
761 Each entry in both the C<superclasses> and the C<roles> option can be
762 followed by a hash reference with arguments. The C<superclasses>
763 option can be supplied with a L<-version|Class::MOP/Class Loading
764 Options> option that ensures the loaded superclass satisfies the
765 required version. The C<role> option also takes the C<-version> as an
766 argument, but the option hash reference can also contain any other
767 role relevant values like exclusions or parameterized role arguments.
769 =item B<< $metaclass->make_immutable(%options) >>
771 This overrides the parent's method to add a few options. Specifically,
772 it uses the Moose-specific constructor and destructor classes, and
773 enables inlining the destructor.
775 Since Moose always inlines attributes, it sets the C<inline_accessors> option
778 =item B<< $metaclass->new_object(%params) >>
780 This overrides the parent's method in order to add support for
783 =item B<< $metaclass->superclasses(@superclasses) >>
785 This is the accessor allowing you to read or change the parents of
788 Each superclass can be followed by a hash reference containing a
789 L<-version|Class::MOP/Class Loading Options> value. If the version
790 requirement is not satisfied an error will be thrown.
792 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
794 This adds an C<override> method modifier to the package.
796 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
798 This adds an C<augment> method modifier to the package.
800 =item B<< $metaclass->calculate_all_roles >>
802 This will return a unique array of C<Moose::Meta::Role> instances
803 which are attached to this class.
805 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
807 This will return a unique array of C<Moose::Meta::Role> instances
808 which are attached to this class, and each of this class's ancestors.
810 =item B<< $metaclass->add_role($role) >>
812 This takes a L<Moose::Meta::Role> object, and adds it to the class's
813 list of roles. This I<does not> actually apply the role to the class.
815 =item B<< $metaclass->role_applications >>
817 Returns a list of L<Moose::Meta::Role::Application::ToClass>
818 objects, which contain the arguments to role application.
820 =item B<< $metaclass->add_role_application($application) >>
822 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
823 adds it to the class's list of role applications. This I<does not>
824 actually apply any role to the class; it is only for tracking role
827 =item B<< $metaclass->does_role($role) >>
829 This returns a boolean indicating whether or not the class does the specified
830 role. The role provided can be either a role name or a L<Moose::Meta::Role>
831 object. This tests both the class and its parents.
833 =item B<< $metaclass->excludes_role($role_name) >>
835 A class excludes a role if it has already composed a role which
836 excludes the named role. This tests both the class and its parents.
838 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
840 This overrides the parent's method in order to allow the parameters to
841 be provided as a hash reference.
843 =item B<< $metaclass->constructor_class($class_name) >>
845 =item B<< $metaclass->destructor_class($class_name) >>
847 These are the names of classes used when making a class immutable. These
848 default to L<Moose::Meta::Method::Constructor> and
849 L<Moose::Meta::Method::Destructor> respectively. These accessors are
850 read-write, so you can use them to change the class name.
852 =item B<< $metaclass->error_class($class_name) >>
854 The name of the class used to throw errors. This defaults to
855 L<Moose::Error::Default>, which generates an error with a stacktrace
856 just like C<Carp::confess>.
858 =item B<< $metaclass->throw_error($message, %extra) >>
860 Throws the error created by C<create_error> using C<raise_error>
866 See L<Moose/BUGS> for details on reporting bugs.
870 Stevan Little E<lt>stevan@iinteractive.comE<gt>
872 =head1 COPYRIGHT AND LICENSE
874 Copyright 2006-2010 by Infinity Interactive, Inc.
876 L<http://www.iinteractive.com>
878 This library is free software; you can redistribute it and/or modify
879 it under the same terms as Perl itself.