2 package Class::MOP::Class;
7 use Class::MOP::Instance;
8 use Class::MOP::Method::Wrapped;
9 use Class::MOP::Method::Accessor;
10 use Class::MOP::Method::Constructor;
11 use Class::MOP::MiniTrait;
14 use Scalar::Util 'blessed', 'reftype', 'weaken';
15 use Sub::Name 'subname';
16 use Devel::GlobalDestruction 'in_global_destruction';
18 use List::MoreUtils 'all';
20 use base 'Class::MOP::Module',
21 'Class::MOP::Mixin::HasAttributes',
22 'Class::MOP::Mixin::HasMethods';
32 $package_name = shift;
35 $package_name = $options{package};
38 ($package_name && !ref($package_name))
39 || confess "You must pass a package name and it cannot be blessed";
41 return Class::MOP::get_metaclass_by_name($package_name)
42 || $class->_construct_class_instance(package => $package_name, @_);
46 my ( $class, @args ) = @_;
47 unshift @args, "package" if @args % 2;
49 my $old_metaclass = blessed($options{package})
51 : Class::MOP::get_metaclass_by_name($options{package});
52 $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name)
53 if !exists $options{weaken}
54 && blessed($old_metaclass)
55 && $old_metaclass->isa('Class::MOP::Class');
56 $old_metaclass->_remove_generated_metaobjects
57 if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
58 my $new_metaclass = $class->SUPER::reinitialize(%options);
59 $new_metaclass->_restore_metaobjects_from($old_metaclass)
60 if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
61 return $new_metaclass;
64 # NOTE: (meta-circularity)
65 # this is a special form of _construct_instance
66 # (see below), which is used to construct class
67 # meta-object instances for any Class::MOP::*
68 # class. All other classes will use the more
69 # normal &construct_instance.
70 sub _construct_class_instance {
72 my $options = @_ == 1 ? $_[0] : {@_};
73 my $package_name = $options->{package};
74 (defined $package_name && $package_name)
75 || confess "You must pass a package name";
77 # return the metaclass if we have it cached,
78 # and it is still defined (it has not been
79 # reaped by DESTROY yet, which can happen
80 # annoyingly enough during global destruction)
82 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
88 ? $class->_real_ref_name
91 # now create the metaclass
93 if ($class eq 'Class::MOP::Class') {
94 $meta = $class->_new($options);
98 # it is safe to use meta here because
99 # class will always be a subclass of
100 # Class::MOP::Class, which defines meta
101 $meta = $class->meta->_construct_instance($options)
104 # and check the metaclass compatibility
105 $meta->_check_metaclass_compatibility();
107 Class::MOP::store_metaclass_by_name($package_name, $meta);
110 # we need to weaken any anon classes
111 # so that they can call DESTROY properly
112 Class::MOP::weaken_metaclass($package_name) if $options->{weaken};
120 # NOTE: we need to deal with the possibility of class immutability here,
121 # and then get the name of the class appropriately
122 return $self->is_immutable
123 ? $self->_get_mutable_metaclass_name()
130 return Class::MOP::Class->initialize($class)->new_object(@_)
131 if $class ne __PACKAGE__;
133 my $options = @_ == 1 ? $_[0] : {@_};
136 # inherited from Class::MOP::Package
137 'package' => $options->{package},
140 # since the following attributes will
141 # actually be loaded from the symbol
142 # table, and actually bypass the instance
143 # entirely, we can just leave these things
144 # listed here for reference, because they
145 # should not actually have a value associated
147 'namespace' => \undef,
150 # inherited from Class::MOP::Module
152 'authority' => \undef,
154 # defined in Class::MOP::Class
155 'superclasses' => \undef,
158 'attribute_metaclass' =>
159 ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
160 'method_metaclass' =>
161 ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
162 'wrapped_method_metaclass' => (
163 $options->{'wrapped_method_metaclass'}
164 || 'Class::MOP::Method::Wrapped'
166 'instance_metaclass' =>
167 ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
168 'immutable_trait' => (
169 $options->{'immutable_trait'}
170 || 'Class::MOP::Class::Immutable::Trait'
172 'constructor_name' => ( $options->{constructor_name} || 'new' ),
173 'constructor_class' => (
174 $options->{constructor_class} || 'Class::MOP::Method::Constructor'
176 'destructor_class' => $options->{destructor_class},
180 ## Metaclass compatibility
182 my %base_metaclass = (
183 attribute_metaclass => 'Class::MOP::Attribute',
184 method_metaclass => 'Class::MOP::Method',
185 wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
186 instance_metaclass => 'Class::MOP::Instance',
187 constructor_class => 'Class::MOP::Method::Constructor',
188 destructor_class => 'Class::MOP::Method::Destructor',
191 sub _base_metaclasses { %base_metaclass }
194 sub _check_metaclass_compatibility {
197 my @superclasses = $self->superclasses
200 $self->_fix_metaclass_incompatibility(@superclasses);
202 my %base_metaclass = $self->_base_metaclasses;
204 # this is always okay ...
206 if ref($self) eq 'Class::MOP::Class'
208 my $meta = $self->$_;
209 !defined($meta) || $meta eq $base_metaclass{$_};
211 keys %base_metaclass;
213 for my $superclass (@superclasses) {
214 $self->_check_class_metaclass_compatibility($superclass);
217 for my $metaclass_type ( keys %base_metaclass ) {
218 next unless defined $self->$metaclass_type;
219 for my $superclass (@superclasses) {
220 $self->_check_single_metaclass_compatibility( $metaclass_type,
226 sub _check_class_metaclass_compatibility {
228 my ( $superclass_name ) = @_;
230 if (!$self->_class_metaclass_is_compatible($superclass_name)) {
231 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
233 my $super_meta_type = $super_meta->_real_ref_name;
235 confess "The metaclass of " . $self->name . " ("
236 . (ref($self)) . ")" . " is not compatible with "
237 . "the metaclass of its superclass, "
238 . $superclass_name . " (" . ($super_meta_type) . ")";
242 sub _class_metaclass_is_compatible {
244 my ( $superclass_name ) = @_;
246 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
249 my $super_meta_name = $super_meta->_real_ref_name;
251 return $self->_is_compatible_with($super_meta_name);
254 sub _check_single_metaclass_compatibility {
256 my ( $metaclass_type, $superclass_name ) = @_;
258 if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
259 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
260 my $metaclass_type_name = $metaclass_type;
261 $metaclass_type_name =~ s/_(?:meta)?class$//;
262 $metaclass_type_name =~ s/_/ /g;
263 confess "The $metaclass_type_name metaclass for "
264 . $self->name . " (" . ($self->$metaclass_type)
265 . ")" . " is not compatible with the "
266 . "$metaclass_type_name metaclass of its "
267 . "superclass, $superclass_name ("
268 . ($super_meta->$metaclass_type) . ")";
272 sub _single_metaclass_is_compatible {
274 my ( $metaclass_type, $superclass_name ) = @_;
276 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
279 # for instance, Moose::Meta::Class has a error_class attribute, but
280 # Class::MOP::Class doesn't - this shouldn't be an error
281 return 1 unless $super_meta->can($metaclass_type);
282 # for instance, Moose::Meta::Class has a destructor_class, but
283 # Class::MOP::Class doesn't - this shouldn't be an error
284 return 1 unless defined $super_meta->$metaclass_type;
285 # if metaclass is defined in superclass but not here, it's not compatible
286 # this is a really odd case
287 return 0 unless defined $self->$metaclass_type;
289 return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
292 sub _fix_metaclass_incompatibility {
294 my @supers = map { Class::MOP::Class->initialize($_) } @_;
297 for my $super (@supers) {
299 if $self->_can_fix_metaclass_incompatibility($super);
301 return unless $necessary;
303 for my $super (@supers) {
304 if (!$self->_class_metaclass_is_compatible($super->name)) {
305 $self->_fix_class_metaclass_incompatibility($super);
309 my %base_metaclass = $self->_base_metaclasses;
310 for my $metaclass_type (keys %base_metaclass) {
311 for my $super (@supers) {
312 if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
313 $self->_fix_single_metaclass_incompatibility(
314 $metaclass_type, $super
321 sub _can_fix_metaclass_incompatibility {
323 my ($super_meta) = @_;
325 return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
327 my %base_metaclass = $self->_base_metaclasses;
328 for my $metaclass_type (keys %base_metaclass) {
329 return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
335 sub _class_metaclass_can_be_made_compatible {
337 my ($super_meta) = @_;
339 return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
342 sub _single_metaclass_can_be_made_compatible {
344 my ($super_meta, $metaclass_type) = @_;
346 my $specific_meta = $self->$metaclass_type;
348 return unless $super_meta->can($metaclass_type);
349 my $super_specific_meta = $super_meta->$metaclass_type;
351 # for instance, Moose::Meta::Class has a destructor_class, but
352 # Class::MOP::Class doesn't - this shouldn't be an error
353 return unless defined $super_specific_meta;
355 # if metaclass is defined in superclass but not here, it's fixable
356 # this is a really odd case
357 return 1 unless defined $specific_meta;
359 return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
362 sub _fix_class_metaclass_incompatibility {
364 my ( $super_meta ) = @_;
366 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
368 || confess "Can't fix metaclass incompatibility for "
370 . " because it is not pristine.";
372 my $super_meta_name = $super_meta->_real_ref_name;
374 $self->_make_compatible_with($super_meta_name);
378 sub _fix_single_metaclass_incompatibility {
380 my ( $metaclass_type, $super_meta ) = @_;
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.";
388 my $new_metaclass = $self->$metaclass_type
389 ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
390 : $super_meta->$metaclass_type;
391 $self->{$metaclass_type} = $new_metaclass;
395 sub _restore_metaobjects_from {
399 $self->_restore_metamethods_from($old_meta);
400 $self->_restore_metaattributes_from($old_meta);
403 sub _remove_generated_metaobjects {
406 for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
407 $attr->remove_accessors;
415 # this should be sufficient, if you have a
416 # use case where it is not, write a test and
418 my $ANON_CLASS_SERIAL = 0;
421 # we need a sufficiently annoying prefix
422 # this should suffice for now, this is
423 # used in a couple of places below, so
424 # need to put it up here for now.
425 my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
429 no warnings 'uninitialized';
430 $self->name =~ /^$ANON_CLASS_PREFIX/o;
433 sub create_anon_class {
434 my ($class, %options) = @_;
435 $options{weaken} = 1 unless exists $options{weaken};
436 my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
437 return $class->create($package_name, %options);
441 # this will only get called for
442 # anon-classes, all other calls
443 # are assumed to occur during
444 # global destruction and so don't
445 # really need to be handled explicitly
449 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
451 $self->free_anon_class
452 if $self->is_anon_class;
455 sub free_anon_class {
457 my $name = $self->name;
459 # Moose does a weird thing where it replaces the metaclass for
460 # class when fixing metaclass incompatibility. In that case,
461 # we don't want to clean out the namespace now. We can detect
462 # that because Moose will explicitly update the singleton
463 # cache in Class::MOP.
464 no warnings 'uninitialized';
465 my $current_meta = Class::MOP::get_metaclass_by_name($name);
466 return if $current_meta ne $self;
468 my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
471 @{$name . '::ISA'} = ();
472 %{$name . '::'} = ();
473 delete ${$first_fragments . '::'}{$last_fragment . '::'};
475 Class::MOP::remove_metaclass_by_name($name);
480 # creating classes with MOP ...
483 my ( $class, @args ) = @_;
485 unshift @args, 'package' if @args % 2 == 1;
487 my (%options) = @args;
488 my $package_name = $options{package};
490 (ref $options{superclasses} eq 'ARRAY')
491 || confess "You must pass an ARRAY ref of superclasses"
492 if exists $options{superclasses};
494 (ref $options{attributes} eq 'ARRAY')
495 || confess "You must pass an ARRAY ref of attributes"
496 if exists $options{attributes};
498 (ref $options{methods} eq 'HASH')
499 || confess "You must pass a HASH ref of methods"
500 if exists $options{methods};
502 $options{meta_name} = 'meta'
503 unless exists $options{meta_name};
505 my (%initialize_options) = @args;
506 delete @initialize_options{qw(
515 my $meta = $class->initialize( $package_name => %initialize_options );
517 $meta->_instantiate_module( $options{version}, $options{authority} );
519 $meta->_add_meta_method($options{meta_name})
520 if defined $options{meta_name};
522 $meta->superclasses(@{$options{superclasses}})
523 if exists $options{superclasses};
525 # process attributes first, so that they can
526 # install accessors, but locally defined methods
527 # can then overwrite them. It is maybe a little odd, but
528 # I think this should be the order of things.
529 if (exists $options{attributes}) {
530 foreach my $attr (@{$options{attributes}}) {
531 $meta->add_attribute($attr);
534 if (exists $options{methods}) {
535 foreach my $method_name (keys %{$options{methods}}) {
536 $meta->add_method($method_name, $options{methods}->{$method_name});
542 # Instance Construction & Cloning
548 # we need to protect the integrity of the
549 # Class::MOP::Class singletons here, so we
550 # delegate this to &construct_class_instance
551 # which will deal with the singletons
552 return $class->_construct_class_instance(@_)
553 if $class->name->isa('Class::MOP::Class');
554 return $class->_construct_instance(@_);
557 sub _construct_instance {
559 my $params = @_ == 1 ? $_[0] : {@_};
560 my $meta_instance = $class->get_meta_instance();
562 # the code below is almost certainly incorrect
563 # but this is foreign inheritance, so we might
564 # have to kludge it in the end.
566 if (my $instance_class = blessed($params->{__INSTANCE__})) {
567 ($instance_class eq $class->name)
568 || confess "Objects passed as the __INSTANCE__ parameter must "
569 . "already be blessed into the correct class, but "
570 . "$params->{__INSTANCE__} is not a " . $class->name;
571 $instance = $params->{__INSTANCE__};
573 elsif (exists $params->{__INSTANCE__}) {
574 confess "The __INSTANCE__ parameter must be a blessed reference, not "
575 . $params->{__INSTANCE__};
578 $instance = $meta_instance->create_instance();
580 foreach my $attr ($class->get_all_attributes()) {
581 $attr->initialize_instance_slot($meta_instance, $instance, $params);
583 if (Class::MOP::metaclass_is_weak($class->name)) {
584 $meta_instance->_set_mop_slot($instance, $class);
589 sub _inline_new_object {
593 'my $class = shift;',
594 '$class = Scalar::Util::blessed($class) || $class;',
595 $self->_inline_fallback_constructor('$class'),
596 $self->_inline_params('$params', '$class'),
597 $self->_inline_generate_instance('$instance', '$class'),
598 $self->_inline_slot_initializers,
599 $self->_inline_preserve_weak_metaclasses,
600 $self->_inline_extra_init,
605 sub _inline_fallback_constructor {
609 'return ' . $self->_generate_fallback_constructor($class),
610 'if ' . $class . ' ne \'' . $self->name . '\';',
614 sub _generate_fallback_constructor {
617 return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)',
622 my ($params, $class) = @_;
624 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};',
628 sub _inline_generate_instance {
630 my ($inst, $class) = @_;
632 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';',
636 sub _inline_create_instance {
639 return $self->get_meta_instance->inline_create_instance(@_);
642 sub _inline_slot_initializers {
647 return map { $self->_inline_slot_initializer($_, $idx++) }
648 sort { $a->name cmp $b->name } $self->get_all_attributes;
651 sub _inline_slot_initializer {
653 my ($attr, $idx) = @_;
655 if (defined(my $init_arg = $attr->init_arg)) {
657 'if (exists $params->{\'' . $init_arg . '\'}) {',
658 $self->_inline_init_attr_from_constructor($attr, $idx),
661 if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
670 elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
682 sub _inline_init_attr_from_constructor {
684 my ($attr, $idx) = @_;
686 my @initial_value = $attr->_inline_set_value(
687 '$instance', '$params->{\'' . $attr->init_arg . '\'}',
690 push @initial_value, (
691 '$attrs->[' . $idx . ']->set_initial_value(',
693 $attr->_inline_instance_get('$instance'),
695 ) if $attr->has_initializer;
697 return @initial_value;
700 sub _inline_init_attr_from_default {
702 my ($attr, $idx) = @_;
704 my $default = $self->_inline_default_value($attr, $idx);
705 return unless $default;
707 my @initial_value = $attr->_inline_set_value('$instance', $default);
709 push @initial_value, (
710 '$attrs->[' . $idx . ']->set_initial_value(',
712 $attr->_inline_instance_get('$instance'),
714 ) if $attr->has_initializer;
716 return @initial_value;
719 sub _inline_default_value {
721 my ($attr, $index) = @_;
723 if ($attr->has_default) {
725 # default values can either be CODE refs
726 # in which case we need to call them. Or
727 # they can be scalars (strings/numbers)
728 # in which case we can just deal with them
729 # in the code we eval.
730 if ($attr->is_default_a_coderef) {
731 return '$defaults->[' . $index . ']->($instance)';
734 return '$defaults->[' . $index . ']';
737 elsif ($attr->has_builder) {
738 return '$instance->' . $attr->builder;
745 sub _inline_preserve_weak_metaclasses {
747 if (Class::MOP::metaclass_is_weak($self->name)) {
749 $self->_inline_set_mop_slot(
750 '$instance', 'Class::MOP::class_of($class)'
759 sub _inline_extra_init { }
762 sub get_meta_instance {
764 $self->{'_meta_instance'} ||= $self->_create_meta_instance();
767 sub _create_meta_instance {
770 my $instance = $self->instance_metaclass->new(
771 associated_metaclass => $self,
772 attributes => [ $self->get_all_attributes() ],
775 $self->add_meta_instance_dependencies()
776 if $instance->is_dependent_on_superclasses();
781 sub _inline_rebless_instance {
784 return $self->get_meta_instance->inline_rebless_instance_structure(@_);
787 sub _inline_get_mop_slot {
790 return $self->get_meta_instance->_inline_get_mop_slot(@_);
793 sub _inline_set_mop_slot {
796 return $self->get_meta_instance->_inline_set_mop_slot(@_);
799 sub _inline_clear_mop_slot {
802 return $self->get_meta_instance->_inline_clear_mop_slot(@_);
807 my $instance = shift;
808 (blessed($instance) && $instance->isa($class->name))
809 || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
812 # we need to protect the integrity of the
813 # Class::MOP::Class singletons here, they
814 # should not be cloned.
815 return $instance if $instance->isa('Class::MOP::Class');
816 $class->_clone_instance($instance, @_);
819 sub _clone_instance {
820 my ($class, $instance, %params) = @_;
822 || confess "You can only clone instances, ($instance) is not a blessed instance";
823 my $meta_instance = $class->get_meta_instance();
824 my $clone = $meta_instance->clone_instance($instance);
825 foreach my $attr ($class->get_all_attributes()) {
826 if ( defined( my $init_arg = $attr->init_arg ) ) {
827 if (exists $params{$init_arg}) {
828 $attr->set_value($clone, $params{$init_arg});
835 sub _force_rebless_instance {
836 my ($self, $instance, %params) = @_;
837 my $old_metaclass = Class::MOP::class_of($instance);
839 $old_metaclass->rebless_instance_away($instance, $self, %params)
842 my $meta_instance = $self->get_meta_instance;
844 if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
845 $meta_instance->_clear_mop_slot($instance);
849 # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
850 $meta_instance->rebless_instance_structure($_[1], $self);
852 $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
854 if (Class::MOP::metaclass_is_weak($self->name)) {
855 $meta_instance->_set_mop_slot($instance, $self);
859 sub rebless_instance {
860 my ($self, $instance, %params) = @_;
861 my $old_metaclass = Class::MOP::class_of($instance);
863 my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
864 $self->name->isa($old_class)
865 || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
867 $self->_force_rebless_instance($_[1], %params);
872 sub rebless_instance_back {
873 my ( $self, $instance ) = @_;
874 my $old_metaclass = Class::MOP::class_of($instance);
877 = $old_metaclass ? $old_metaclass->name : blessed($instance);
878 $old_class->isa( $self->name )
880 "You may rebless only into a superclass of ($old_class), of which ("
884 $self->_force_rebless_instance($_[1]);
889 sub rebless_instance_away {
890 # this intentionally does nothing, it is just a hook
893 sub _fixup_attributes_after_rebless {
895 my ($instance, $rebless_from, %params) = @_;
896 my $meta_instance = $self->get_meta_instance;
898 for my $attr ( $rebless_from->get_all_attributes ) {
899 next if $self->find_attribute_by_name( $attr->name );
900 $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
903 foreach my $attr ( $self->get_all_attributes ) {
904 if ( $attr->has_value($instance) ) {
905 if ( defined( my $init_arg = $attr->init_arg ) ) {
906 $params{$init_arg} = $attr->get_value($instance)
907 unless exists $params{$init_arg};
910 $attr->set_value($instance, $attr->get_value($instance));
915 foreach my $attr ($self->get_all_attributes) {
916 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
920 sub _attach_attribute {
921 my ($self, $attribute) = @_;
922 $attribute->attach_to_class($self);
925 sub _post_add_attribute {
926 my ( $self, $attribute ) = @_;
928 $self->invalidate_meta_instances;
930 # invalidate package flag here
933 $attribute->install_accessors;
936 $self->remove_attribute( $attribute->name );
941 sub remove_attribute {
944 my $removed_attribute = $self->SUPER::remove_attribute(@_)
947 $self->invalidate_meta_instances;
949 $removed_attribute->remove_accessors;
950 $removed_attribute->detach_from_class;
952 return$removed_attribute;
955 sub find_attribute_by_name {
956 my ( $self, $attr_name ) = @_;
958 foreach my $class ( $self->linearized_isa ) {
959 # fetch the meta-class ...
960 my $meta = Class::MOP::Class->initialize($class);
961 return $meta->get_attribute($attr_name)
962 if $meta->has_attribute($attr_name);
968 sub get_all_attributes {
970 my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
971 reverse $self->linearized_isa;
972 return values %attrs;
980 my $isa = $self->get_or_add_package_symbol('@ISA');
987 # on 5.8 and below, we need to call
988 # a method to get Perl to detect
989 # a cycle in the class hierarchy
990 my $class = $self->name;
994 # we need to check the metaclass
995 # compatibility here so that we can
996 # be sure that the superclass is
997 # not potentially creating an issues
998 # we don't know about
1000 $self->_check_metaclass_compatibility();
1001 $self->_superclasses_updated();
1007 sub _superclasses_updated {
1009 $self->update_meta_instance_dependencies();
1010 # keep strong references to all our parents, so they don't disappear if
1011 # they are anon classes and don't have any direct instances
1012 $self->_superclass_metas(
1013 map { Class::MOP::class_of($_) } $self->superclasses
1017 sub _superclass_metas {
1019 $self->{_superclass_metas} = [@_];
1024 my $super_class = $self->name;
1026 return @{ $super_class->mro::get_isarev() };
1029 sub direct_subclasses {
1031 my $super_class = $self->name;
1036 } Class::MOP::Class->initialize($_)->superclasses
1037 } $self->subclasses;
1040 sub linearized_isa {
1041 return @{ mro::get_linear_isa( (shift)->name ) };
1044 sub class_precedence_list {
1046 my $name = $self->name;
1048 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
1050 # We need to check for circular inheritance here
1051 # if we are are not on 5.10, cause 5.8 detects it
1052 # late. This will do nothing if all is well, and
1053 # blow up otherwise. Yes, it's an ugly hack, better
1054 # suggestions are welcome.
1056 ($name || return)->isa('This is a test for circular inheritance')
1059 # if our mro is c3, we can
1060 # just grab the linear_isa
1061 if (mro::get_mro($name) eq 'c3') {
1062 return @{ mro::get_linear_isa($name) }
1066 # we can't grab the linear_isa for dfs
1067 # since it has all the duplicates
1072 Class::MOP::Class->initialize($_)->class_precedence_list()
1073 } $self->superclasses()
1081 my $fetch_and_prepare_method = sub {
1082 my ($self, $method_name) = @_;
1083 my $wrapped_metaclass = $self->wrapped_method_metaclass;
1085 my $method = $self->get_method($method_name);
1086 # if we dont have local ...
1088 # try to find the next method
1089 $method = $self->find_next_method_by_name($method_name);
1090 # die if it does not exist
1092 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
1093 # and now make sure to wrap it
1094 # even if it is already wrapped
1095 # because we need a new sub ref
1096 $method = $wrapped_metaclass->wrap($method,
1097 package_name => $self->name,
1098 name => $method_name,
1102 # now make sure we wrap it properly
1103 $method = $wrapped_metaclass->wrap($method,
1104 package_name => $self->name,
1105 name => $method_name,
1106 ) unless $method->isa($wrapped_metaclass);
1108 $self->add_method($method_name => $method);
1112 sub add_before_method_modifier {
1113 my ($self, $method_name, $method_modifier) = @_;
1114 (defined $method_name && length $method_name)
1115 || confess "You must pass in a method name";
1116 my $method = $fetch_and_prepare_method->($self, $method_name);
1117 $method->add_before_modifier(
1118 subname(':before' => $method_modifier)
1122 sub add_after_method_modifier {
1123 my ($self, $method_name, $method_modifier) = @_;
1124 (defined $method_name && length $method_name)
1125 || confess "You must pass in a method name";
1126 my $method = $fetch_and_prepare_method->($self, $method_name);
1127 $method->add_after_modifier(
1128 subname(':after' => $method_modifier)
1132 sub add_around_method_modifier {
1133 my ($self, $method_name, $method_modifier) = @_;
1134 (defined $method_name && length $method_name)
1135 || confess "You must pass in a method name";
1136 my $method = $fetch_and_prepare_method->($self, $method_name);
1137 $method->add_around_modifier(
1138 subname(':around' => $method_modifier)
1143 # the methods above used to be named like this:
1144 # ${pkg}::${method}:(before|after|around)
1145 # but this proved problematic when using one modifier
1146 # to wrap multiple methods (something which is likely
1147 # to happen pretty regularly IMO). So instead of naming
1148 # it like this, I have chosen to just name them purely
1149 # with their modifier names, like so:
1150 # :(before|after|around)
1151 # The fact is that in a stack trace, it will be fairly
1152 # evident from the context what method they are attached
1153 # to, and so don't need the fully qualified name.
1156 sub find_method_by_name {
1157 my ($self, $method_name) = @_;
1158 (defined $method_name && length $method_name)
1159 || confess "You must define a method name to find";
1160 foreach my $class ($self->linearized_isa) {
1161 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1162 return $method if defined $method;
1167 sub get_all_methods {
1171 for my $class ( reverse $self->linearized_isa ) {
1172 my $meta = Class::MOP::Class->initialize($class);
1174 $methods{ $_->name } = $_ for $meta->_get_local_methods;
1177 return values %methods;
1180 sub get_all_method_names {
1183 return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
1186 sub find_all_methods_by_name {
1187 my ($self, $method_name) = @_;
1188 (defined $method_name && length $method_name)
1189 || confess "You must define a method name to find";
1191 foreach my $class ($self->linearized_isa) {
1192 # fetch the meta-class ...
1193 my $meta = Class::MOP::Class->initialize($class);
1195 name => $method_name,
1197 code => $meta->get_method($method_name)
1198 } if $meta->has_method($method_name);
1203 sub find_next_method_by_name {
1204 my ($self, $method_name) = @_;
1205 (defined $method_name && length $method_name)
1206 || confess "You must define a method name to find";
1207 my @cpl = $self->linearized_isa;
1208 shift @cpl; # discard ourselves
1209 foreach my $class (@cpl) {
1210 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1211 return $method if defined $method;
1216 sub update_meta_instance_dependencies {
1219 if ( $self->{meta_instance_dependencies} ) {
1220 return $self->add_meta_instance_dependencies;
1224 sub add_meta_instance_dependencies {
1227 $self->remove_meta_instance_dependencies;
1229 my @attrs = $self->get_all_attributes();
1232 my @classes = grep { not $seen{ $_->name }++ }
1233 map { $_->associated_class } @attrs;
1235 foreach my $class (@classes) {
1236 $class->add_dependent_meta_instance($self);
1239 $self->{meta_instance_dependencies} = \@classes;
1242 sub remove_meta_instance_dependencies {
1245 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
1246 foreach my $class (@$classes) {
1247 $class->remove_dependent_meta_instance($self);
1257 sub add_dependent_meta_instance {
1258 my ( $self, $metaclass ) = @_;
1259 push @{ $self->{dependent_meta_instances} }, $metaclass;
1262 sub remove_dependent_meta_instance {
1263 my ( $self, $metaclass ) = @_;
1264 my $name = $metaclass->name;
1265 @$_ = grep { $_->name ne $name } @$_
1266 for $self->{dependent_meta_instances};
1269 sub invalidate_meta_instances {
1271 $_->invalidate_meta_instance()
1272 for $self, @{ $self->{dependent_meta_instances} };
1275 sub invalidate_meta_instance {
1277 undef $self->{_meta_instance};
1280 # check if we can reinitialize
1284 # if any local attr is defined
1285 return if $self->get_attribute_list;
1287 # or any non-declared methods
1288 for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
1289 return if $method->isa("Class::MOP::Method::Generated");
1290 # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
1298 sub is_mutable { 1 }
1299 sub is_immutable { 0 }
1301 sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
1303 sub _immutable_options {
1304 my ( $self, @args ) = @_;
1307 inline_accessors => 1,
1308 inline_constructor => 1,
1309 inline_destructor => 0,
1311 immutable_trait => $self->immutable_trait,
1312 constructor_name => $self->constructor_name,
1313 constructor_class => $self->constructor_class,
1314 destructor_class => $self->destructor_class,
1319 sub make_immutable {
1320 my ( $self, @args ) = @_;
1322 if ( $self->is_mutable ) {
1323 $self->_initialize_immutable( $self->_immutable_options(@args) );
1324 $self->_rebless_as_immutable(@args);
1335 if ( $self->is_immutable ) {
1336 my @args = $self->immutable_options;
1337 $self->_rebless_as_mutable();
1338 $self->_remove_inlined_code(@args);
1339 delete $self->{__immutable};
1347 sub _rebless_as_immutable {
1348 my ( $self, @args ) = @_;
1350 $self->{__immutable}{original_class} = ref $self;
1352 bless $self => $self->_immutable_metaclass(@args);
1355 sub _immutable_metaclass {
1356 my ( $self, %args ) = @_;
1358 if ( my $class = $args{immutable_metaclass} ) {
1362 my $trait = $args{immutable_trait} = $self->immutable_trait
1363 || confess "no immutable trait specified for $self";
1365 my $meta = $self->meta;
1366 my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
1370 if ( $meta_attr and $trait eq $meta_attr->default ) {
1371 # if the trait is the same as the default we try and pick a
1372 # predictable name for the immutable metaclass
1373 $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1376 $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1377 $trait, 'ForMetaClass', ref($self);
1381 if Class::MOP::is_class_loaded($class_name);
1383 # If the metaclass is a subclass of CMOP::Class which has had
1384 # metaclass roles applied (via Moose), then we want to make sure
1385 # that we preserve that anonymous class (see Fey::ORM for an
1386 # example of where this matters).
1387 my $meta_name = $meta->_real_ref_name;
1389 my $immutable_meta = $meta_name->create(
1391 superclasses => [ ref $self ],
1394 Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
1396 $immutable_meta->make_immutable(
1397 inline_constructor => 0,
1398 inline_accessors => 0,
1404 sub _remove_inlined_code {
1407 $self->remove_method( $_->name ) for $self->_inlined_methods;
1409 delete $self->{__immutable}{inlined_methods};
1412 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1414 sub _add_inlined_method {
1415 my ( $self, $method ) = @_;
1417 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1420 sub _initialize_immutable {
1421 my ( $self, %args ) = @_;
1423 $self->{__immutable}{options} = \%args;
1424 $self->_install_inlined_code(%args);
1427 sub _install_inlined_code {
1428 my ( $self, %args ) = @_;
1431 $self->_inline_accessors(%args) if $args{inline_accessors};
1432 $self->_inline_constructor(%args) if $args{inline_constructor};
1433 $self->_inline_destructor(%args) if $args{inline_destructor};
1436 sub _rebless_as_mutable {
1439 bless $self, $self->_get_mutable_metaclass_name;
1444 sub _inline_accessors {
1447 foreach my $attr_name ( $self->get_attribute_list ) {
1448 $self->get_attribute($attr_name)->install_accessors(1);
1452 sub _inline_constructor {
1453 my ( $self, %args ) = @_;
1455 my $name = $args{constructor_name};
1456 # A class may not even have a constructor, and that's okay.
1457 return unless defined $name;
1459 if ( $self->has_method($name) && !$args{replace_constructor} ) {
1460 my $class = $self->name;
1461 warn "Not inlining a constructor for $class since it defines"
1462 . " its own constructor.\n"
1463 . "If you are certain you don't need to inline your"
1464 . " constructor, specify inline_constructor => 0 in your"
1465 . " call to $class->meta->make_immutable\n";
1469 my $constructor_class = $args{constructor_class};
1471 Class::MOP::load_class($constructor_class);
1473 my $constructor = $constructor_class->new(
1477 package_name => $self->name,
1481 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1482 $self->add_method( $name => $constructor );
1483 $self->_add_inlined_method($constructor);
1487 sub _inline_destructor {
1488 my ( $self, %args ) = @_;
1490 ( exists $args{destructor_class} && defined $args{destructor_class} )
1491 || confess "The 'inline_destructor' option is present, but "
1492 . "no destructor class was specified";
1494 if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1495 my $class = $self->name;
1496 warn "Not inlining a destructor for $class since it defines"
1497 . " its own destructor.\n";
1501 my $destructor_class = $args{destructor_class};
1503 Class::MOP::load_class($destructor_class);
1505 return unless $destructor_class->is_needed($self);
1507 my $destructor = $destructor_class->new(
1510 package_name => $self->name,
1514 if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1515 $self->add_method( 'DESTROY' => $destructor );
1516 $self->_add_inlined_method($destructor);
1522 # ABSTRACT: Class Meta Object
1530 # assuming that class Foo
1531 # has been defined, you can
1533 # use this for introspection ...
1535 # add a method to Foo ...
1536 Foo->meta->add_method( 'bar' => sub {...} )
1538 # get a list of all the classes searched
1539 # the method dispatcher in the correct order
1540 Foo->meta->class_precedence_list()
1542 # remove a method from Foo
1543 Foo->meta->remove_method('bar');
1545 # or use this to actually create classes ...
1547 Class::MOP::Class->create(
1550 superclasses => ['Foo'],
1552 Class::MOP::Attribute->new('$bar'),
1553 Class::MOP::Attribute->new('$baz'),
1556 calculate_bar => sub {...},
1557 construct_baz => sub {...}
1564 The Class Protocol is the largest and most complex part of the
1565 Class::MOP meta-object protocol. It controls the introspection and
1566 manipulation of Perl 5 classes, and it can create them as well. The
1567 best way to understand what this module can do is to read the
1568 documentation for each of its methods.
1572 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1576 =head2 Class construction
1578 These methods all create new C<Class::MOP::Class> objects. These
1579 objects can represent existing classes or they can be used to create
1580 new classes from scratch.
1582 The metaclass object for a given class is a singleton. If you attempt
1583 to create a metaclass for the same class twice, you will just get the
1588 =item B<< Class::MOP::Class->create($package_name, %options) >>
1590 This method creates a new C<Class::MOP::Class> object with the given
1591 package name. It accepts a number of options:
1597 An optional version number for the newly created package.
1601 An optional authority for the newly created package.
1603 =item * superclasses
1605 An optional array reference of superclass names.
1609 An optional hash reference of methods for the class. The keys of the
1610 hash reference are method names and values are subroutine references.
1614 An optional array reference of L<Class::MOP::Attribute> objects.
1618 Specifies the name to install the C<meta> method for this class under.
1619 If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
1620 given, no meta method will be installed.
1624 If true, the metaclass that is stored in the global cache will be a
1627 Classes created in this way are destroyed once the metaclass they are
1628 attached to goes out of scope, and will be removed from Perl's internal
1631 All instances of a class with a weakened metaclass keep a special
1632 reference to the metaclass object, which prevents the metaclass from
1633 going out of scope while any instances exist.
1635 This only works if the instance is based on a hash reference, however.
1639 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1641 This method works just like C<< Class::MOP::Class->create >> but it
1642 creates an "anonymous" class. In fact, the class does have a name, but
1643 that name is a unique name generated internally by this module.
1645 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1646 parameters that C<create> accepts.
1648 Anonymous classes default to C<< weaken => 1 >>, although this can be
1651 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1653 This method will initialize a C<Class::MOP::Class> object for the
1654 named package. Unlike C<create>, this method I<will not> create a new
1657 The purpose of this method is to retrieve a C<Class::MOP::Class>
1658 object for introspecting an existing class.
1660 If an existing C<Class::MOP::Class> object exists for the named
1661 package, it will be returned, and any options provided will be
1664 If the object does not yet exist, it will be created.
1666 The valid options that can be passed to this method are
1667 C<attribute_metaclass>, C<method_metaclass>,
1668 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1669 optional, and default to the appropriate class in the C<Class::MOP>
1674 =head2 Object instance construction and cloning
1676 These methods are all related to creating and/or cloning object
1681 =item B<< $metaclass->clone_object($instance, %params) >>
1683 This method clones an existing object instance. Any parameters you
1684 provide are will override existing attribute values in the object.
1686 This is a convenience method for cloning an object instance, then
1687 blessing it into the appropriate package.
1689 You could implement a clone method in your class, using this method:
1692 my ($self, %params) = @_;
1693 $self->meta->clone_object($self, %params);
1696 =item B<< $metaclass->rebless_instance($instance, %params) >>
1698 This method changes the class of C<$instance> to the metaclass's class.
1700 You can only rebless an instance into a subclass of its current
1701 class. If you pass any additional parameters, these will be treated
1702 like constructor parameters and used to initialize the object's
1703 attributes. Any existing attributes that are already set will be
1706 Before reblessing the instance, this method will call
1707 C<rebless_instance_away> on the instance's current metaclass. This method
1708 will be passed the instance, the new metaclass, and any parameters
1709 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1710 does nothing; it is merely a hook.
1712 =item B<< $metaclass->rebless_instance_back($instance) >>
1714 Does the same thing as C<rebless_instance>, except that you can only
1715 rebless an instance into one of its superclasses. Any attributes that
1716 do not exist in the superclass will be deinitialized.
1718 This is a much more dangerous operation than C<rebless_instance>,
1719 especially when multiple inheritance is involved, so use this carefully!
1721 =item B<< $metaclass->new_object(%params) >>
1723 This method is used to create a new object of the metaclass's
1724 class. Any parameters you provide are used to initialize the
1725 instance's attributes. A special C<__INSTANCE__> key can be passed to
1726 provide an already generated instance, rather than having Class::MOP
1727 generate it for you. This is mostly useful for using Class::MOP with
1728 foreign classes which generate instances using their own constructors.
1730 =item B<< $metaclass->instance_metaclass >>
1732 Returns the class name of the instance metaclass. See
1733 L<Class::MOP::Instance> for more information on the instance
1736 =item B<< $metaclass->get_meta_instance >>
1738 Returns an instance of the C<instance_metaclass> to be used in the
1739 construction of a new instance of the class.
1743 =head2 Informational predicates
1745 These are a few predicate methods for asking information about the
1750 =item B<< $metaclass->is_anon_class >>
1752 This returns true if the class was created by calling C<<
1753 Class::MOP::Class->create_anon_class >>.
1755 =item B<< $metaclass->is_mutable >>
1757 This returns true if the class is still mutable.
1759 =item B<< $metaclass->is_immutable >>
1761 This returns true if the class has been made immutable.
1763 =item B<< $metaclass->is_pristine >>
1765 A class is I<not> pristine if it has non-inherited attributes or if it
1766 has any generated methods.
1770 =head2 Inheritance Relationships
1774 =item B<< $metaclass->superclasses(@superclasses) >>
1776 This is a read-write accessor which represents the superclass
1777 relationships of the metaclass's class.
1779 This is basically sugar around getting and setting C<@ISA>.
1781 =item B<< $metaclass->class_precedence_list >>
1783 This returns a list of all of the class's ancestor classes. The
1784 classes are returned in method dispatch order.
1786 =item B<< $metaclass->linearized_isa >>
1788 This returns a list based on C<class_precedence_list> but with all
1791 =item B<< $metaclass->subclasses >>
1793 This returns a list of all subclasses for this class, even indirect
1796 =item B<< $metaclass->direct_subclasses >>
1798 This returns a list of immediate subclasses for this class, which does not
1799 include indirect subclasses.
1803 =head2 Method introspection and creation
1805 These methods allow you to introspect a class's methods, as well as
1806 add, remove, or change methods.
1808 Determining what is truly a method in a Perl 5 class requires some
1809 heuristics (aka guessing).
1811 Methods defined outside the package with a fully qualified name (C<sub
1812 Package::name { ... }>) will be included. Similarly, methods named
1813 with a fully qualified name using L<Sub::Name> are also included.
1815 However, we attempt to ignore imported functions.
1817 Ultimately, we are using heuristics to determine what truly is a
1818 method in a class, and these heuristics may get the wrong answer in
1819 some edge cases. However, for most "normal" cases the heuristics work
1824 =item B<< $metaclass->get_method($method_name) >>
1826 This will return a L<Class::MOP::Method> for the specified
1827 C<$method_name>. If the class does not have the specified method, it
1830 =item B<< $metaclass->has_method($method_name) >>
1832 Returns a boolean indicating whether or not the class defines the
1833 named method. It does not include methods inherited from parent
1836 =item B<< $metaclass->get_method_list >>
1838 This will return a list of method I<names> for all methods defined in
1841 =item B<< $metaclass->add_method($method_name, $method) >>
1843 This method takes a method name and a subroutine reference, and adds
1844 the method to the class.
1846 The subroutine reference can be a L<Class::MOP::Method>, and you are
1847 strongly encouraged to pass a meta method object instead of a code
1848 reference. If you do so, that object gets stored as part of the
1849 class's method map directly. If not, the meta information will have to
1850 be recreated later, and may be incorrect.
1852 If you provide a method object, this method will clone that object if
1853 the object's package name does not match the class name. This lets us
1854 track the original source of any methods added from other classes
1855 (notably Moose roles).
1857 =item B<< $metaclass->remove_method($method_name) >>
1859 Remove the named method from the class. This method returns the
1860 L<Class::MOP::Method> object for the method.
1862 =item B<< $metaclass->method_metaclass >>
1864 Returns the class name of the method metaclass, see
1865 L<Class::MOP::Method> for more information on the method metaclass.
1867 =item B<< $metaclass->wrapped_method_metaclass >>
1869 Returns the class name of the wrapped method metaclass, see
1870 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1873 =item B<< $metaclass->get_all_methods >>
1875 This will traverse the inheritance hierarchy and return a list of all
1876 the L<Class::MOP::Method> objects for this class and its parents.
1878 =item B<< $metaclass->find_method_by_name($method_name) >>
1880 This will return a L<Class::MOP::Method> for the specified
1881 C<$method_name>. If the class does not have the specified method, it
1884 Unlike C<get_method>, this method I<will> look for the named method in
1887 =item B<< $metaclass->get_all_method_names >>
1889 This will return a list of method I<names> for all of this class's
1890 methods, including inherited methods.
1892 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1894 This method looks for the named method in the class and all of its
1895 parents. It returns every matching method it finds in the inheritance
1896 tree, so it returns a list of methods.
1898 Each method is returned as a hash reference with three keys. The keys
1899 are C<name>, C<class>, and C<code>. The C<code> key has a
1900 L<Class::MOP::Method> object as its value.
1902 The list of methods is distinct.
1904 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1906 This method returns the first method in any superclass matching the
1907 given name. It is effectively the method that C<SUPER::$method_name>
1912 =head2 Attribute introspection and creation
1914 Because Perl 5 does not have a core concept of attributes in classes,
1915 we can only return information about attributes which have been added
1916 via this class's methods. We cannot discover information about
1917 attributes which are defined in terms of "regular" Perl 5 methods.
1921 =item B<< $metaclass->get_attribute($attribute_name) >>
1923 This will return a L<Class::MOP::Attribute> for the specified
1924 C<$attribute_name>. If the class does not have the specified
1925 attribute, it returns C<undef>.
1927 NOTE that get_attribute does not search superclasses, for that you
1928 need to use C<find_attribute_by_name>.
1930 =item B<< $metaclass->has_attribute($attribute_name) >>
1932 Returns a boolean indicating whether or not the class defines the
1933 named attribute. It does not include attributes inherited from parent
1936 =item B<< $metaclass->get_attribute_list >>
1938 This will return a list of attributes I<names> for all attributes
1939 defined in this class. Note that this operates on the current class
1940 only, it does not traverse the inheritance hierarchy.
1942 =item B<< $metaclass->get_all_attributes >>
1944 This will traverse the inheritance hierarchy and return a list of all
1945 the L<Class::MOP::Attribute> objects for this class and its parents.
1947 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1949 This will return a L<Class::MOP::Attribute> for the specified
1950 C<$attribute_name>. If the class does not have the specified
1951 attribute, it returns C<undef>.
1953 Unlike C<get_attribute>, this attribute I<will> look for the named
1954 attribute in superclasses.
1956 =item B<< $metaclass->add_attribute(...) >>
1958 This method accepts either an existing L<Class::MOP::Attribute>
1959 object or parameters suitable for passing to that class's C<new>
1962 The attribute provided will be added to the class.
1964 Any accessor methods defined by the attribute will be added to the
1965 class when the attribute is added.
1967 If an attribute of the same name already exists, the old attribute
1968 will be removed first.
1970 =item B<< $metaclass->remove_attribute($attribute_name) >>
1972 This will remove the named attribute from the class, and
1973 L<Class::MOP::Attribute> object.
1975 Removing an attribute also removes any accessor methods defined by the
1978 However, note that removing an attribute will only affect I<future>
1979 object instances created for this class, not existing instances.
1981 =item B<< $metaclass->attribute_metaclass >>
1983 Returns the class name of the attribute metaclass for this class. By
1984 default, this is L<Class::MOP::Attribute>.
1988 =head2 Class Immutability
1990 Making a class immutable "freezes" the class definition. You can no
1991 longer call methods which alter the class, such as adding or removing
1992 methods or attributes.
1994 Making a class immutable lets us optimize the class by inlining some
1995 methods, and also allows us to optimize some methods on the metaclass
1998 After immutabilization, the metaclass object will cache most informational
1999 methods that returns information about methods or attributes. Methods which
2000 would alter the class, such as C<add_attribute> and C<add_method>, will
2001 throw an error on an immutable metaclass object.
2003 The immutabilization system in L<Moose> takes much greater advantage
2004 of the inlining features than Class::MOP itself does.
2008 =item B<< $metaclass->make_immutable(%options) >>
2010 This method will create an immutable transformer and use it to make
2011 the class and its metaclass object immutable.
2013 This method accepts the following options:
2017 =item * inline_accessors
2019 =item * inline_constructor
2021 =item * inline_destructor
2023 These are all booleans indicating whether the specified method(s)
2026 By default, accessors and the constructor are inlined, but not the
2029 =item * immutable_trait
2031 The name of a class which will be used as a parent class for the
2032 metaclass object being made immutable. This "trait" implements the
2033 post-immutability functionality of the metaclass (but not the
2034 transformation itself).
2036 This defaults to L<Class::MOP::Class::Immutable::Trait>.
2038 =item * constructor_name
2040 This is the constructor method name. This defaults to "new".
2042 =item * constructor_class
2044 The name of the method metaclass for constructors. It will be used to
2045 generate the inlined constructor. This defaults to
2046 "Class::MOP::Method::Constructor".
2048 =item * replace_constructor
2050 This is a boolean indicating whether an existing constructor should be
2051 replaced when inlining a constructor. This defaults to false.
2053 =item * destructor_class
2055 The name of the method metaclass for destructors. It will be used to
2056 generate the inlined destructor. This defaults to
2057 "Class::MOP::Method::Denstructor".
2059 =item * replace_destructor
2061 This is a boolean indicating whether an existing destructor should be
2062 replaced when inlining a destructor. This defaults to false.
2066 =item B<< $metaclass->immutable_options >>
2068 Returns a hash of the options used when making the class immutable, including
2069 both defaults and anything supplied by the user in the call to C<<
2070 $metaclass->make_immutable >>. This is useful if you need to temporarily make
2071 a class mutable and then restore immutability as it was before.
2073 =item B<< $metaclass->make_mutable >>
2075 Calling this method reverse the immutabilization transformation.
2079 =head2 Method Modifiers
2081 Method modifiers are hooks which allow a method to be wrapped with
2082 I<before>, I<after> and I<around> method modifiers. Every time a
2083 method is called, its modifiers are also called.
2085 A class can modify its own methods, as well as methods defined in
2088 =head3 How method modifiers work?
2090 Method modifiers work by wrapping the original method and then
2091 replacing it in the class's symbol table. The wrappers will handle
2092 calling all the modifiers in the appropriate order and preserving the
2093 calling context for the original method.
2095 The return values of C<before> and C<after> modifiers are
2096 ignored. This is because their purpose is B<not> to filter the input
2097 and output of the primary method (this is done with an I<around>
2100 This may seem like an odd restriction to some, but doing this allows
2101 for simple code to be added at the beginning or end of a method call
2102 without altering the function of the wrapped method or placing any
2103 extra responsibility on the code of the modifier.
2105 Of course if you have more complex needs, you can use the C<around>
2106 modifier which allows you to change both the parameters passed to the
2107 wrapped method, as well as its return value.
2109 Before and around modifiers are called in last-defined-first-called
2110 order, while after modifiers are called in first-defined-first-called
2111 order. So the call tree might looks something like this:
2123 =head3 What is the performance impact?
2125 Of course there is a performance cost associated with method
2126 modifiers, but we have made every effort to make that cost directly
2127 proportional to the number of modifier features you use.
2129 The wrapping method does its best to B<only> do as much work as it
2130 absolutely needs to. In order to do this we have moved some of the
2131 performance costs to set-up time, where they are easier to amortize.
2133 All this said, our benchmarks have indicated the following:
2135 simple wrapper with no modifiers 100% slower
2136 simple wrapper with simple before modifier 400% slower
2137 simple wrapper with simple after modifier 450% slower
2138 simple wrapper with simple around modifier 500-550% slower
2139 simple wrapper with all 3 modifiers 1100% slower
2141 These numbers may seem daunting, but you must remember, every feature
2142 comes with some cost. To put things in perspective, just doing a
2143 simple C<AUTOLOAD> which does nothing but extract the name of the
2144 method called and return it costs about 400% over a normal method
2149 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
2151 This wraps the specified method with the supplied subroutine
2152 reference. The modifier will be called as a method itself, and will
2153 receive the same arguments as are passed to the method.
2155 When the modifier exits, the wrapped method will be called.
2157 The return value of the modifier will be ignored.
2159 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
2161 This wraps the specified method with the supplied subroutine
2162 reference. The modifier will be called as a method itself, and will
2163 receive the same arguments as are passed to the method.
2165 When the wrapped methods exits, the modifier will be called.
2167 The return value of the modifier will be ignored.
2169 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
2171 This wraps the specified method with the supplied subroutine
2174 The first argument passed to the modifier will be a subroutine
2175 reference to the wrapped method. The second argument is the object,
2176 and after that come any arguments passed when the method is called.
2178 The around modifier can choose to call the original method, as well as
2179 what arguments to pass if it does so.
2181 The return value of the modifier is what will be seen by the caller.
2185 =head2 Introspection
2189 =item B<< Class::MOP::Class->meta >>
2191 This will return a L<Class::MOP::Class> instance for this class.
2193 It should also be noted that L<Class::MOP> will actually bootstrap
2194 this module by installing a number of attribute meta-objects into its
2203 =item B<< $metaclass->free_anon_class >>
2205 This removes the metaclass from the symbol table and L<Class::MOP>'s own
2206 bookkeeping. This should probably only be called by L</DESTROY>.