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.15';
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 my $new_class = $self->SUPER::create_anon_class(%options);
110 $ANON_CLASSES{$cache_key} = $new_class
116 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
118 sub _anon_cache_key {
119 # Makes something like Super::Class|Super::Class::2=Role|Role::1
121 join( '|', @{ $_[0] || [] } ),
122 join( '|', sort @{ $_[1] || [] } ),
130 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
134 my %existing_classes;
136 %existing_classes = map { $_ => $meta->$_() } qw(
139 wrapped_method_metaclass
146 $cache_key = _anon_cache_key(
147 [ $meta->superclasses ],
148 [ map { $_->name } @{ $meta->roles } ],
149 ) if $meta->is_anon_class;
152 my $new_meta = $self->SUPER::reinitialize(
158 return $new_meta unless defined $cache_key;
160 my $new_cache_key = _anon_cache_key(
161 [ $meta->superclasses ],
162 [ map { $_->name } @{ $meta->roles } ],
165 delete $ANON_CLASSES{$cache_key};
166 $ANON_CLASSES{$new_cache_key} = $new_meta;
172 my ($self, $role) = @_;
173 (blessed($role) && $role->isa('Moose::Meta::Role'))
174 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
175 push @{$self->roles} => $role;
178 sub role_applications {
181 return @{$self->_get_role_applications};
184 sub add_role_application {
185 my ($self, $application) = @_;
186 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
187 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
188 push @{$self->_get_role_applications} => $application;
191 sub calculate_all_roles {
194 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
197 sub calculate_all_roles_with_inheritance {
200 grep { !$seen{$_->name}++ }
201 map { Class::MOP::class_of($_)->can('calculate_all_roles')
202 ? Class::MOP::class_of($_)->calculate_all_roles
204 $self->linearized_isa;
208 my ($self, $role_name) = @_;
211 || $self->throw_error("You must supply a role name to look for");
213 foreach my $class ($self->class_precedence_list) {
214 my $meta = Class::MOP::class_of($class);
215 # when a Moose metaclass is itself extended with a role,
216 # this check needs to be done since some items in the
217 # class_precedence_list might in fact be Class::MOP
219 next unless $meta && $meta->can('roles');
220 foreach my $role (@{$meta->roles}) {
221 return 1 if $role->does_role($role_name);
228 my ($self, $role_name) = @_;
231 || $self->throw_error("You must supply a role name to look for");
233 foreach my $class ($self->class_precedence_list) {
234 my $meta = Class::MOP::class_of($class);
235 # when a Moose metaclass is itself extended with a role,
236 # this check needs to be done since some items in the
237 # class_precedence_list might in fact be Class::MOP
239 next unless $meta && $meta->can('roles');
240 foreach my $role (@{$meta->roles}) {
241 return 1 if $role->excludes_role($role_name);
249 my $params = @_ == 1 ? $_[0] : {@_};
250 my $object = $self->SUPER::new_object($params);
252 foreach my $attr ( $self->get_all_attributes() ) {
254 next unless $attr->can('has_trigger') && $attr->has_trigger;
256 my $init_arg = $attr->init_arg;
258 next unless defined $init_arg;
260 next unless exists $params->{$init_arg};
266 ? $attr->get_read_method_ref->($object)
267 : $params->{$init_arg}
272 $object->BUILDALL($params) if $object->can('BUILDALL');
279 my $supers = Data::OptList::mkopt(\@_);
280 foreach my $super (@{ $supers }) {
281 my ($name, $opts) = @{ $super };
282 Class::MOP::load_class($name, $opts);
283 my $meta = Class::MOP::class_of($name);
284 $self->throw_error("You cannot inherit from a Moose Role ($name)")
285 if $meta && $meta->isa('Moose::Meta::Role')
287 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
290 ### ---------------------------------------------
295 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
297 : $self->_process_attribute(@_));
298 $self->SUPER::add_attribute($attr);
299 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
300 # 'bare' and doesn't implement this method
301 if ($attr->can('_check_associated_methods')) {
302 $attr->_check_associated_methods;
307 sub add_override_method_modifier {
308 my ($self, $name, $method, $_super_package) = @_;
310 (!$self->has_method($name))
311 || $self->throw_error("Cannot add an override method if a local method is already present");
313 $self->add_method($name => Moose::Meta::Method::Overridden->new(
316 package => $_super_package, # need this for roles
321 sub add_augment_method_modifier {
322 my ($self, $name, $method) = @_;
323 (!$self->has_method($name))
324 || $self->throw_error("Cannot add an augment method if a local method is already present");
326 $self->add_method($name => Moose::Meta::Method::Augmented->new(
333 ## Private Utility methods ...
335 sub _find_next_method_by_name_which_is_not_overridden {
336 my ($self, $name) = @_;
337 foreach my $method ($self->find_all_methods_by_name($name)) {
338 return $method->{code}
339 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
344 ## Metaclass compatibility
346 sub _base_metaclasses {
348 my %metaclasses = $self->SUPER::_base_metaclasses;
349 for my $class (keys %metaclasses) {
350 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
354 error_class => 'Moose::Error::Default',
358 sub _fix_class_metaclass_incompatibility {
360 my ($super_meta) = @_;
362 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
364 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
366 || confess "Can't fix metaclass incompatibility for "
368 . " because it is not pristine.";
369 my $super_meta_name = $super_meta->_real_ref_name;
370 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
371 my $new_self = $class_meta_subclass_meta_name->reinitialize(
375 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
379 sub _fix_single_metaclass_incompatibility {
381 my ($metaclass_type, $super_meta) = @_;
383 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
385 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
387 || confess "Can't fix metaclass incompatibility for "
389 . " because it is not pristine.";
390 my $super_meta_name = $super_meta->_real_ref_name;
391 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
392 my $new_self = $super_meta->reinitialize(
394 $metaclass_type => $class_specific_meta_subclass_meta_name,
397 $self->_replace_self( $new_self, $super_meta_name );
403 my ( $new_self, $new_class) = @_;
406 bless $self, $new_class;
408 # We need to replace the cached metaclass instance or else when it goes
409 # out of scope Class::MOP::Class destroy's the namespace for the
410 # metaclass's class, causing much havoc.
411 Class::MOP::store_metaclass_by_name( $self->name, $self );
412 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
415 sub _process_attribute {
416 my ( $self, $name, @args ) = @_;
418 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
420 if (($name || '') =~ /^\+(.*)/) {
421 return $self->_process_inherited_attribute($1, @args);
424 return $self->_process_new_attribute($name, @args);
428 sub _process_new_attribute {
429 my ( $self, $name, @args ) = @_;
431 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
434 sub _process_inherited_attribute {
435 my ($self, $attr_name, %options) = @_;
436 my $inherited_attr = $self->find_attribute_by_name($attr_name);
437 (defined $inherited_attr)
438 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
439 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
440 return $inherited_attr->clone_and_inherit_options(%options);
444 # kind of a kludge to handle Class::MOP::Attributes
445 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
451 sub _immutable_options {
452 my ( $self, @args ) = @_;
454 $self->SUPER::_immutable_options(
455 inline_destructor => 1,
457 # Moose always does this when an attribute is created
458 inline_accessors => 0,
464 ## -------------------------------------------------
469 my ( $self, @args ) = @_;
470 local $error_level = ($error_level || 0) + 1;
471 $self->raise_error($self->create_error(@args));
475 my ( $self, @args ) = @_;
480 my ( $self, @args ) = @_;
484 local $error_level = ($error_level || 0 ) + 1;
486 if ( @args % 2 == 1 ) {
487 unshift @args, "message";
490 my %args = ( metaclass => $self, last_error => $@, @args );
492 $args{depth} += $error_level;
494 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
496 Class::MOP::load_class($class);
499 Carp::caller_info($args{depth}),
512 Moose::Meta::Class - The Moose metaclass
516 This class is a subclass of L<Class::MOP::Class> that provides
517 additional Moose-specific functionality.
519 To really understand this class, you will need to start with the
520 L<Class::MOP::Class> documentation. This class can be understood as a
521 set of additional features on top of the basic feature provided by
526 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
532 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
534 This overrides the parent's method in order to provide its own
535 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
536 C<method_metaclass> options.
538 These all default to the appropriate Moose class.
540 =item B<< Moose::Meta::Class->create($package_name, %options) >>
542 This overrides the parent's method in order to accept a C<roles>
543 option. This should be an array reference containing roles
544 that the class does, each optionally followed by a hashref of options
545 (C<-excludes> and C<-alias>).
547 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
549 =item B<< Moose::Meta::Class->create_anon_class >>
551 This overrides the parent's method to accept a C<roles> option, just
554 It also accepts a C<cache> option. If this is true, then the anonymous
555 class will be cached based on its superclasses and roles. If an
556 existing anonymous class in the cache has the same superclasses and
557 roles, it will be reused.
559 my $metaclass = Moose::Meta::Class->create_anon_class(
560 superclasses => ['Foo'],
561 roles => [qw/Some Roles Go Here/],
565 Each entry in both the C<superclasses> and the C<roles> option can be
566 followed by a hash reference with arguments. The C<superclasses>
567 option can be supplied with a L<-version|Class::MOP/Class Loading
568 Options> option that ensures the loaded superclass satisfies the
569 required version. The C<role> option also takes the C<-version> as an
570 argument, but the option hash reference can also contain any other
571 role relevant values like exclusions or parameterized role arguments.
573 =item B<< $metaclass->make_immutable(%options) >>
575 This overrides the parent's method to add a few options. Specifically,
576 it uses the Moose-specific constructor and destructor classes, and
577 enables inlining the destructor.
579 Since Moose always inlines attributes, it sets the C<inline_accessors> option
582 =item B<< $metaclass->new_object(%params) >>
584 This overrides the parent's method in order to add support for
587 =item B<< $metaclass->superclasses(@superclasses) >>
589 This is the accessor allowing you to read or change the parents of
592 Each superclass can be followed by a hash reference containing a
593 L<-version|Class::MOP/Class Loading Options> value. If the version
594 requirement is not satisfied an error will be thrown.
596 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
598 This adds an C<override> method modifier to the package.
600 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
602 This adds an C<augment> method modifier to the package.
604 =item B<< $metaclass->calculate_all_roles >>
606 This will return a unique array of C<Moose::Meta::Role> instances
607 which are attached to this class.
609 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
611 This will return a unique array of C<Moose::Meta::Role> instances
612 which are attached to this class, and each of this class's ancestors.
614 =item B<< $metaclass->add_role($role) >>
616 This takes a L<Moose::Meta::Role> object, and adds it to the class's
617 list of roles. This I<does not> actually apply the role to the class.
619 =item B<< $metaclass->role_applications >>
621 Returns a list of L<Moose::Meta::Role::Application::ToClass>
622 objects, which contain the arguments to role application.
624 =item B<< $metaclass->add_role_application($application) >>
626 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
627 adds it to the class's list of role applications. This I<does not>
628 actually apply any role to the class; it is only for tracking role
631 =item B<< $metaclass->does_role($role) >>
633 This returns a boolean indicating whether or not the class does the specified
634 role. The role provided can be either a role name or a L<Moose::Meta::Role>
635 object. This tests both the class and its parents.
637 =item B<< $metaclass->excludes_role($role_name) >>
639 A class excludes a role if it has already composed a role which
640 excludes the named role. This tests both the class and its parents.
642 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
644 This overrides the parent's method in order to allow the parameters to
645 be provided as a hash reference.
647 =item B<< $metaclass->constructor_class($class_name) >>
649 =item B<< $metaclass->destructor_class($class_name) >>
651 These are the names of classes used when making a class immutable. These
652 default to L<Moose::Meta::Method::Constructor> and
653 L<Moose::Meta::Method::Destructor> respectively. These accessors are
654 read-write, so you can use them to change the class name.
656 =item B<< $metaclass->error_class($class_name) >>
658 The name of the class used to throw errors. This defaults to
659 L<Moose::Error::Default>, which generates an error with a stacktrace
660 just like C<Carp::confess>.
662 =item B<< $metaclass->throw_error($message, %extra) >>
664 Throws the error created by C<create_error> using C<raise_error>
670 See L<Moose/BUGS> for details on reporting bugs.
674 Stevan Little E<lt>stevan@iinteractive.comE<gt>
676 =head1 COPYRIGHT AND LICENSE
678 Copyright 2006-2010 by Infinity Interactive, Inc.
680 L<http://www.iinteractive.com>
682 This library is free software; you can redistribute it and/or modify
683 it under the same terms as Perl itself.