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.20';
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');
285 my $supers = Data::OptList::mkopt(\@_);
286 foreach my $super (@{ $supers }) {
287 my ($name, $opts) = @{ $super };
288 Class::MOP::load_class($name, $opts);
289 my $meta = Class::MOP::class_of($name);
290 $self->throw_error("You cannot inherit from a Moose Role ($name)")
291 if $meta && $meta->isa('Moose::Meta::Role')
293 return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
296 ### ---------------------------------------------
301 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
303 : $self->_process_attribute(@_));
304 $self->SUPER::add_attribute($attr);
305 # it may be a Class::MOP::Attribute, theoretically, which doesn't have
306 # 'bare' and doesn't implement this method
307 if ($attr->can('_check_associated_methods')) {
308 $attr->_check_associated_methods;
313 sub add_override_method_modifier {
314 my ($self, $name, $method, $_super_package) = @_;
316 (!$self->has_method($name))
317 || $self->throw_error("Cannot add an override method if a local method is already present");
319 $self->add_method($name => Moose::Meta::Method::Overridden->new(
322 package => $_super_package, # need this for roles
327 sub add_augment_method_modifier {
328 my ($self, $name, $method) = @_;
329 (!$self->has_method($name))
330 || $self->throw_error("Cannot add an augment method if a local method is already present");
332 $self->add_method($name => Moose::Meta::Method::Augmented->new(
339 ## Private Utility methods ...
341 sub _find_next_method_by_name_which_is_not_overridden {
342 my ($self, $name) = @_;
343 foreach my $method ($self->find_all_methods_by_name($name)) {
344 return $method->{code}
345 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
350 ## Metaclass compatibility
352 sub _base_metaclasses {
354 my %metaclasses = $self->SUPER::_base_metaclasses;
355 for my $class (keys %metaclasses) {
356 $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
360 error_class => 'Moose::Error::Default',
364 sub _fix_class_metaclass_incompatibility {
366 my ($super_meta) = @_;
368 $self->SUPER::_fix_class_metaclass_incompatibility(@_);
370 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
372 || confess "Can't fix metaclass incompatibility for "
374 . " because it is not pristine.";
375 my $super_meta_name = $super_meta->_real_ref_name;
376 my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
377 my $new_self = $class_meta_subclass_meta_name->reinitialize(
381 $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
385 sub _fix_single_metaclass_incompatibility {
387 my ($metaclass_type, $super_meta) = @_;
389 $self->SUPER::_fix_single_metaclass_incompatibility(@_);
391 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
393 || confess "Can't fix metaclass incompatibility for "
395 . " because it is not pristine.";
396 my $super_meta_name = $super_meta->_real_ref_name;
397 my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
398 my $new_self = $super_meta->reinitialize(
400 $metaclass_type => $class_specific_meta_subclass_meta_name,
403 $self->_replace_self( $new_self, $super_meta_name );
409 my ( $new_self, $new_class) = @_;
412 bless $self, $new_class;
414 # We need to replace the cached metaclass instance or else when it goes
415 # out of scope Class::MOP::Class destroy's the namespace for the
416 # metaclass's class, causing much havoc.
417 my $weaken = Class::MOP::metaclass_is_weak( $self->name );
418 Class::MOP::store_metaclass_by_name( $self->name, $self );
419 Class::MOP::weaken_metaclass( $self->name ) if $weaken;
422 sub _process_attribute {
423 my ( $self, $name, @args ) = @_;
425 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
427 if (($name || '') =~ /^\+(.*)/) {
428 return $self->_process_inherited_attribute($1, @args);
431 return $self->_process_new_attribute($name, @args);
435 sub _process_new_attribute {
436 my ( $self, $name, @args ) = @_;
438 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
441 sub _process_inherited_attribute {
442 my ($self, $attr_name, %options) = @_;
443 my $inherited_attr = $self->find_attribute_by_name($attr_name);
444 (defined $inherited_attr)
445 || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
446 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
447 return $inherited_attr->clone_and_inherit_options(%options);
451 # kind of a kludge to handle Class::MOP::Attributes
452 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
458 sub _immutable_options {
459 my ( $self, @args ) = @_;
461 $self->SUPER::_immutable_options(
462 inline_destructor => 1,
464 # Moose always does this when an attribute is created
465 inline_accessors => 0,
471 ## -------------------------------------------------
476 my ( $self, @args ) = @_;
477 local $error_level = ($error_level || 0) + 1;
478 $self->raise_error($self->create_error(@args));
482 my ( $self, @args ) = @_;
487 my ( $self, @args ) = @_;
491 local $error_level = ($error_level || 0 ) + 1;
493 if ( @args % 2 == 1 ) {
494 unshift @args, "message";
497 my %args = ( metaclass => $self, last_error => $@, @args );
499 $args{depth} += $error_level;
501 my $class = ref $self ? $self->error_class : "Moose::Error::Default";
503 Class::MOP::load_class($class);
506 Carp::caller_info($args{depth}),
519 Moose::Meta::Class - The Moose metaclass
523 This class is a subclass of L<Class::MOP::Class> that provides
524 additional Moose-specific functionality.
526 To really understand this class, you will need to start with the
527 L<Class::MOP::Class> documentation. This class can be understood as a
528 set of additional features on top of the basic feature provided by
533 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
539 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
541 This overrides the parent's method in order to provide its own
542 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
543 C<method_metaclass> options.
545 These all default to the appropriate Moose class.
547 =item B<< Moose::Meta::Class->create($package_name, %options) >>
549 This overrides the parent's method in order to accept a C<roles>
550 option. This should be an array reference containing roles
551 that the class does, each optionally followed by a hashref of options
552 (C<-excludes> and C<-alias>).
554 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
556 =item B<< Moose::Meta::Class->create_anon_class >>
558 This overrides the parent's method to accept a C<roles> option, just
561 It also accepts a C<cache> option. If this is true, then the anonymous
562 class will be cached based on its superclasses and roles. If an
563 existing anonymous class in the cache has the same superclasses and
564 roles, it will be reused.
566 my $metaclass = Moose::Meta::Class->create_anon_class(
567 superclasses => ['Foo'],
568 roles => [qw/Some Roles Go Here/],
572 Each entry in both the C<superclasses> and the C<roles> option can be
573 followed by a hash reference with arguments. The C<superclasses>
574 option can be supplied with a L<-version|Class::MOP/Class Loading
575 Options> option that ensures the loaded superclass satisfies the
576 required version. The C<role> option also takes the C<-version> as an
577 argument, but the option hash reference can also contain any other
578 role relevant values like exclusions or parameterized role arguments.
580 =item B<< $metaclass->make_immutable(%options) >>
582 This overrides the parent's method to add a few options. Specifically,
583 it uses the Moose-specific constructor and destructor classes, and
584 enables inlining the destructor.
586 Since Moose always inlines attributes, it sets the C<inline_accessors> option
589 =item B<< $metaclass->new_object(%params) >>
591 This overrides the parent's method in order to add support for
594 =item B<< $metaclass->superclasses(@superclasses) >>
596 This is the accessor allowing you to read or change the parents of
599 Each superclass can be followed by a hash reference containing a
600 L<-version|Class::MOP/Class Loading Options> value. If the version
601 requirement is not satisfied an error will be thrown.
603 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
605 This adds an C<override> method modifier to the package.
607 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
609 This adds an C<augment> method modifier to the package.
611 =item B<< $metaclass->calculate_all_roles >>
613 This will return a unique array of C<Moose::Meta::Role> instances
614 which are attached to this class.
616 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
618 This will return a unique array of C<Moose::Meta::Role> instances
619 which are attached to this class, and each of this class's ancestors.
621 =item B<< $metaclass->add_role($role) >>
623 This takes a L<Moose::Meta::Role> object, and adds it to the class's
624 list of roles. This I<does not> actually apply the role to the class.
626 =item B<< $metaclass->role_applications >>
628 Returns a list of L<Moose::Meta::Role::Application::ToClass>
629 objects, which contain the arguments to role application.
631 =item B<< $metaclass->add_role_application($application) >>
633 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
634 adds it to the class's list of role applications. This I<does not>
635 actually apply any role to the class; it is only for tracking role
638 =item B<< $metaclass->does_role($role) >>
640 This returns a boolean indicating whether or not the class does the specified
641 role. The role provided can be either a role name or a L<Moose::Meta::Role>
642 object. This tests both the class and its parents.
644 =item B<< $metaclass->excludes_role($role_name) >>
646 A class excludes a role if it has already composed a role which
647 excludes the named role. This tests both the class and its parents.
649 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
651 This overrides the parent's method in order to allow the parameters to
652 be provided as a hash reference.
654 =item B<< $metaclass->constructor_class($class_name) >>
656 =item B<< $metaclass->destructor_class($class_name) >>
658 These are the names of classes used when making a class immutable. These
659 default to L<Moose::Meta::Method::Constructor> and
660 L<Moose::Meta::Method::Destructor> respectively. These accessors are
661 read-write, so you can use them to change the class name.
663 =item B<< $metaclass->error_class($class_name) >>
665 The name of the class used to throw errors. This defaults to
666 L<Moose::Error::Default>, which generates an error with a stacktrace
667 just like C<Carp::confess>.
669 =item B<< $metaclass->throw_error($message, %extra) >>
671 Throws the error created by C<create_error> using C<raise_error>
677 See L<Moose/BUGS> for details on reporting bugs.
681 Stevan Little E<lt>stevan@iinteractive.comE<gt>
683 =head1 COPYRIGHT AND LICENSE
685 Copyright 2006-2010 by Infinity Interactive, Inc.
687 L<http://www.iinteractive.com>
689 This library is free software; you can redistribute it and/or modify
690 it under the same terms as Perl itself.