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 our $VERSION = '1.11';
21 $VERSION = eval $VERSION;
22 our $AUTHORITY = 'cpan:STEVAN';
24 use base 'Class::MOP::Module',
25 'Class::MOP::Mixin::HasAttributes',
26 'Class::MOP::Mixin::HasMethods';
36 $package_name = shift;
39 $package_name = $options{package};
42 ($package_name && !ref($package_name))
43 || confess "You must pass a package name and it cannot be blessed";
45 return Class::MOP::get_metaclass_by_name($package_name)
46 || $class->_construct_class_instance(package => $package_name, @_);
50 my ( $class, @args ) = @_;
51 unshift @args, "package" if @args % 2;
53 my $old_metaclass = blessed($options{package})
55 : Class::MOP::get_metaclass_by_name($options{package});
56 $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name)
57 if !exists $options{weaken}
58 && blessed($old_metaclass)
59 && $old_metaclass->isa('Class::MOP::Class');
60 $old_metaclass->_remove_generated_metaobjects
61 if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
62 my $new_metaclass = $class->SUPER::reinitialize(%options);
63 $new_metaclass->_restore_metaobjects_from($old_metaclass)
64 if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
65 return $new_metaclass;
68 # NOTE: (meta-circularity)
69 # this is a special form of _construct_instance
70 # (see below), which is used to construct class
71 # meta-object instances for any Class::MOP::*
72 # class. All other classes will use the more
73 # normal &construct_instance.
74 sub _construct_class_instance {
76 my $options = @_ == 1 ? $_[0] : {@_};
77 my $package_name = $options->{package};
78 (defined $package_name && $package_name)
79 || confess "You must pass a package name";
81 # return the metaclass if we have it cached,
82 # and it is still defined (it has not been
83 # reaped by DESTROY yet, which can happen
84 # annoyingly enough during global destruction)
86 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
92 ? $class->_real_ref_name
95 # now create the metaclass
97 if ($class eq 'Class::MOP::Class') {
98 $meta = $class->_new($options);
102 # it is safe to use meta here because
103 # class will always be a subclass of
104 # Class::MOP::Class, which defines meta
105 $meta = $class->meta->_construct_instance($options)
108 # and check the metaclass compatibility
109 $meta->_check_metaclass_compatibility();
111 Class::MOP::store_metaclass_by_name($package_name, $meta);
114 # we need to weaken any anon classes
115 # so that they can call DESTROY properly
116 Class::MOP::weaken_metaclass($package_name) if $options->{weaken};
124 # NOTE: we need to deal with the possibility of class immutability here,
125 # and then get the name of the class appropriately
126 return $self->is_immutable
127 ? $self->_get_mutable_metaclass_name()
134 return Class::MOP::Class->initialize($class)->new_object(@_)
135 if $class ne __PACKAGE__;
137 my $options = @_ == 1 ? $_[0] : {@_};
140 # inherited from Class::MOP::Package
141 'package' => $options->{package},
144 # since the following attributes will
145 # actually be loaded from the symbol
146 # table, and actually bypass the instance
147 # entirely, we can just leave these things
148 # listed here for reference, because they
149 # should not actually have a value associated
151 'namespace' => \undef,
154 # inherited from Class::MOP::Module
156 'authority' => \undef,
158 # defined in Class::MOP::Class
159 'superclasses' => \undef,
162 'attribute_metaclass' =>
163 ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
164 'method_metaclass' =>
165 ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
166 'wrapped_method_metaclass' => (
167 $options->{'wrapped_method_metaclass'}
168 || 'Class::MOP::Method::Wrapped'
170 'instance_metaclass' =>
171 ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
172 'immutable_trait' => (
173 $options->{'immutable_trait'}
174 || 'Class::MOP::Class::Immutable::Trait'
176 'constructor_name' => ( $options->{constructor_name} || 'new' ),
177 'constructor_class' => (
178 $options->{constructor_class} || 'Class::MOP::Method::Constructor'
180 'destructor_class' => $options->{destructor_class},
184 ## Metaclass compatibility
186 my %base_metaclass = (
187 attribute_metaclass => 'Class::MOP::Attribute',
188 method_metaclass => 'Class::MOP::Method',
189 wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
190 instance_metaclass => 'Class::MOP::Instance',
191 constructor_class => 'Class::MOP::Method::Constructor',
192 destructor_class => 'Class::MOP::Method::Destructor',
195 sub _base_metaclasses { %base_metaclass }
198 sub _check_metaclass_compatibility {
201 my @superclasses = $self->superclasses
204 $self->_fix_metaclass_incompatibility(@superclasses);
206 my %base_metaclass = $self->_base_metaclasses;
208 # this is always okay ...
210 if ref($self) eq 'Class::MOP::Class'
212 my $meta = $self->$_;
213 !defined($meta) || $meta eq $base_metaclass{$_};
215 keys %base_metaclass;
217 for my $superclass (@superclasses) {
218 $self->_check_class_metaclass_compatibility($superclass);
221 for my $metaclass_type ( keys %base_metaclass ) {
222 next unless defined $self->$metaclass_type;
223 for my $superclass (@superclasses) {
224 $self->_check_single_metaclass_compatibility( $metaclass_type,
230 sub _check_class_metaclass_compatibility {
232 my ( $superclass_name ) = @_;
234 if (!$self->_class_metaclass_is_compatible($superclass_name)) {
235 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
237 my $super_meta_type = $super_meta->_real_ref_name;
239 confess "The metaclass of " . $self->name . " ("
240 . (ref($self)) . ")" . " is not compatible with "
241 . "the metaclass of its superclass, "
242 . $superclass_name . " (" . ($super_meta_type) . ")";
246 sub _class_metaclass_is_compatible {
248 my ( $superclass_name ) = @_;
250 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
253 my $super_meta_name = $super_meta->_real_ref_name;
255 return $self->_is_compatible_with($super_meta_name);
258 sub _check_single_metaclass_compatibility {
260 my ( $metaclass_type, $superclass_name ) = @_;
262 if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
263 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
264 my $metaclass_type_name = $metaclass_type;
265 $metaclass_type_name =~ s/_(?:meta)?class$//;
266 $metaclass_type_name =~ s/_/ /g;
267 confess "The $metaclass_type_name metaclass for "
268 . $self->name . " (" . ($self->$metaclass_type)
269 . ")" . " is not compatible with the "
270 . "$metaclass_type_name metaclass of its "
271 . "superclass, $superclass_name ("
272 . ($super_meta->$metaclass_type) . ")";
276 sub _single_metaclass_is_compatible {
278 my ( $metaclass_type, $superclass_name ) = @_;
280 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
283 # for instance, Moose::Meta::Class has a error_class attribute, but
284 # Class::MOP::Class doesn't - this shouldn't be an error
285 return 1 unless $super_meta->can($metaclass_type);
286 # for instance, Moose::Meta::Class has a destructor_class, but
287 # Class::MOP::Class doesn't - this shouldn't be an error
288 return 1 unless defined $super_meta->$metaclass_type;
289 # if metaclass is defined in superclass but not here, it's not compatible
290 # this is a really odd case
291 return 0 unless defined $self->$metaclass_type;
293 return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
296 sub _fix_metaclass_incompatibility {
298 my @supers = map { Class::MOP::Class->initialize($_) } @_;
301 for my $super (@supers) {
303 if $self->_can_fix_metaclass_incompatibility($super);
305 return unless $necessary;
307 for my $super (@supers) {
308 if (!$self->_class_metaclass_is_compatible($super->name)) {
309 $self->_fix_class_metaclass_incompatibility($super);
313 my %base_metaclass = $self->_base_metaclasses;
314 for my $metaclass_type (keys %base_metaclass) {
315 for my $super (@supers) {
316 if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
317 $self->_fix_single_metaclass_incompatibility(
318 $metaclass_type, $super
325 sub _can_fix_metaclass_incompatibility {
327 my ($super_meta) = @_;
329 return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
331 my %base_metaclass = $self->_base_metaclasses;
332 for my $metaclass_type (keys %base_metaclass) {
333 return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
339 sub _class_metaclass_can_be_made_compatible {
341 my ($super_meta) = @_;
343 return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
346 sub _single_metaclass_can_be_made_compatible {
348 my ($super_meta, $metaclass_type) = @_;
350 my $specific_meta = $self->$metaclass_type;
352 return unless $super_meta->can($metaclass_type);
353 my $super_specific_meta = $super_meta->$metaclass_type;
355 # for instance, Moose::Meta::Class has a destructor_class, but
356 # Class::MOP::Class doesn't - this shouldn't be an error
357 return unless defined $super_specific_meta;
359 # if metaclass is defined in superclass but not here, it's fixable
360 # this is a really odd case
361 return 1 unless defined $specific_meta;
363 return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
366 sub _fix_class_metaclass_incompatibility {
368 my ( $super_meta ) = @_;
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.";
376 my $super_meta_name = $super_meta->_real_ref_name;
378 $self->_make_compatible_with($super_meta_name);
382 sub _fix_single_metaclass_incompatibility {
384 my ( $metaclass_type, $super_meta ) = @_;
386 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
388 || confess "Can't fix metaclass incompatibility for "
390 . " because it is not pristine.";
392 my $new_metaclass = $self->$metaclass_type
393 ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
394 : $super_meta->$metaclass_type;
395 $self->{$metaclass_type} = $new_metaclass;
399 sub _restore_metaobjects_from {
403 $self->_restore_metamethods_from($old_meta);
404 $self->_restore_metaattributes_from($old_meta);
407 sub _remove_generated_metaobjects {
410 for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
411 $attr->remove_accessors;
419 # this should be sufficient, if you have a
420 # use case where it is not, write a test and
422 my $ANON_CLASS_SERIAL = 0;
425 # we need a sufficiently annoying prefix
426 # this should suffice for now, this is
427 # used in a couple of places below, so
428 # need to put it up here for now.
429 my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
433 no warnings 'uninitialized';
434 $self->name =~ /^$ANON_CLASS_PREFIX/o;
437 sub create_anon_class {
438 my ($class, %options) = @_;
439 $options{weaken} = 1 unless exists $options{weaken};
440 my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
441 return $class->create($package_name, %options);
445 # this will only get called for
446 # anon-classes, all other calls
447 # are assumed to occur during
448 # global destruction and so don't
449 # really need to be handled explicitly
453 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
455 no warnings 'uninitialized';
456 my $name = $self->name;
457 return unless $name =~ /^$ANON_CLASS_PREFIX/o;
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 my $current_meta = Class::MOP::get_metaclass_by_name($name);
465 return if $current_meta ne $self;
467 my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
469 @{$name . '::ISA'} = ();
470 %{$name . '::'} = ();
471 delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
473 Class::MOP::remove_metaclass_by_name($name);
478 # creating classes with MOP ...
481 my ( $class, @args ) = @_;
483 unshift @args, 'package' if @args % 2 == 1;
485 my (%options) = @args;
486 my $package_name = $options{package};
488 (ref $options{superclasses} eq 'ARRAY')
489 || confess "You must pass an ARRAY ref of superclasses"
490 if exists $options{superclasses};
492 (ref $options{attributes} eq 'ARRAY')
493 || confess "You must pass an ARRAY ref of attributes"
494 if exists $options{attributes};
496 (ref $options{methods} eq 'HASH')
497 || confess "You must pass a HASH ref of methods"
498 if exists $options{methods};
500 $options{meta_name} = 'meta'
501 unless exists $options{meta_name};
503 my (%initialize_options) = @args;
504 delete @initialize_options{qw(
513 my $meta = $class->initialize( $package_name => %initialize_options );
515 $meta->_instantiate_module( $options{version}, $options{authority} );
517 $meta->_add_meta_method($options{meta_name})
518 if defined $options{meta_name};
520 $meta->superclasses(@{$options{superclasses}})
521 if exists $options{superclasses};
523 # process attributes first, so that they can
524 # install accessors, but locally defined methods
525 # can then overwrite them. It is maybe a little odd, but
526 # I think this should be the order of things.
527 if (exists $options{attributes}) {
528 foreach my $attr (@{$options{attributes}}) {
529 $meta->add_attribute($attr);
532 if (exists $options{methods}) {
533 foreach my $method_name (keys %{$options{methods}}) {
534 $meta->add_method($method_name, $options{methods}->{$method_name});
540 # Instance Construction & Cloning
546 # we need to protect the integrity of the
547 # Class::MOP::Class singletons here, so we
548 # delegate this to &construct_class_instance
549 # which will deal with the singletons
550 return $class->_construct_class_instance(@_)
551 if $class->name->isa('Class::MOP::Class');
552 return $class->_construct_instance(@_);
555 sub _construct_instance {
557 my $params = @_ == 1 ? $_[0] : {@_};
558 my $meta_instance = $class->get_meta_instance();
560 # the code below is almost certainly incorrect
561 # but this is foreign inheritance, so we might
562 # have to kludge it in the end.
564 if (my $instance_class = blessed($params->{__INSTANCE__})) {
565 ($instance_class eq $class->name)
566 || confess "Objects passed as the __INSTANCE__ parameter must "
567 . "already be blessed into the correct class, but "
568 . "$params->{__INSTANCE__} is not a " . $class->name;
569 $instance = $params->{__INSTANCE__};
571 elsif (exists $params->{__INSTANCE__}) {
572 confess "The __INSTANCE__ parameter must be a blessed reference, not "
573 . $params->{__INSTANCE__};
576 $instance = $meta_instance->create_instance();
578 foreach my $attr ($class->get_all_attributes()) {
579 $attr->initialize_instance_slot($meta_instance, $instance, $params);
581 if (Class::MOP::metaclass_is_weak($class->name)) {
582 $meta_instance->_set_mop_slot($instance, $class);
587 sub _inline_new_object {
592 'my $class = shift;',
593 'return Class::MOP::Class->initialize($class)->new_object(@_)',
594 'if $class ne \'' . $self->name . '\';',
595 'my $params = @_ == 1 ? $_[0] : {@_};',
596 'my $instance = ' . $self->_inline_create_instance('$class') . ';',
597 (map { $self->_inline_slot_initializer($_, $idx++) }
598 $self->get_all_attributes),
599 $self->_inline_preserve_weak_metaclasses,
604 sub _inline_create_instance {
607 return $self->get_meta_instance->inline_create_instance(@_);
610 sub _inline_slot_initializer {
612 my ($attr, $idx) = @_;
614 my $default = $self->_inline_default_value($attr, $idx);
616 if (defined(my $init_arg = $attr->init_arg)) {
618 'if (exists $params->{\'' . $init_arg . '\'}) {',
619 $attr->_inline_set_value(
620 '$instance', '$params->{\'' . $init_arg . '\'}'
624 if (defined $default) {
627 $attr->_inline_set_value('$instance', $default),
633 elsif (defined $default) {
634 return $attr->_inline_set_value('$instance', $default);
641 sub _inline_default_value {
643 my ($attr, $index) = @_;
645 if ($attr->has_default) {
647 # default values can either be CODE refs
648 # in which case we need to call them. Or
649 # they can be scalars (strings/numbers)
650 # in which case we can just deal with them
651 # in the code we eval.
652 if ($attr->is_default_a_coderef) {
653 return '$defaults->[' . $index . ']->($instance)';
656 return '$defaults->[' . $index . ']';
659 elsif ($attr->has_builder) {
660 return '$instance->' . $attr->builder;
667 sub _inline_preserve_weak_metaclasses {
669 if (Class::MOP::metaclass_is_weak($self->name)) {
671 $self->_inline_set_mop_slot(
672 '$instance', 'Class::MOP::class_of($class)'
682 sub get_meta_instance {
684 $self->{'_meta_instance'} ||= $self->_create_meta_instance();
687 sub _create_meta_instance {
690 my $instance = $self->instance_metaclass->new(
691 associated_metaclass => $self,
692 attributes => [ $self->get_all_attributes() ],
695 $self->add_meta_instance_dependencies()
696 if $instance->is_dependent_on_superclasses();
701 sub _inline_rebless_instance {
704 return $self->get_meta_instance->inline_rebless_instance_structure(@_);
707 sub _inline_get_mop_slot {
710 return $self->get_meta_instance->_inline_get_mop_slot(@_);
713 sub _inline_set_mop_slot {
716 return $self->get_meta_instance->_inline_set_mop_slot(@_);
719 sub _inline_clear_mop_slot {
722 return $self->get_meta_instance->_inline_clear_mop_slot(@_);
727 my $instance = shift;
728 (blessed($instance) && $instance->isa($class->name))
729 || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
732 # we need to protect the integrity of the
733 # Class::MOP::Class singletons here, they
734 # should not be cloned.
735 return $instance if $instance->isa('Class::MOP::Class');
736 $class->_clone_instance($instance, @_);
739 sub _clone_instance {
740 my ($class, $instance, %params) = @_;
742 || confess "You can only clone instances, ($instance) is not a blessed instance";
743 my $meta_instance = $class->get_meta_instance();
744 my $clone = $meta_instance->clone_instance($instance);
745 foreach my $attr ($class->get_all_attributes()) {
746 if ( defined( my $init_arg = $attr->init_arg ) ) {
747 if (exists $params{$init_arg}) {
748 $attr->set_value($clone, $params{$init_arg});
755 sub _force_rebless_instance {
756 my ($self, $instance, %params) = @_;
757 my $old_metaclass = Class::MOP::class_of($instance);
759 $old_metaclass->rebless_instance_away($instance, $self, %params)
762 my $meta_instance = $self->get_meta_instance;
764 if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
765 $meta_instance->_clear_mop_slot($instance);
769 # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
770 $meta_instance->rebless_instance_structure($_[1], $self);
772 $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
774 if (Class::MOP::metaclass_is_weak($self->name)) {
775 $meta_instance->_set_mop_slot($instance, $self);
779 sub rebless_instance {
780 my ($self, $instance, %params) = @_;
781 my $old_metaclass = Class::MOP::class_of($instance);
783 my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
784 $self->name->isa($old_class)
785 || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
787 $self->_force_rebless_instance($_[1], %params);
792 sub rebless_instance_back {
793 my ( $self, $instance ) = @_;
794 my $old_metaclass = Class::MOP::class_of($instance);
797 = $old_metaclass ? $old_metaclass->name : blessed($instance);
798 $old_class->isa( $self->name )
800 "You may rebless only into a superclass of ($old_class), of which ("
804 $self->_force_rebless_instance($_[1]);
809 sub rebless_instance_away {
810 # this intentionally does nothing, it is just a hook
813 sub _fixup_attributes_after_rebless {
815 my ($instance, $rebless_from, %params) = @_;
816 my $meta_instance = $self->get_meta_instance;
818 for my $attr ( $rebless_from->get_all_attributes ) {
819 next if $self->find_attribute_by_name( $attr->name );
820 $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
823 foreach my $attr ( $self->get_all_attributes ) {
824 if ( $attr->has_value($instance) ) {
825 if ( defined( my $init_arg = $attr->init_arg ) ) {
826 $params{$init_arg} = $attr->get_value($instance)
827 unless exists $params{$init_arg};
830 $attr->set_value($instance, $attr->get_value($instance));
835 foreach my $attr ($self->get_all_attributes) {
836 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
840 sub _attach_attribute {
841 my ($self, $attribute) = @_;
842 $attribute->attach_to_class($self);
845 sub _post_add_attribute {
846 my ( $self, $attribute ) = @_;
848 $self->invalidate_meta_instances;
850 # invalidate package flag here
853 $attribute->install_accessors;
856 $self->remove_attribute( $attribute->name );
861 sub remove_attribute {
864 my $removed_attribute = $self->SUPER::remove_attribute(@_)
867 $self->invalidate_meta_instances;
869 $removed_attribute->remove_accessors;
870 $removed_attribute->detach_from_class;
872 return$removed_attribute;
875 sub find_attribute_by_name {
876 my ( $self, $attr_name ) = @_;
878 foreach my $class ( $self->linearized_isa ) {
879 # fetch the meta-class ...
880 my $meta = Class::MOP::Class->initialize($class);
881 return $meta->get_attribute($attr_name)
882 if $meta->has_attribute($attr_name);
888 sub get_all_attributes {
890 my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
891 reverse $self->linearized_isa;
892 return values %attrs;
900 my $isa = $self->get_or_add_package_symbol('@ISA');
907 # on 5.8 and below, we need to call
908 # a method to get Perl to detect
909 # a cycle in the class hierarchy
910 my $class = $self->name;
914 # we need to check the metaclass
915 # compatibility here so that we can
916 # be sure that the superclass is
917 # not potentially creating an issues
918 # we don't know about
920 $self->_check_metaclass_compatibility();
921 $self->_superclasses_updated();
927 sub _superclasses_updated {
929 $self->update_meta_instance_dependencies();
930 # keep strong references to all our parents, so they don't disappear if
931 # they are anon classes and don't have any direct instances
932 $self->_superclass_metas(
933 map { Class::MOP::class_of($_) } $self->superclasses
937 sub _superclass_metas {
939 $self->{_superclass_metas} = [@_];
944 my $super_class = $self->name;
946 return @{ $super_class->mro::get_isarev() };
949 sub direct_subclasses {
951 my $super_class = $self->name;
956 } Class::MOP::Class->initialize($_)->superclasses
961 return @{ mro::get_linear_isa( (shift)->name ) };
964 sub class_precedence_list {
966 my $name = $self->name;
968 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
970 # We need to check for circular inheritance here
971 # if we are are not on 5.10, cause 5.8 detects it
972 # late. This will do nothing if all is well, and
973 # blow up otherwise. Yes, it's an ugly hack, better
974 # suggestions are welcome.
976 ($name || return)->isa('This is a test for circular inheritance')
979 # if our mro is c3, we can
980 # just grab the linear_isa
981 if (mro::get_mro($name) eq 'c3') {
982 return @{ mro::get_linear_isa($name) }
986 # we can't grab the linear_isa for dfs
987 # since it has all the duplicates
992 Class::MOP::Class->initialize($_)->class_precedence_list()
993 } $self->superclasses()
1001 my $fetch_and_prepare_method = sub {
1002 my ($self, $method_name) = @_;
1003 my $wrapped_metaclass = $self->wrapped_method_metaclass;
1005 my $method = $self->get_method($method_name);
1006 # if we dont have local ...
1008 # try to find the next method
1009 $method = $self->find_next_method_by_name($method_name);
1010 # die if it does not exist
1012 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
1013 # and now make sure to wrap it
1014 # even if it is already wrapped
1015 # because we need a new sub ref
1016 $method = $wrapped_metaclass->wrap($method,
1017 package_name => $self->name,
1018 name => $method_name,
1022 # now make sure we wrap it properly
1023 $method = $wrapped_metaclass->wrap($method,
1024 package_name => $self->name,
1025 name => $method_name,
1026 ) unless $method->isa($wrapped_metaclass);
1028 $self->add_method($method_name => $method);
1032 sub add_before_method_modifier {
1033 my ($self, $method_name, $method_modifier) = @_;
1034 (defined $method_name && length $method_name)
1035 || confess "You must pass in a method name";
1036 my $method = $fetch_and_prepare_method->($self, $method_name);
1037 $method->add_before_modifier(
1038 subname(':before' => $method_modifier)
1042 sub add_after_method_modifier {
1043 my ($self, $method_name, $method_modifier) = @_;
1044 (defined $method_name && length $method_name)
1045 || confess "You must pass in a method name";
1046 my $method = $fetch_and_prepare_method->($self, $method_name);
1047 $method->add_after_modifier(
1048 subname(':after' => $method_modifier)
1052 sub add_around_method_modifier {
1053 my ($self, $method_name, $method_modifier) = @_;
1054 (defined $method_name && length $method_name)
1055 || confess "You must pass in a method name";
1056 my $method = $fetch_and_prepare_method->($self, $method_name);
1057 $method->add_around_modifier(
1058 subname(':around' => $method_modifier)
1063 # the methods above used to be named like this:
1064 # ${pkg}::${method}:(before|after|around)
1065 # but this proved problematic when using one modifier
1066 # to wrap multiple methods (something which is likely
1067 # to happen pretty regularly IMO). So instead of naming
1068 # it like this, I have chosen to just name them purely
1069 # with their modifier names, like so:
1070 # :(before|after|around)
1071 # The fact is that in a stack trace, it will be fairly
1072 # evident from the context what method they are attached
1073 # to, and so don't need the fully qualified name.
1076 sub find_method_by_name {
1077 my ($self, $method_name) = @_;
1078 (defined $method_name && length $method_name)
1079 || confess "You must define a method name to find";
1080 foreach my $class ($self->linearized_isa) {
1081 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1082 return $method if defined $method;
1087 sub get_all_methods {
1091 for my $class ( reverse $self->linearized_isa ) {
1092 my $meta = Class::MOP::Class->initialize($class);
1094 $methods{ $_->name } = $_ for $meta->_get_local_methods;
1097 return values %methods;
1100 sub get_all_method_names {
1103 return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
1106 sub find_all_methods_by_name {
1107 my ($self, $method_name) = @_;
1108 (defined $method_name && length $method_name)
1109 || confess "You must define a method name to find";
1111 foreach my $class ($self->linearized_isa) {
1112 # fetch the meta-class ...
1113 my $meta = Class::MOP::Class->initialize($class);
1115 name => $method_name,
1117 code => $meta->get_method($method_name)
1118 } if $meta->has_method($method_name);
1123 sub find_next_method_by_name {
1124 my ($self, $method_name) = @_;
1125 (defined $method_name && length $method_name)
1126 || confess "You must define a method name to find";
1127 my @cpl = $self->linearized_isa;
1128 shift @cpl; # discard ourselves
1129 foreach my $class (@cpl) {
1130 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1131 return $method if defined $method;
1136 sub update_meta_instance_dependencies {
1139 if ( $self->{meta_instance_dependencies} ) {
1140 return $self->add_meta_instance_dependencies;
1144 sub add_meta_instance_dependencies {
1147 $self->remove_meta_instance_dependencies;
1149 my @attrs = $self->get_all_attributes();
1152 my @classes = grep { not $seen{ $_->name }++ }
1153 map { $_->associated_class } @attrs;
1155 foreach my $class (@classes) {
1156 $class->add_dependent_meta_instance($self);
1159 $self->{meta_instance_dependencies} = \@classes;
1162 sub remove_meta_instance_dependencies {
1165 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
1166 foreach my $class (@$classes) {
1167 $class->remove_dependent_meta_instance($self);
1177 sub add_dependent_meta_instance {
1178 my ( $self, $metaclass ) = @_;
1179 push @{ $self->{dependent_meta_instances} }, $metaclass;
1182 sub remove_dependent_meta_instance {
1183 my ( $self, $metaclass ) = @_;
1184 my $name = $metaclass->name;
1185 @$_ = grep { $_->name ne $name } @$_
1186 for $self->{dependent_meta_instances};
1189 sub invalidate_meta_instances {
1191 $_->invalidate_meta_instance()
1192 for $self, @{ $self->{dependent_meta_instances} };
1195 sub invalidate_meta_instance {
1197 undef $self->{_meta_instance};
1200 # check if we can reinitialize
1204 # if any local attr is defined
1205 return if $self->get_attribute_list;
1207 # or any non-declared methods
1208 for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
1209 return if $method->isa("Class::MOP::Method::Generated");
1210 # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
1218 sub is_mutable { 1 }
1219 sub is_immutable { 0 }
1221 sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
1223 sub _immutable_options {
1224 my ( $self, @args ) = @_;
1227 inline_accessors => 1,
1228 inline_constructor => 1,
1229 inline_destructor => 0,
1231 immutable_trait => $self->immutable_trait,
1232 constructor_name => $self->constructor_name,
1233 constructor_class => $self->constructor_class,
1234 destructor_class => $self->destructor_class,
1239 sub make_immutable {
1240 my ( $self, @args ) = @_;
1242 if ( $self->is_mutable ) {
1243 $self->_initialize_immutable( $self->_immutable_options(@args) );
1244 $self->_rebless_as_immutable(@args);
1255 if ( $self->is_immutable ) {
1256 my @args = $self->immutable_options;
1257 $self->_rebless_as_mutable();
1258 $self->_remove_inlined_code(@args);
1259 delete $self->{__immutable};
1267 sub _rebless_as_immutable {
1268 my ( $self, @args ) = @_;
1270 $self->{__immutable}{original_class} = ref $self;
1272 bless $self => $self->_immutable_metaclass(@args);
1275 sub _immutable_metaclass {
1276 my ( $self, %args ) = @_;
1278 if ( my $class = $args{immutable_metaclass} ) {
1282 my $trait = $args{immutable_trait} = $self->immutable_trait
1283 || confess "no immutable trait specified for $self";
1285 my $meta = $self->meta;
1286 my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
1290 if ( $meta_attr and $trait eq $meta_attr->default ) {
1291 # if the trait is the same as the default we try and pick a
1292 # predictable name for the immutable metaclass
1293 $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1296 $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1297 $trait, 'ForMetaClass', ref($self);
1301 if Class::MOP::is_class_loaded($class_name);
1303 # If the metaclass is a subclass of CMOP::Class which has had
1304 # metaclass roles applied (via Moose), then we want to make sure
1305 # that we preserve that anonymous class (see Fey::ORM for an
1306 # example of where this matters).
1307 my $meta_name = $meta->_real_ref_name;
1309 my $immutable_meta = $meta_name->create(
1311 superclasses => [ ref $self ],
1314 Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
1316 $immutable_meta->make_immutable(
1317 inline_constructor => 0,
1318 inline_accessors => 0,
1324 sub _remove_inlined_code {
1327 $self->remove_method( $_->name ) for $self->_inlined_methods;
1329 delete $self->{__immutable}{inlined_methods};
1332 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1334 sub _add_inlined_method {
1335 my ( $self, $method ) = @_;
1337 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1340 sub _initialize_immutable {
1341 my ( $self, %args ) = @_;
1343 $self->{__immutable}{options} = \%args;
1344 $self->_install_inlined_code(%args);
1347 sub _install_inlined_code {
1348 my ( $self, %args ) = @_;
1351 $self->_inline_accessors(%args) if $args{inline_accessors};
1352 $self->_inline_constructor(%args) if $args{inline_constructor};
1353 $self->_inline_destructor(%args) if $args{inline_destructor};
1356 sub _rebless_as_mutable {
1359 bless $self, $self->_get_mutable_metaclass_name;
1364 sub _inline_accessors {
1367 foreach my $attr_name ( $self->get_attribute_list ) {
1368 $self->get_attribute($attr_name)->install_accessors(1);
1372 sub _inline_constructor {
1373 my ( $self, %args ) = @_;
1375 my $name = $args{constructor_name};
1376 # A class may not even have a constructor, and that's okay.
1377 return unless defined $name;
1379 if ( $self->has_method($name) && !$args{replace_constructor} ) {
1380 my $class = $self->name;
1381 warn "Not inlining a constructor for $class since it defines"
1382 . " its own constructor.\n"
1383 . "If you are certain you don't need to inline your"
1384 . " constructor, specify inline_constructor => 0 in your"
1385 . " call to $class->meta->make_immutable\n";
1389 my $constructor_class = $args{constructor_class};
1391 Class::MOP::load_class($constructor_class);
1393 my $constructor = $constructor_class->new(
1397 package_name => $self->name,
1401 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1402 $self->add_method( $name => $constructor );
1403 $self->_add_inlined_method($constructor);
1407 sub _inline_destructor {
1408 my ( $self, %args ) = @_;
1410 ( exists $args{destructor_class} && defined $args{destructor_class} )
1411 || confess "The 'inline_destructor' option is present, but "
1412 . "no destructor class was specified";
1414 if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1415 my $class = $self->name;
1416 warn "Not inlining a destructor for $class since it defines"
1417 . " its own destructor.\n";
1421 my $destructor_class = $args{destructor_class};
1423 Class::MOP::load_class($destructor_class);
1425 return unless $destructor_class->is_needed($self);
1427 my $destructor = $destructor_class->new(
1430 package_name => $self->name,
1434 if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1435 $self->add_method( 'DESTROY' => $destructor );
1436 $self->_add_inlined_method($destructor);
1448 Class::MOP::Class - Class Meta Object
1452 # assuming that class Foo
1453 # has been defined, you can
1455 # use this for introspection ...
1457 # add a method to Foo ...
1458 Foo->meta->add_method( 'bar' => sub {...} )
1460 # get a list of all the classes searched
1461 # the method dispatcher in the correct order
1462 Foo->meta->class_precedence_list()
1464 # remove a method from Foo
1465 Foo->meta->remove_method('bar');
1467 # or use this to actually create classes ...
1469 Class::MOP::Class->create(
1472 superclasses => ['Foo'],
1474 Class::MOP::Attribute->new('$bar'),
1475 Class::MOP::Attribute->new('$baz'),
1478 calculate_bar => sub {...},
1479 construct_baz => sub {...}
1486 The Class Protocol is the largest and most complex part of the
1487 Class::MOP meta-object protocol. It controls the introspection and
1488 manipulation of Perl 5 classes, and it can create them as well. The
1489 best way to understand what this module can do is to read the
1490 documentation for each of its methods.
1494 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1498 =head2 Class construction
1500 These methods all create new C<Class::MOP::Class> objects. These
1501 objects can represent existing classes or they can be used to create
1502 new classes from scratch.
1504 The metaclass object for a given class is a singleton. If you attempt
1505 to create a metaclass for the same class twice, you will just get the
1510 =item B<< Class::MOP::Class->create($package_name, %options) >>
1512 This method creates a new C<Class::MOP::Class> object with the given
1513 package name. It accepts a number of options:
1519 An optional version number for the newly created package.
1523 An optional authority for the newly created package.
1525 =item * superclasses
1527 An optional array reference of superclass names.
1531 An optional hash reference of methods for the class. The keys of the
1532 hash reference are method names and values are subroutine references.
1536 An optional array reference of L<Class::MOP::Attribute> objects.
1540 Specifies the name to install the C<meta> method for this class under.
1541 If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
1542 given, no meta method will be installed.
1546 If true, the metaclass that is stored in the global cache will be a
1549 Classes created in this way are destroyed once the metaclass they are
1550 attached to goes out of scope, and will be removed from Perl's internal
1553 All instances of a class with a weakened metaclass keep a special
1554 reference to the metaclass object, which prevents the metaclass from
1555 going out of scope while any instances exist.
1557 This only works if the instance is based on a hash reference, however.
1561 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1563 This method works just like C<< Class::MOP::Class->create >> but it
1564 creates an "anonymous" class. In fact, the class does have a name, but
1565 that name is a unique name generated internally by this module.
1567 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1568 parameters that C<create> accepts.
1570 Anonymous classes default to C<< weaken => 1 >>, although this can be
1573 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1575 This method will initialize a C<Class::MOP::Class> object for the
1576 named package. Unlike C<create>, this method I<will not> create a new
1579 The purpose of this method is to retrieve a C<Class::MOP::Class>
1580 object for introspecting an existing class.
1582 If an existing C<Class::MOP::Class> object exists for the named
1583 package, it will be returned, and any options provided will be
1586 If the object does not yet exist, it will be created.
1588 The valid options that can be passed to this method are
1589 C<attribute_metaclass>, C<method_metaclass>,
1590 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1591 optional, and default to the appropriate class in the C<Class::MOP>
1596 =head2 Object instance construction and cloning
1598 These methods are all related to creating and/or cloning object
1603 =item B<< $metaclass->clone_object($instance, %params) >>
1605 This method clones an existing object instance. Any parameters you
1606 provide are will override existing attribute values in the object.
1608 This is a convenience method for cloning an object instance, then
1609 blessing it into the appropriate package.
1611 You could implement a clone method in your class, using this method:
1614 my ($self, %params) = @_;
1615 $self->meta->clone_object($self, %params);
1618 =item B<< $metaclass->rebless_instance($instance, %params) >>
1620 This method changes the class of C<$instance> to the metaclass's class.
1622 You can only rebless an instance into a subclass of its current
1623 class. If you pass any additional parameters, these will be treated
1624 like constructor parameters and used to initialize the object's
1625 attributes. Any existing attributes that are already set will be
1628 Before reblessing the instance, this method will call
1629 C<rebless_instance_away> on the instance's current metaclass. This method
1630 will be passed the instance, the new metaclass, and any parameters
1631 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1632 does nothing; it is merely a hook.
1634 =item B<< $metaclass->rebless_instance_back($instance) >>
1636 Does the same thing as C<rebless_instance>, except that you can only
1637 rebless an instance into one of its superclasses. Any attributes that
1638 do not exist in the superclass will be deinitialized.
1640 This is a much more dangerous operation than C<rebless_instance>,
1641 especially when multiple inheritance is involved, so use this carefully!
1643 =item B<< $metaclass->new_object(%params) >>
1645 This method is used to create a new object of the metaclass's
1646 class. Any parameters you provide are used to initialize the
1647 instance's attributes. A special C<__INSTANCE__> key can be passed to
1648 provide an already generated instance, rather than having Class::MOP
1649 generate it for you. This is mostly useful for using Class::MOP with
1650 foreign classes which generate instances using their own constructors.
1652 =item B<< $metaclass->instance_metaclass >>
1654 Returns the class name of the instance metaclass. See
1655 L<Class::MOP::Instance> for more information on the instance
1658 =item B<< $metaclass->get_meta_instance >>
1660 Returns an instance of the C<instance_metaclass> to be used in the
1661 construction of a new instance of the class.
1665 =head2 Informational predicates
1667 These are a few predicate methods for asking information about the
1672 =item B<< $metaclass->is_anon_class >>
1674 This returns true if the class was created by calling C<<
1675 Class::MOP::Class->create_anon_class >>.
1677 =item B<< $metaclass->is_mutable >>
1679 This returns true if the class is still mutable.
1681 =item B<< $metaclass->is_immutable >>
1683 This returns true if the class has been made immutable.
1685 =item B<< $metaclass->is_pristine >>
1687 A class is I<not> pristine if it has non-inherited attributes or if it
1688 has any generated methods.
1692 =head2 Inheritance Relationships
1696 =item B<< $metaclass->superclasses(@superclasses) >>
1698 This is a read-write accessor which represents the superclass
1699 relationships of the metaclass's class.
1701 This is basically sugar around getting and setting C<@ISA>.
1703 =item B<< $metaclass->class_precedence_list >>
1705 This returns a list of all of the class's ancestor classes. The
1706 classes are returned in method dispatch order.
1708 =item B<< $metaclass->linearized_isa >>
1710 This returns a list based on C<class_precedence_list> but with all
1713 =item B<< $metaclass->subclasses >>
1715 This returns a list of all subclasses for this class, even indirect
1718 =item B<< $metaclass->direct_subclasses >>
1720 This returns a list of immediate subclasses for this class, which does not
1721 include indirect subclasses.
1725 =head2 Method introspection and creation
1727 These methods allow you to introspect a class's methods, as well as
1728 add, remove, or change methods.
1730 Determining what is truly a method in a Perl 5 class requires some
1731 heuristics (aka guessing).
1733 Methods defined outside the package with a fully qualified name (C<sub
1734 Package::name { ... }>) will be included. Similarly, methods named
1735 with a fully qualified name using L<Sub::Name> are also included.
1737 However, we attempt to ignore imported functions.
1739 Ultimately, we are using heuristics to determine what truly is a
1740 method in a class, and these heuristics may get the wrong answer in
1741 some edge cases. However, for most "normal" cases the heuristics work
1746 =item B<< $metaclass->get_method($method_name) >>
1748 This will return a L<Class::MOP::Method> for the specified
1749 C<$method_name>. If the class does not have the specified method, it
1752 =item B<< $metaclass->has_method($method_name) >>
1754 Returns a boolean indicating whether or not the class defines the
1755 named method. It does not include methods inherited from parent
1758 =item B<< $metaclass->get_method_list >>
1760 This will return a list of method I<names> for all methods defined in
1763 =item B<< $metaclass->add_method($method_name, $method) >>
1765 This method takes a method name and a subroutine reference, and adds
1766 the method to the class.
1768 The subroutine reference can be a L<Class::MOP::Method>, and you are
1769 strongly encouraged to pass a meta method object instead of a code
1770 reference. If you do so, that object gets stored as part of the
1771 class's method map directly. If not, the meta information will have to
1772 be recreated later, and may be incorrect.
1774 If you provide a method object, this method will clone that object if
1775 the object's package name does not match the class name. This lets us
1776 track the original source of any methods added from other classes
1777 (notably Moose roles).
1779 =item B<< $metaclass->remove_method($method_name) >>
1781 Remove the named method from the class. This method returns the
1782 L<Class::MOP::Method> object for the method.
1784 =item B<< $metaclass->method_metaclass >>
1786 Returns the class name of the method metaclass, see
1787 L<Class::MOP::Method> for more information on the method metaclass.
1789 =item B<< $metaclass->wrapped_method_metaclass >>
1791 Returns the class name of the wrapped method metaclass, see
1792 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1795 =item B<< $metaclass->get_all_methods >>
1797 This will traverse the inheritance hierarchy and return a list of all
1798 the L<Class::MOP::Method> objects for this class and its parents.
1800 =item B<< $metaclass->find_method_by_name($method_name) >>
1802 This will return a L<Class::MOP::Method> for the specified
1803 C<$method_name>. If the class does not have the specified method, it
1806 Unlike C<get_method>, this method I<will> look for the named method in
1809 =item B<< $metaclass->get_all_method_names >>
1811 This will return a list of method I<names> for all of this class's
1812 methods, including inherited methods.
1814 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1816 This method looks for the named method in the class and all of its
1817 parents. It returns every matching method it finds in the inheritance
1818 tree, so it returns a list of methods.
1820 Each method is returned as a hash reference with three keys. The keys
1821 are C<name>, C<class>, and C<code>. The C<code> key has a
1822 L<Class::MOP::Method> object as its value.
1824 The list of methods is distinct.
1826 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1828 This method returns the first method in any superclass matching the
1829 given name. It is effectively the method that C<SUPER::$method_name>
1834 =head2 Attribute introspection and creation
1836 Because Perl 5 does not have a core concept of attributes in classes,
1837 we can only return information about attributes which have been added
1838 via this class's methods. We cannot discover information about
1839 attributes which are defined in terms of "regular" Perl 5 methods.
1843 =item B<< $metaclass->get_attribute($attribute_name) >>
1845 This will return a L<Class::MOP::Attribute> for the specified
1846 C<$attribute_name>. If the class does not have the specified
1847 attribute, it returns C<undef>.
1849 NOTE that get_attribute does not search superclasses, for that you
1850 need to use C<find_attribute_by_name>.
1852 =item B<< $metaclass->has_attribute($attribute_name) >>
1854 Returns a boolean indicating whether or not the class defines the
1855 named attribute. It does not include attributes inherited from parent
1858 =item B<< $metaclass->get_attribute_list >>
1860 This will return a list of attributes I<names> for all attributes
1861 defined in this class. Note that this operates on the current class
1862 only, it does not traverse the inheritance hierarchy.
1864 =item B<< $metaclass->get_all_attributes >>
1866 This will traverse the inheritance hierarchy and return a list of all
1867 the L<Class::MOP::Attribute> objects for this class and its parents.
1869 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1871 This will return a L<Class::MOP::Attribute> for the specified
1872 C<$attribute_name>. If the class does not have the specified
1873 attribute, it returns C<undef>.
1875 Unlike C<get_attribute>, this attribute I<will> look for the named
1876 attribute in superclasses.
1878 =item B<< $metaclass->add_attribute(...) >>
1880 This method accepts either an existing L<Class::MOP::Attribute>
1881 object or parameters suitable for passing to that class's C<new>
1884 The attribute provided will be added to the class.
1886 Any accessor methods defined by the attribute will be added to the
1887 class when the attribute is added.
1889 If an attribute of the same name already exists, the old attribute
1890 will be removed first.
1892 =item B<< $metaclass->remove_attribute($attribute_name) >>
1894 This will remove the named attribute from the class, and
1895 L<Class::MOP::Attribute> object.
1897 Removing an attribute also removes any accessor methods defined by the
1900 However, note that removing an attribute will only affect I<future>
1901 object instances created for this class, not existing instances.
1903 =item B<< $metaclass->attribute_metaclass >>
1905 Returns the class name of the attribute metaclass for this class. By
1906 default, this is L<Class::MOP::Attribute>.
1910 =head2 Class Immutability
1912 Making a class immutable "freezes" the class definition. You can no
1913 longer call methods which alter the class, such as adding or removing
1914 methods or attributes.
1916 Making a class immutable lets us optimize the class by inlining some
1917 methods, and also allows us to optimize some methods on the metaclass
1920 After immutabilization, the metaclass object will cache most informational
1921 methods that returns information about methods or attributes. Methods which
1922 would alter the class, such as C<add_attribute> and C<add_method>, will
1923 throw an error on an immutable metaclass object.
1925 The immutabilization system in L<Moose> takes much greater advantage
1926 of the inlining features than Class::MOP itself does.
1930 =item B<< $metaclass->make_immutable(%options) >>
1932 This method will create an immutable transformer and use it to make
1933 the class and its metaclass object immutable.
1935 This method accepts the following options:
1939 =item * inline_accessors
1941 =item * inline_constructor
1943 =item * inline_destructor
1945 These are all booleans indicating whether the specified method(s)
1948 By default, accessors and the constructor are inlined, but not the
1951 =item * immutable_trait
1953 The name of a class which will be used as a parent class for the
1954 metaclass object being made immutable. This "trait" implements the
1955 post-immutability functionality of the metaclass (but not the
1956 transformation itself).
1958 This defaults to L<Class::MOP::Class::Immutable::Trait>.
1960 =item * constructor_name
1962 This is the constructor method name. This defaults to "new".
1964 =item * constructor_class
1966 The name of the method metaclass for constructors. It will be used to
1967 generate the inlined constructor. This defaults to
1968 "Class::MOP::Method::Constructor".
1970 =item * replace_constructor
1972 This is a boolean indicating whether an existing constructor should be
1973 replaced when inlining a constructor. This defaults to false.
1975 =item * destructor_class
1977 The name of the method metaclass for destructors. It will be used to
1978 generate the inlined destructor. This defaults to
1979 "Class::MOP::Method::Denstructor".
1981 =item * replace_destructor
1983 This is a boolean indicating whether an existing destructor should be
1984 replaced when inlining a destructor. This defaults to false.
1988 =item B<< $metaclass->immutable_options >>
1990 Returns a hash of the options used when making the class immutable, including
1991 both defaults and anything supplied by the user in the call to C<<
1992 $metaclass->make_immutable >>. This is useful if you need to temporarily make
1993 a class mutable and then restore immutability as it was before.
1995 =item B<< $metaclass->make_mutable >>
1997 Calling this method reverse the immutabilization transformation.
2001 =head2 Method Modifiers
2003 Method modifiers are hooks which allow a method to be wrapped with
2004 I<before>, I<after> and I<around> method modifiers. Every time a
2005 method is called, its modifiers are also called.
2007 A class can modify its own methods, as well as methods defined in
2010 =head3 How method modifiers work?
2012 Method modifiers work by wrapping the original method and then
2013 replacing it in the class's symbol table. The wrappers will handle
2014 calling all the modifiers in the appropriate order and preserving the
2015 calling context for the original method.
2017 The return values of C<before> and C<after> modifiers are
2018 ignored. This is because their purpose is B<not> to filter the input
2019 and output of the primary method (this is done with an I<around>
2022 This may seem like an odd restriction to some, but doing this allows
2023 for simple code to be added at the beginning or end of a method call
2024 without altering the function of the wrapped method or placing any
2025 extra responsibility on the code of the modifier.
2027 Of course if you have more complex needs, you can use the C<around>
2028 modifier which allows you to change both the parameters passed to the
2029 wrapped method, as well as its return value.
2031 Before and around modifiers are called in last-defined-first-called
2032 order, while after modifiers are called in first-defined-first-called
2033 order. So the call tree might looks something like this:
2045 =head3 What is the performance impact?
2047 Of course there is a performance cost associated with method
2048 modifiers, but we have made every effort to make that cost directly
2049 proportional to the number of modifier features you use.
2051 The wrapping method does its best to B<only> do as much work as it
2052 absolutely needs to. In order to do this we have moved some of the
2053 performance costs to set-up time, where they are easier to amortize.
2055 All this said, our benchmarks have indicated the following:
2057 simple wrapper with no modifiers 100% slower
2058 simple wrapper with simple before modifier 400% slower
2059 simple wrapper with simple after modifier 450% slower
2060 simple wrapper with simple around modifier 500-550% slower
2061 simple wrapper with all 3 modifiers 1100% slower
2063 These numbers may seem daunting, but you must remember, every feature
2064 comes with some cost. To put things in perspective, just doing a
2065 simple C<AUTOLOAD> which does nothing but extract the name of the
2066 method called and return it costs about 400% over a normal method
2071 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
2073 This wraps the specified method with the supplied subroutine
2074 reference. The modifier will be called as a method itself, and will
2075 receive the same arguments as are passed to the method.
2077 When the modifier exits, the wrapped method will be called.
2079 The return value of the modifier will be ignored.
2081 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
2083 This wraps the specified method with the supplied subroutine
2084 reference. The modifier will be called as a method itself, and will
2085 receive the same arguments as are passed to the method.
2087 When the wrapped methods exits, the modifier will be called.
2089 The return value of the modifier will be ignored.
2091 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
2093 This wraps the specified method with the supplied subroutine
2096 The first argument passed to the modifier will be a subroutine
2097 reference to the wrapped method. The second argument is the object,
2098 and after that come any arguments passed when the method is called.
2100 The around modifier can choose to call the original method, as well as
2101 what arguments to pass if it does so.
2103 The return value of the modifier is what will be seen by the caller.
2107 =head2 Introspection
2111 =item B<< Class::MOP::Class->meta >>
2113 This will return a L<Class::MOP::Class> instance for this class.
2115 It should also be noted that L<Class::MOP> will actually bootstrap
2116 this module by installing a number of attribute meta-objects into its
2123 Stevan Little E<lt>stevan@iinteractive.comE<gt>
2125 =head1 COPYRIGHT AND LICENSE
2127 Copyright 2006-2010 by Infinity Interactive, Inc.
2129 L<http://www.iinteractive.com>
2131 This library is free software; you can redistribute it and/or modify
2132 it under the same terms as Perl itself.