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.14';
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;
26 use Class::MOP::MiniTrait;
28 use base 'Class::MOP::Class';
30 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
32 __PACKAGE__->meta->add_attribute('roles' => (
37 __PACKAGE__->meta->add_attribute('role_applications' => (
38 reader => '_get_role_applications',
42 __PACKAGE__->meta->add_attribute(
43 Class::MOP::Attribute->new('immutable_trait' => (
44 accessor => "immutable_trait",
45 default => 'Moose::Meta::Class::Immutable::Trait',
49 __PACKAGE__->meta->add_attribute('constructor_class' => (
50 accessor => 'constructor_class',
51 default => 'Moose::Meta::Method::Constructor',
54 __PACKAGE__->meta->add_attribute('destructor_class' => (
55 accessor => 'destructor_class',
56 default => 'Moose::Meta::Method::Destructor',
59 __PACKAGE__->meta->add_attribute('error_class' => (
60 accessor => 'error_class',
61 default => 'Moose::Error::Default',
67 return Class::MOP::get_metaclass_by_name($pkg)
68 || $class->SUPER::initialize($pkg,
69 'attribute_metaclass' => 'Moose::Meta::Attribute',
70 'method_metaclass' => 'Moose::Meta::Method',
71 'instance_metaclass' => 'Moose::Meta::Instance',
77 my ($class, $package_name, %options) = @_;
79 (ref $options{roles} eq 'ARRAY')
80 || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
81 if exists $options{roles};
82 my $roles = delete $options{roles};
84 my $new_meta = $class->SUPER::create($package_name, %options);
87 Moose::Util::apply_all_roles( $new_meta, @$roles );
95 sub create_anon_class {
96 my ($self, %options) = @_;
98 my $cache_ok = delete $options{cache};
101 = _anon_cache_key( $options{superclasses}, $options{roles} );
103 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
104 return $ANON_CLASSES{$cache_key};
107 my $new_class = $self->SUPER::create_anon_class(%options);
109 $ANON_CLASSES{$cache_key} = $new_class
115 sub _anon_cache_key {
116 # Makes something like Super::Class|Super::Class::2=Role|Role::1
118 join( '|', @{ $_[0] || [] } ),
119 join( '|', sort @{ $_[1] || [] } ),
127 my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
131 my %existing_classes;
133 %existing_classes = map { $_ => $meta->$_() } qw(
136 wrapped_method_metaclass
143 $cache_key = _anon_cache_key(
144 [ $meta->superclasses ],
145 [ map { $_->name } @{ $meta->roles } ],
146 ) if $meta->is_anon_class;
149 my $new_meta = $self->SUPER::reinitialize(
155 return $new_meta unless defined $cache_key;
157 my $new_cache_key = _anon_cache_key(
158 [ $meta->superclasses ],
159 [ map { $_->name } @{ $meta->roles } ],
162 delete $ANON_CLASSES{$cache_key};
163 $ANON_CLASSES{$new_cache_key} = $new_meta;
169 my ($self, $role) = @_;
170 (blessed($role) && $role->isa('Moose::Meta::Role'))
171 || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
172 push @{$self->roles} => $role;
175 sub role_applications {
178 return @{$self->_get_role_applications};
181 sub add_role_application {
182 my ($self, $application) = @_;
183 (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
184 || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
185 push @{$self->_get_role_applications} => $application;
188 sub calculate_all_roles {
191 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
194 sub calculate_all_roles_with_inheritance {
197 grep { !$seen{$_->name}++ }
198 map { Class::MOP::class_of($_)->can('calculate_all_roles')
199 ? Class::MOP::class_of($_)->calculate_all_roles
201 $self->linearized_isa;
205 my ($self, $role_name) = @_;
208 || $self->throw_error("You must supply a role name to look for");
210 foreach my $class ($self->class_precedence_list) {
211 my $meta = Class::MOP::class_of($class);
212 # when a Moose metaclass is itself extended with a role,
213 # this check needs to be done since some items in the
214 # class_precedence_list might in fact be Class::MOP
216 next unless $meta && $meta->can('roles');
217 foreach my $role (@{$meta->roles}) {
218 return 1 if $role->does_role($role_name);
225 my ($self, $role_name) = @_;
228 || $self->throw_error("You must supply a role name to look for");
230 foreach my $class ($self->class_precedence_list) {
231 my $meta = Class::MOP::class_of($class);
232 # when a Moose metaclass is itself extended with a role,
233 # this check needs to be done since some items in the
234 # class_precedence_list might in fact be Class::MOP
236 next unless $meta && $meta->can('roles');
237 foreach my $role (@{$meta->roles}) {
238 return 1 if $role->excludes_role($role_name);
246 my $params = @_ == 1 ? $_[0] : {@_};
247 my $object = $self->SUPER::new_object($params);
249 foreach my $attr ( $self->get_all_attributes() ) {
251 next unless $attr->can('has_trigger') && $attr->has_trigger;
253 my $init_arg = $attr->init_arg;
255 next unless defined $init_arg;
257 next unless exists $params->{$init_arg};
263 ? $attr->get_read_method_ref->($object)
264 : $params->{$init_arg}
269 $object->BUILDALL($params) if $object->can('BUILDALL');
276 my $supers = Data::OptList::mkopt(\@_);
277 foreach my $super (@{ $supers }) {
278 my ($name, $opts) = @{ $super };
279 Class::MOP::load_class($name, $opts);
280 my $meta = Class::MOP::class_of($name);
281 $self->throw_error("You cannot inherit from a Moose Role ($name)")
282 if $meta && $meta->isa('Moose::Meta::Role')
284 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
287 ### ---------------------------------------------
292 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
294 : $self->_process_attribute(@_));
295 $self->SUPER::add_attribute($attr);
296 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
297 # 'bare' and doesn't implement this method
298 if ($attr->can('_check_associated_methods')) {
299 $attr->_check_associated_methods;
304 sub add_override_method_modifier {
305 my ($self, $name, $method, $_super_package) = @_;
307 (!$self->has_method($name))
308 || $self->throw_error("Cannot add an override method if a local method is already present");
310 $self->add_method($name => Moose::Meta::Method::Overridden->new(
313 package => $_super_package, # need this for roles
318 sub add_augment_method_modifier {
319 my ($self, $name, $method) = @_;
320 (!$self->has_method($name))
321 || $self->throw_error("Cannot add an augment method if a local method is already present");
323 $self->add_method($name => Moose::Meta::Method::Augmented->new(
330 ## Private Utility methods ...
332 sub _find_next_method_by_name_which_is_not_overridden {
333 my ($self, $name) = @_;
334 foreach my $method ($self->find_all_methods_by_name($name)) {
335 return $method->{code}
336 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
341 ## Metaclass compatibility
343 sub _base_metaclasses {
345 my %metaclasses = $self->SUPER::_base_metaclasses;
346 for my $class (keys %metaclasses) {
347 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
351 error_class => 'Moose::Error::Default',
355 sub _fix_class_metaclass_incompatibility {
357 my ($super_meta) = @_;
359 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
361 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
363 || confess "Can't fix metaclass incompatibility for "
365 . " because it is not pristine.";
366 my $super_meta_name = $super_meta->_real_ref_name;
367 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
368 my $new_self = $class_meta_subclass_meta_name->reinitialize(
372 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
376 sub _fix_single_metaclass_incompatibility {
378 my ($metaclass_type, $super_meta) = @_;
380 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
382 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
384 || confess "Can't fix metaclass incompatibility for "
386 . " because it is not pristine.";
387 my $super_meta_name = $super_meta->_real_ref_name;
388 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
389 my $new_self = $super_meta->reinitialize(
391 $metaclass_type => $class_specific_meta_subclass_meta_name,
394 $self->_replace_self( $new_self, $super_meta_name );
400 my ( $new_self, $new_class) = @_;
403 bless $self, $new_class;
405 # We need to replace the cached metaclass instance or else when it goes
406 # out of scope Class::MOP::Class destroy's the namespace for the
407 # metaclass's class, causing much havoc.
408 Class::MOP::store_metaclass_by_name( $self->name, $self );
409 Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
412 sub _process_attribute {
413 my ( $self, $name, @args ) = @_;
415 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
417 if (($name || '') =~ /^\+(.*)/) {
418 return $self->_process_inherited_attribute($1, @args);
421 return $self->_process_new_attribute($name, @args);
425 sub _process_new_attribute {
426 my ( $self, $name, @args ) = @_;
428 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
431 sub _process_inherited_attribute {
432 my ($self, $attr_name, %options) = @_;
433 my $inherited_attr = $self->find_attribute_by_name($attr_name);
434 (defined $inherited_attr)
435 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
436 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
437 return $inherited_attr->clone_and_inherit_options(%options);
441 # kind of a kludge to handle Class::MOP::Attributes
442 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
448 sub _immutable_options {
449 my ( $self, @args ) = @_;
451 $self->SUPER::_immutable_options(
452 inline_destructor => 1,
454 # Moose always does this when an attribute is created
455 inline_accessors => 0,
461 ## -------------------------------------------------
466 my ( $self, @args ) = @_;
467 local $error_level = ($error_level || 0) + 1;
468 $self->raise_error($self->create_error(@args));
472 my ( $self, @args ) = @_;
477 my ( $self, @args ) = @_;
481 local $error_level = ($error_level || 0 ) + 1;
483 if ( @args % 2 == 1 ) {
484 unshift @args, "message";
487 my %args = ( metaclass => $self, last_error => $@, @args );
489 $args{depth} += $error_level;
491 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
493 Class::MOP::load_class($class);
496 Carp::caller_info($args{depth}),
509 Moose::Meta::Class - The Moose metaclass
513 This class is a subclass of L<Class::MOP::Class> that provides
514 additional Moose-specific functionality.
516 To really understand this class, you will need to start with the
517 L<Class::MOP::Class> documentation. This class can be understood as a
518 set of additional features on top of the basic feature provided by
523 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
529 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
531 This overrides the parent's method in order to provide its own
532 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
533 C<method_metaclass> options.
535 These all default to the appropriate Moose class.
537 =item B<< Moose::Meta::Class->create($package_name, %options) >>
539 This overrides the parent's method in order to accept a C<roles>
540 option. This should be an array reference containing roles
541 that the class does, each optionally followed by a hashref of options
542 (C<-excludes> and C<-alias>).
544 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
546 =item B<< Moose::Meta::Class->create_anon_class >>
548 This overrides the parent's method to accept a C<roles> option, just
551 It also accepts a C<cache> option. If this is true, then the anonymous
552 class will be cached based on its superclasses and roles. If an
553 existing anonymous class in the cache has the same superclasses and
554 roles, it will be reused.
556 my $metaclass = Moose::Meta::Class->create_anon_class(
557 superclasses => ['Foo'],
558 roles => [qw/Some Roles Go Here/],
562 Each entry in both the C<superclasses> and the C<roles> option can be
563 followed by a hash reference with arguments. The C<superclasses>
564 option can be supplied with a L<-version|Class::MOP/Class Loading
565 Options> option that ensures the loaded superclass satisfies the
566 required version. The C<role> option also takes the C<-version> as an
567 argument, but the option hash reference can also contain any other
568 role relevant values like exclusions or parameterized role arguments.
570 =item B<< $metaclass->make_immutable(%options) >>
572 This overrides the parent's method to add a few options. Specifically,
573 it uses the Moose-specific constructor and destructor classes, and
574 enables inlining the destructor.
576 Since Moose always inlines attributes, it sets the C<inline_accessors> option
579 =item B<< $metaclass->new_object(%params) >>
581 This overrides the parent's method in order to add support for
584 =item B<< $metaclass->superclasses(@superclasses) >>
586 This is the accessor allowing you to read or change the parents of
589 Each superclass can be followed by a hash reference containing a
590 L<-version|Class::MOP/Class Loading Options> value. If the version
591 requirement is not satisfied an error will be thrown.
593 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
595 This adds an C<override> method modifier to the package.
597 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
599 This adds an C<augment> method modifier to the package.
601 =item B<< $metaclass->calculate_all_roles >>
603 This will return a unique array of C<Moose::Meta::Role> instances
604 which are attached to this class.
606 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
608 This will return a unique array of C<Moose::Meta::Role> instances
609 which are attached to this class, and each of this class's ancestors.
611 =item B<< $metaclass->add_role($role) >>
613 This takes a L<Moose::Meta::Role> object, and adds it to the class's
614 list of roles. This I<does not> actually apply the role to the class.
616 =item B<< $metaclass->role_applications >>
618 Returns a list of L<Moose::Meta::Role::Application::ToClass>
619 objects, which contain the arguments to role application.
621 =item B<< $metaclass->add_role_application($application) >>
623 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
624 adds it to the class's list of role applications. This I<does not>
625 actually apply any role to the class; it is only for tracking role
628 =item B<< $metaclass->does_role($role) >>
630 This returns a boolean indicating whether or not the class does the specified
631 role. The role provided can be either a role name or a L<Moose::Meta::Role>
632 object. This tests both the class and its parents.
634 =item B<< $metaclass->excludes_role($role_name) >>
636 A class excludes a role if it has already composed a role which
637 excludes the named role. This tests both the class and its parents.
639 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
641 This overrides the parent's method in order to allow the parameters to
642 be provided as a hash reference.
644 =item B<< $metaclass->constructor_class($class_name) >>
646 =item B<< $metaclass->destructor_class($class_name) >>
648 These are the names of classes used when making a class immutable. These
649 default to L<Moose::Meta::Method::Constructor> and
650 L<Moose::Meta::Method::Destructor> respectively. These accessors are
651 read-write, so you can use them to change the class name.
653 =item B<< $metaclass->error_class($class_name) >>
655 The name of the class used to throw errors. This defaults to
656 L<Moose::Error::Default>, which generates an error with a stacktrace
657 just like C<Carp::confess>.
659 =item B<< $metaclass->throw_error($message, %extra) >>
661 Throws the error created by C<create_error> using C<raise_error>
667 See L<Moose/BUGS> for details on reporting bugs.
671 Stevan Little E<lt>stevan@iinteractive.comE<gt>
673 =head1 COPYRIGHT AND LICENSE
675 Copyright 2006-2010 by Infinity Interactive, Inc.
677 L<http://www.iinteractive.com>
679 This library is free software; you can redistribute it and/or modify
680 it under the same terms as Perl itself.