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::Method::Meta;
12 use Class::MOP::MiniTrait;
15 use Scalar::Util 'blessed', 'reftype', 'weaken';
16 use Sub::Name 'subname';
17 use Devel::GlobalDestruction 'in_global_destruction';
19 use List::MoreUtils 'all';
21 our $VERSION = '1.09';
22 $VERSION = eval $VERSION;
23 our $AUTHORITY = 'cpan:STEVAN';
25 use base 'Class::MOP::Module',
26 'Class::MOP::Mixin::HasAttributes',
27 'Class::MOP::Mixin::HasMethods';
37 $package_name = shift;
40 $package_name = $options{package};
43 ($package_name && !ref($package_name))
44 || confess "You must pass a package name and it cannot be blessed";
46 return Class::MOP::get_metaclass_by_name($package_name)
47 || $class->_construct_class_instance(package => $package_name, @_);
51 my ( $class, @args ) = @_;
52 unshift @args, "package" if @args % 2;
54 my $old_metaclass = blessed($options{package})
56 : Class::MOP::get_metaclass_by_name($options{package});
57 $old_metaclass->_remove_generated_metaobjects
58 if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
59 my $new_metaclass = $class->SUPER::reinitialize(@args);
60 $new_metaclass->_restore_metaobjects_from($old_metaclass)
61 if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
62 return $new_metaclass;
65 # NOTE: (meta-circularity)
66 # this is a special form of _construct_instance
67 # (see below), which is used to construct class
68 # meta-object instances for any Class::MOP::*
69 # class. All other classes will use the more
70 # normal &construct_instance.
71 sub _construct_class_instance {
73 my $options = @_ == 1 ? $_[0] : {@_};
74 my $package_name = $options->{package};
75 (defined $package_name && $package_name)
76 || confess "You must pass a package name";
78 # return the metaclass if we have it cached,
79 # and it is still defined (it has not been
80 # reaped by DESTROY yet, which can happen
81 # annoyingly enough during global destruction)
83 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
89 ? $class->_real_ref_name
92 # now create the metaclass
94 if ($class eq 'Class::MOP::Class') {
95 $meta = $class->_new($options);
99 # it is safe to use meta here because
100 # class will always be a subclass of
101 # Class::MOP::Class, which defines meta
102 $meta = $class->meta->_construct_instance($options)
105 # and check the metaclass compatibility
106 $meta->_check_metaclass_compatibility();
108 Class::MOP::store_metaclass_by_name($package_name, $meta);
111 # we need to weaken any anon classes
112 # so that they can call DESTROY properly
113 Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class;
121 # NOTE: we need to deal with the possibility of class immutability here,
122 # and then get the name of the class appropriately
123 return $self->is_immutable
124 ? $self->_get_mutable_metaclass_name()
128 sub _meta_method_class { 'Class::MOP::Method::Meta' }
130 sub _add_meta_method {
132 my $existing_method = $self->find_method_by_name('meta');
133 return if $existing_method
134 && $existing_method->isa($self->_meta_method_class);
136 'meta' => $self->_meta_method_class->wrap(
138 package_name => $self->name,
139 associated_metaclass => $self,
147 return Class::MOP::Class->initialize($class)->new_object(@_)
148 if $class ne __PACKAGE__;
150 my $options = @_ == 1 ? $_[0] : {@_};
153 # inherited from Class::MOP::Package
154 'package' => $options->{package},
157 # since the following attributes will
158 # actually be loaded from the symbol
159 # table, and actually bypass the instance
160 # entirely, we can just leave these things
161 # listed here for reference, because they
162 # should not actually have a value associated
164 'namespace' => \undef,
167 # inherited from Class::MOP::Module
169 'authority' => \undef,
171 # defined in Class::MOP::Class
172 'superclasses' => \undef,
175 'attribute_metaclass' =>
176 ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
177 'method_metaclass' =>
178 ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
179 'wrapped_method_metaclass' => (
180 $options->{'wrapped_method_metaclass'}
181 || 'Class::MOP::Method::Wrapped'
183 'instance_metaclass' =>
184 ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
185 'immutable_trait' => (
186 $options->{'immutable_trait'}
187 || 'Class::MOP::Class::Immutable::Trait'
189 'constructor_name' => ( $options->{constructor_name} || 'new' ),
190 'constructor_class' => (
191 $options->{constructor_class} || 'Class::MOP::Method::Constructor'
193 'destructor_class' => $options->{destructor_class},
197 sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
198 sub update_package_cache_flag {
201 # we can manually update the cache number
202 # since we are actually adding the method
203 # to our cache as well. This avoids us
204 # having to regenerate the method_map.
206 $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
209 ## Metaclass compatibility
211 my %base_metaclass = (
212 attribute_metaclass => 'Class::MOP::Attribute',
213 method_metaclass => 'Class::MOP::Method',
214 wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
215 instance_metaclass => 'Class::MOP::Instance',
216 constructor_class => 'Class::MOP::Method::Constructor',
217 destructor_class => 'Class::MOP::Method::Destructor',
220 sub _base_metaclasses { %base_metaclass }
223 sub _check_metaclass_compatibility {
226 my @superclasses = $self->superclasses
229 $self->_fix_metaclass_incompatibility(@superclasses);
231 my %base_metaclass = $self->_base_metaclasses;
233 # this is always okay ...
235 if ref($self) eq 'Class::MOP::Class'
237 my $meta = $self->$_;
238 !defined($meta) || $meta eq $base_metaclass{$_};
240 keys %base_metaclass;
242 for my $superclass (@superclasses) {
243 $self->_check_class_metaclass_compatibility($superclass);
246 for my $metaclass_type ( keys %base_metaclass ) {
247 next unless defined $self->$metaclass_type;
248 for my $superclass (@superclasses) {
249 $self->_check_single_metaclass_compatibility( $metaclass_type,
255 sub _check_class_metaclass_compatibility {
257 my ( $superclass_name ) = @_;
259 if (!$self->_class_metaclass_is_compatible($superclass_name)) {
260 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
262 my $super_meta_type = $super_meta->_real_ref_name;
264 confess "The metaclass of " . $self->name . " ("
265 . (ref($self)) . ")" . " is not compatible with "
266 . "the metaclass of its superclass, "
267 . $superclass_name . " (" . ($super_meta_type) . ")";
271 sub _class_metaclass_is_compatible {
273 my ( $superclass_name ) = @_;
275 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
278 my $super_meta_name = $super_meta->_real_ref_name;
280 return $self->_is_compatible_with($super_meta_name);
283 sub _check_single_metaclass_compatibility {
285 my ( $metaclass_type, $superclass_name ) = @_;
287 if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
288 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
289 my $metaclass_type_name = $metaclass_type;
290 $metaclass_type_name =~ s/_(?:meta)?class$//;
291 $metaclass_type_name =~ s/_/ /g;
292 confess "The $metaclass_type_name metaclass for "
293 . $self->name . " (" . ($self->$metaclass_type)
294 . ")" . " is not compatible with the "
295 . "$metaclass_type_name metaclass of its "
296 . "superclass, $superclass_name ("
297 . ($super_meta->$metaclass_type) . ")";
301 sub _single_metaclass_is_compatible {
303 my ( $metaclass_type, $superclass_name ) = @_;
305 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
308 # for instance, Moose::Meta::Class has a error_class attribute, but
309 # Class::MOP::Class doesn't - this shouldn't be an error
310 return 1 unless $super_meta->can($metaclass_type);
311 # for instance, Moose::Meta::Class has a destructor_class, but
312 # Class::MOP::Class doesn't - this shouldn't be an error
313 return 1 unless defined $super_meta->$metaclass_type;
314 # if metaclass is defined in superclass but not here, it's not compatible
315 # this is a really odd case
316 return 0 unless defined $self->$metaclass_type;
318 return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
321 sub _fix_metaclass_incompatibility {
323 my @supers = map { Class::MOP::Class->initialize($_) } @_;
326 for my $super (@supers) {
328 if $self->_can_fix_metaclass_incompatibility($super);
330 return unless $necessary;
332 for my $super (@supers) {
333 if (!$self->_class_metaclass_is_compatible($super->name)) {
334 $self->_fix_class_metaclass_incompatibility($super);
338 my %base_metaclass = $self->_base_metaclasses;
339 for my $metaclass_type (keys %base_metaclass) {
340 for my $super (@supers) {
341 if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
342 $self->_fix_single_metaclass_incompatibility(
343 $metaclass_type, $super
350 sub _can_fix_metaclass_incompatibility {
352 my ($super_meta) = @_;
354 return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
356 my %base_metaclass = $self->_base_metaclasses;
357 for my $metaclass_type (keys %base_metaclass) {
358 return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
364 sub _class_metaclass_can_be_made_compatible {
366 my ($super_meta) = @_;
368 return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
371 sub _single_metaclass_can_be_made_compatible {
373 my ($super_meta, $metaclass_type) = @_;
375 my $specific_meta = $self->$metaclass_type;
377 return unless $super_meta->can($metaclass_type);
378 my $super_specific_meta = $super_meta->$metaclass_type;
380 # for instance, Moose::Meta::Class has a destructor_class, but
381 # Class::MOP::Class doesn't - this shouldn't be an error
382 return unless defined $super_specific_meta;
384 # if metaclass is defined in superclass but not here, it's fixable
385 # this is a really odd case
386 return 1 unless defined $specific_meta;
388 return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
391 sub _fix_class_metaclass_incompatibility {
393 my ( $super_meta ) = @_;
395 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
397 || confess "Can't fix metaclass incompatibility for "
399 . " because it is not pristine.";
401 my $super_meta_name = $super_meta->_real_ref_name;
403 $self->_make_compatible_with($super_meta_name);
407 sub _fix_single_metaclass_incompatibility {
409 my ( $metaclass_type, $super_meta ) = @_;
411 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
413 || confess "Can't fix metaclass incompatibility for "
415 . " because it is not pristine.";
417 my $new_metaclass = $self->$metaclass_type
418 ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
419 : $super_meta->$metaclass_type;
420 $self->{$metaclass_type} = $new_metaclass;
424 sub _restore_metaobjects_from {
428 $self->_restore_metamethods_from($old_meta);
429 $self->_restore_metaattributes_from($old_meta);
432 sub _remove_generated_metaobjects {
435 for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
436 $attr->remove_accessors;
444 # this should be sufficient, if you have a
445 # use case where it is not, write a test and
447 my $ANON_CLASS_SERIAL = 0;
450 # we need a sufficiently annoying prefix
451 # this should suffice for now, this is
452 # used in a couple of places below, so
453 # need to put it up here for now.
454 my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
458 no warnings 'uninitialized';
459 $self->name =~ /^$ANON_CLASS_PREFIX/o;
462 sub create_anon_class {
463 my ($class, %options) = @_;
464 my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
465 return $class->create($package_name, %options);
469 # this will only get called for
470 # anon-classes, all other calls
471 # are assumed to occur during
472 # global destruction and so don't
473 # really need to be handled explicitly
477 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
479 no warnings 'uninitialized';
480 my $name = $self->name;
481 return unless $name =~ /^$ANON_CLASS_PREFIX/o;
483 # Moose does a weird thing where it replaces the metaclass for
484 # class when fixing metaclass incompatibility. In that case,
485 # we don't want to clean out the namespace now. We can detect
486 # that because Moose will explicitly update the singleton
487 # cache in Class::MOP.
488 my $current_meta = Class::MOP::get_metaclass_by_name($name);
489 return if $current_meta ne $self;
491 my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
493 @{$name . '::ISA'} = ();
494 %{$name . '::'} = ();
495 delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
497 Class::MOP::remove_metaclass_by_name($name);
502 # creating classes with MOP ...
505 my ( $class, @args ) = @_;
507 unshift @args, 'package' if @args % 2 == 1;
509 my (%options) = @args;
510 my $package_name = $options{package};
512 (ref $options{superclasses} eq 'ARRAY')
513 || confess "You must pass an ARRAY ref of superclasses"
514 if exists $options{superclasses};
516 (ref $options{attributes} eq 'ARRAY')
517 || confess "You must pass an ARRAY ref of attributes"
518 if exists $options{attributes};
520 (ref $options{methods} eq 'HASH')
521 || confess "You must pass a HASH ref of methods"
522 if exists $options{methods};
524 my (%initialize_options) = @args;
525 delete @initialize_options{qw(
534 my $meta = $class->initialize( $package_name => %initialize_options );
536 $meta->_instantiate_module( $options{version}, $options{authority} );
538 $meta->_add_meta_method unless $options{no_meta};
540 $meta->superclasses(@{$options{superclasses}})
541 if exists $options{superclasses};
543 # process attributes first, so that they can
544 # install accessors, but locally defined methods
545 # can then overwrite them. It is maybe a little odd, but
546 # I think this should be the order of things.
547 if (exists $options{attributes}) {
548 foreach my $attr (@{$options{attributes}}) {
549 $meta->add_attribute($attr);
552 if (exists $options{methods}) {
553 foreach my $method_name (keys %{$options{methods}}) {
554 $meta->add_method($method_name, $options{methods}->{$method_name});
563 # all these attribute readers will be bootstrapped
564 # away in the Class::MOP bootstrap section
566 sub instance_metaclass { $_[0]->{'instance_metaclass'} }
567 sub immutable_trait { $_[0]->{'immutable_trait'} }
568 sub constructor_class { $_[0]->{'constructor_class'} }
569 sub constructor_name { $_[0]->{'constructor_name'} }
570 sub destructor_class { $_[0]->{'destructor_class'} }
572 # Instance Construction & Cloning
578 # we need to protect the integrity of the
579 # Class::MOP::Class singletons here, so we
580 # delegate this to &construct_class_instance
581 # which will deal with the singletons
582 return $class->_construct_class_instance(@_)
583 if $class->name->isa('Class::MOP::Class');
584 return $class->_construct_instance(@_);
587 sub _construct_instance {
589 my $params = @_ == 1 ? $_[0] : {@_};
590 my $meta_instance = $class->get_meta_instance();
592 # the code below is almost certainly incorrect
593 # but this is foreign inheritance, so we might
594 # have to kludge it in the end.
596 if (my $instance_class = blessed($params->{__INSTANCE__})) {
597 ($instance_class eq $class->name)
598 || confess "Objects passed as the __INSTANCE__ parameter must "
599 . "already be blessed into the correct class, but "
600 . "$params->{__INSTANCE__} is not a " . $class->name;
601 $instance = $params->{__INSTANCE__};
603 elsif (exists $params->{__INSTANCE__}) {
604 confess "The __INSTANCE__ parameter must be a blessed reference, not "
605 . $params->{__INSTANCE__};
608 $instance = $meta_instance->create_instance();
610 foreach my $attr ($class->get_all_attributes()) {
611 $attr->initialize_instance_slot($meta_instance, $instance, $params);
614 # this will only work for a HASH instance type
615 if ($class->is_anon_class) {
616 (reftype($instance) eq 'HASH')
617 || confess "Currently only HASH based instances are supported with instance of anon-classes";
619 # At some point we should make this official
620 # as a reserved slot name, but right now I am
621 # going to keep it here.
622 # my $RESERVED_MOP_SLOT = '__MOP__';
623 $instance->{'__MOP__'} = $class;
629 sub get_meta_instance {
631 $self->{'_meta_instance'} ||= $self->_create_meta_instance();
634 sub _create_meta_instance {
637 my $instance = $self->instance_metaclass->new(
638 associated_metaclass => $self,
639 attributes => [ $self->get_all_attributes() ],
642 $self->add_meta_instance_dependencies()
643 if $instance->is_dependent_on_superclasses();
648 sub inline_create_instance {
651 return $self->get_meta_instance->inline_create_instance(@_);
654 sub inline_rebless_instance {
657 return $self->get_meta_instance->inline_rebless_instance_structure(@_);
662 my $instance = shift;
663 (blessed($instance) && $instance->isa($class->name))
664 || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
667 # we need to protect the integrity of the
668 # Class::MOP::Class singletons here, they
669 # should not be cloned.
670 return $instance if $instance->isa('Class::MOP::Class');
671 $class->_clone_instance($instance, @_);
674 sub _clone_instance {
675 my ($class, $instance, %params) = @_;
677 || confess "You can only clone instances, ($instance) is not a blessed instance";
678 my $meta_instance = $class->get_meta_instance();
679 my $clone = $meta_instance->clone_instance($instance);
680 foreach my $attr ($class->get_all_attributes()) {
681 if ( defined( my $init_arg = $attr->init_arg ) ) {
682 if (exists $params{$init_arg}) {
683 $attr->set_value($clone, $params{$init_arg});
690 sub _force_rebless_instance {
691 my ($self, $instance, %params) = @_;
692 my $old_metaclass = Class::MOP::class_of($instance);
694 $old_metaclass->rebless_instance_away($instance, $self, %params)
697 my $meta_instance = $self->get_meta_instance;
700 # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
701 $meta_instance->rebless_instance_structure($_[1], $self);
703 $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
706 sub rebless_instance {
707 my ($self, $instance, %params) = @_;
708 my $old_metaclass = Class::MOP::class_of($instance);
710 my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
711 $self->name->isa($old_class)
712 || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
714 $self->_force_rebless_instance($_[1], %params);
719 sub rebless_instance_back {
720 my ( $self, $instance ) = @_;
721 my $old_metaclass = Class::MOP::class_of($instance);
724 = $old_metaclass ? $old_metaclass->name : blessed($instance);
725 $old_class->isa( $self->name )
727 "You may rebless only into a superclass of ($old_class), of which ("
731 $self->_force_rebless_instance($_[1]);
736 sub rebless_instance_away {
737 # this intentionally does nothing, it is just a hook
740 sub _fixup_attributes_after_rebless {
742 my ($instance, $rebless_from, %params) = @_;
743 my $meta_instance = $self->get_meta_instance;
745 for my $attr ( $rebless_from->get_all_attributes ) {
746 next if $self->find_attribute_by_name( $attr->name );
747 $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
750 foreach my $attr ( $self->get_all_attributes ) {
751 if ( $attr->has_value($instance) ) {
752 if ( defined( my $init_arg = $attr->init_arg ) ) {
753 $params{$init_arg} = $attr->get_value($instance)
754 unless exists $params{$init_arg};
757 $attr->set_value($instance, $attr->get_value($instance));
762 foreach my $attr ($self->get_all_attributes) {
763 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
767 sub _attach_attribute {
768 my ($self, $attribute) = @_;
769 $attribute->attach_to_class($self);
772 sub _post_add_attribute {
773 my ( $self, $attribute ) = @_;
775 $self->invalidate_meta_instances;
777 # invalidate package flag here
780 $attribute->install_accessors;
783 $self->remove_attribute( $attribute->name );
788 sub remove_attribute {
791 my $removed_attribute = $self->SUPER::remove_attribute(@_)
794 $self->invalidate_meta_instances;
796 $removed_attribute->remove_accessors;
797 $removed_attribute->detach_from_class;
799 return$removed_attribute;
802 sub find_attribute_by_name {
803 my ( $self, $attr_name ) = @_;
805 foreach my $class ( $self->linearized_isa ) {
806 # fetch the meta-class ...
807 my $meta = Class::MOP::Class->initialize($class);
808 return $meta->get_attribute($attr_name)
809 if $meta->has_attribute($attr_name);
815 sub get_all_attributes {
817 my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
818 reverse $self->linearized_isa;
819 return values %attrs;
827 my $isa = $self->get_or_add_package_symbol(
828 { sigil => '@', type => 'ARRAY', name => 'ISA' } );
835 # on 5.8 and below, we need to call
836 # a method to get Perl to detect
837 # a cycle in the class hierarchy
838 my $class = $self->name;
842 # we need to check the metaclass
843 # compatibility here so that we can
844 # be sure that the superclass is
845 # not potentially creating an issues
846 # we don't know about
848 $self->_check_metaclass_compatibility();
849 $self->_superclasses_updated();
855 sub _superclasses_updated {
857 $self->update_meta_instance_dependencies();
862 my $super_class = $self->name;
864 return @{ $super_class->mro::get_isarev() };
867 sub direct_subclasses {
869 my $super_class = $self->name;
874 } Class::MOP::Class->initialize($_)->superclasses
879 return @{ mro::get_linear_isa( (shift)->name ) };
882 sub class_precedence_list {
884 my $name = $self->name;
886 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
888 # We need to check for circular inheritance here
889 # if we are are not on 5.10, cause 5.8 detects it
890 # late. This will do nothing if all is well, and
891 # blow up otherwise. Yes, it's an ugly hack, better
892 # suggestions are welcome.
894 ($name || return)->isa('This is a test for circular inheritance')
897 # if our mro is c3, we can
898 # just grab the linear_isa
899 if (mro::get_mro($name) eq 'c3') {
900 return @{ mro::get_linear_isa($name) }
904 # we can't grab the linear_isa for dfs
905 # since it has all the duplicates
910 Class::MOP::Class->initialize($_)->class_precedence_list()
911 } $self->superclasses()
919 my $fetch_and_prepare_method = sub {
920 my ($self, $method_name) = @_;
921 my $wrapped_metaclass = $self->wrapped_method_metaclass;
923 my $method = $self->get_method($method_name);
924 # if we dont have local ...
926 # try to find the next method
927 $method = $self->find_next_method_by_name($method_name);
928 # die if it does not exist
930 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
931 # and now make sure to wrap it
932 # even if it is already wrapped
933 # because we need a new sub ref
934 $method = $wrapped_metaclass->wrap($method,
935 package_name => $self->name,
936 name => $method_name,
940 # now make sure we wrap it properly
941 $method = $wrapped_metaclass->wrap($method,
942 package_name => $self->name,
943 name => $method_name,
944 ) unless $method->isa($wrapped_metaclass);
946 $self->add_method($method_name => $method);
950 sub add_before_method_modifier {
951 my ($self, $method_name, $method_modifier) = @_;
952 (defined $method_name && length $method_name)
953 || confess "You must pass in a method name";
954 my $method = $fetch_and_prepare_method->($self, $method_name);
955 $method->add_before_modifier(
956 subname(':before' => $method_modifier)
960 sub add_after_method_modifier {
961 my ($self, $method_name, $method_modifier) = @_;
962 (defined $method_name && length $method_name)
963 || confess "You must pass in a method name";
964 my $method = $fetch_and_prepare_method->($self, $method_name);
965 $method->add_after_modifier(
966 subname(':after' => $method_modifier)
970 sub add_around_method_modifier {
971 my ($self, $method_name, $method_modifier) = @_;
972 (defined $method_name && length $method_name)
973 || confess "You must pass in a method name";
974 my $method = $fetch_and_prepare_method->($self, $method_name);
975 $method->add_around_modifier(
976 subname(':around' => $method_modifier)
981 # the methods above used to be named like this:
982 # ${pkg}::${method}:(before|after|around)
983 # but this proved problematic when using one modifier
984 # to wrap multiple methods (something which is likely
985 # to happen pretty regularly IMO). So instead of naming
986 # it like this, I have chosen to just name them purely
987 # with their modifier names, like so:
988 # :(before|after|around)
989 # The fact is that in a stack trace, it will be fairly
990 # evident from the context what method they are attached
991 # to, and so don't need the fully qualified name.
994 sub find_method_by_name {
995 my ($self, $method_name) = @_;
996 (defined $method_name && length $method_name)
997 || confess "You must define a method name to find";
998 foreach my $class ($self->linearized_isa) {
999 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1000 return $method if defined $method;
1005 sub get_all_methods {
1009 for my $class ( reverse $self->linearized_isa ) {
1010 my $meta = Class::MOP::Class->initialize($class);
1012 $methods{ $_->name } = $_ for $meta->_get_local_methods;
1015 return values %methods;
1018 sub get_all_method_names {
1021 return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
1024 sub find_all_methods_by_name {
1025 my ($self, $method_name) = @_;
1026 (defined $method_name && length $method_name)
1027 || confess "You must define a method name to find";
1029 foreach my $class ($self->linearized_isa) {
1030 # fetch the meta-class ...
1031 my $meta = Class::MOP::Class->initialize($class);
1033 name => $method_name,
1035 code => $meta->get_method($method_name)
1036 } if $meta->has_method($method_name);
1041 sub find_next_method_by_name {
1042 my ($self, $method_name) = @_;
1043 (defined $method_name && length $method_name)
1044 || confess "You must define a method name to find";
1045 my @cpl = $self->linearized_isa;
1046 shift @cpl; # discard ourselves
1047 foreach my $class (@cpl) {
1048 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1049 return $method if defined $method;
1054 sub update_meta_instance_dependencies {
1057 if ( $self->{meta_instance_dependencies} ) {
1058 return $self->add_meta_instance_dependencies;
1062 sub add_meta_instance_dependencies {
1065 $self->remove_meta_instance_dependencies;
1067 my @attrs = $self->get_all_attributes();
1070 my @classes = grep { not $seen{ $_->name }++ }
1071 map { $_->associated_class } @attrs;
1073 foreach my $class (@classes) {
1074 $class->add_dependent_meta_instance($self);
1077 $self->{meta_instance_dependencies} = \@classes;
1080 sub remove_meta_instance_dependencies {
1083 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
1084 foreach my $class (@$classes) {
1085 $class->remove_dependent_meta_instance($self);
1095 sub add_dependent_meta_instance {
1096 my ( $self, $metaclass ) = @_;
1097 push @{ $self->{dependent_meta_instances} }, $metaclass;
1100 sub remove_dependent_meta_instance {
1101 my ( $self, $metaclass ) = @_;
1102 my $name = $metaclass->name;
1103 @$_ = grep { $_->name ne $name } @$_
1104 for $self->{dependent_meta_instances};
1107 sub invalidate_meta_instances {
1109 $_->invalidate_meta_instance()
1110 for $self, @{ $self->{dependent_meta_instances} };
1113 sub invalidate_meta_instance {
1115 undef $self->{_meta_instance};
1118 # check if we can reinitialize
1122 # if any local attr is defined
1123 return if $self->get_attribute_list;
1125 # or any non-declared methods
1126 for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
1127 return if $method->isa("Class::MOP::Method::Generated");
1128 # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
1136 sub is_mutable { 1 }
1137 sub is_immutable { 0 }
1139 sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
1141 sub _immutable_options {
1142 my ( $self, @args ) = @_;
1145 inline_accessors => 1,
1146 inline_constructor => 1,
1147 inline_destructor => 0,
1149 immutable_trait => $self->immutable_trait,
1150 constructor_name => $self->constructor_name,
1151 constructor_class => $self->constructor_class,
1152 destructor_class => $self->destructor_class,
1157 sub make_immutable {
1158 my ( $self, @args ) = @_;
1160 if ( $self->is_mutable ) {
1161 $self->_initialize_immutable( $self->_immutable_options(@args) );
1162 $self->_rebless_as_immutable(@args);
1173 if ( $self->is_immutable ) {
1174 my @args = $self->immutable_options;
1175 $self->_rebless_as_mutable();
1176 $self->_remove_inlined_code(@args);
1177 delete $self->{__immutable};
1185 sub _rebless_as_immutable {
1186 my ( $self, @args ) = @_;
1188 $self->{__immutable}{original_class} = ref $self;
1190 bless $self => $self->_immutable_metaclass(@args);
1193 sub _immutable_metaclass {
1194 my ( $self, %args ) = @_;
1196 if ( my $class = $args{immutable_metaclass} ) {
1200 my $trait = $args{immutable_trait} = $self->immutable_trait
1201 || confess "no immutable trait specified for $self";
1203 my $meta = $self->meta;
1204 my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
1208 if ( $meta_attr and $trait eq $meta_attr->default ) {
1209 # if the trait is the same as the default we try and pick a
1210 # predictable name for the immutable metaclass
1211 $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1214 $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1215 $trait, 'ForMetaClass', ref($self);
1219 if Class::MOP::is_class_loaded($class_name);
1221 # If the metaclass is a subclass of CMOP::Class which has had
1222 # metaclass roles applied (via Moose), then we want to make sure
1223 # that we preserve that anonymous class (see Fey::ORM for an
1224 # example of where this matters).
1225 my $meta_name = $meta->_real_ref_name;
1227 my $immutable_meta = $meta_name->create(
1229 superclasses => [ ref $self ],
1232 Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
1234 $immutable_meta->make_immutable(
1235 inline_constructor => 0,
1236 inline_accessors => 0,
1242 sub _remove_inlined_code {
1245 $self->remove_method( $_->name ) for $self->_inlined_methods;
1247 delete $self->{__immutable}{inlined_methods};
1250 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1252 sub _add_inlined_method {
1253 my ( $self, $method ) = @_;
1255 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1258 sub _initialize_immutable {
1259 my ( $self, %args ) = @_;
1261 $self->{__immutable}{options} = \%args;
1262 $self->_install_inlined_code(%args);
1265 sub _install_inlined_code {
1266 my ( $self, %args ) = @_;
1269 $self->_inline_accessors(%args) if $args{inline_accessors};
1270 $self->_inline_constructor(%args) if $args{inline_constructor};
1271 $self->_inline_destructor(%args) if $args{inline_destructor};
1274 sub _rebless_as_mutable {
1277 bless $self, $self->_get_mutable_metaclass_name;
1282 sub _inline_accessors {
1285 foreach my $attr_name ( $self->get_attribute_list ) {
1286 $self->get_attribute($attr_name)->install_accessors(1);
1290 sub _inline_constructor {
1291 my ( $self, %args ) = @_;
1293 my $name = $args{constructor_name};
1294 # A class may not even have a constructor, and that's okay.
1295 return unless defined $name;
1297 if ( $self->has_method($name) && !$args{replace_constructor} ) {
1298 my $class = $self->name;
1299 warn "Not inlining a constructor for $class since it defines"
1300 . " its own constructor.\n"
1301 . "If you are certain you don't need to inline your"
1302 . " constructor, specify inline_constructor => 0 in your"
1303 . " call to $class->meta->make_immutable\n";
1307 my $constructor_class = $args{constructor_class};
1309 Class::MOP::load_class($constructor_class);
1311 my $constructor = $constructor_class->new(
1315 package_name => $self->name,
1319 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1320 $self->add_method( $name => $constructor );
1321 $self->_add_inlined_method($constructor);
1325 sub _inline_destructor {
1326 my ( $self, %args ) = @_;
1328 ( exists $args{destructor_class} && defined $args{destructor_class} )
1329 || confess "The 'inline_destructor' option is present, but "
1330 . "no destructor class was specified";
1332 if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1333 my $class = $self->name;
1334 warn "Not inlining a destructor for $class since it defines"
1335 . " its own destructor.\n";
1339 my $destructor_class = $args{destructor_class};
1341 Class::MOP::load_class($destructor_class);
1343 return unless $destructor_class->is_needed($self);
1345 my $destructor = $destructor_class->new(
1348 package_name => $self->name,
1352 if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1353 $self->add_method( 'DESTROY' => $destructor );
1354 $self->_add_inlined_method($destructor);
1366 Class::MOP::Class - Class Meta Object
1370 # assuming that class Foo
1371 # has been defined, you can
1373 # use this for introspection ...
1375 # add a method to Foo ...
1376 Foo->meta->add_method( 'bar' => sub {...} )
1378 # get a list of all the classes searched
1379 # the method dispatcher in the correct order
1380 Foo->meta->class_precedence_list()
1382 # remove a method from Foo
1383 Foo->meta->remove_method('bar');
1385 # or use this to actually create classes ...
1387 Class::MOP::Class->create(
1390 superclasses => ['Foo'],
1392 Class::MOP::Attribute->new('$bar'),
1393 Class::MOP::Attribute->new('$baz'),
1396 calculate_bar => sub {...},
1397 construct_baz => sub {...}
1404 The Class Protocol is the largest and most complex part of the
1405 Class::MOP meta-object protocol. It controls the introspection and
1406 manipulation of Perl 5 classes, and it can create them as well. The
1407 best way to understand what this module can do is to read the
1408 documentation for each of its methods.
1412 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1416 =head2 Class construction
1418 These methods all create new C<Class::MOP::Class> objects. These
1419 objects can represent existing classes or they can be used to create
1420 new classes from scratch.
1422 The metaclass object for a given class is a singleton. If you attempt
1423 to create a metaclass for the same class twice, you will just get the
1428 =item B<< Class::MOP::Class->create($package_name, %options) >>
1430 This method creates a new C<Class::MOP::Class> object with the given
1431 package name. It accepts a number of options:
1437 An optional version number for the newly created package.
1441 An optional authority for the newly created package.
1443 =item * superclasses
1445 An optional array reference of superclass names.
1449 An optional hash reference of methods for the class. The keys of the
1450 hash reference are method names and values are subroutine references.
1454 An optional array reference of L<Class::MOP::Attribute> objects.
1458 If true, a C<meta> method will not be installed into the class.
1462 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1464 This method works just like C<< Class::MOP::Class->create >> but it
1465 creates an "anonymous" class. In fact, the class does have a name, but
1466 that name is a unique name generated internally by this module.
1468 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1469 parameters that C<create> accepts.
1471 Anonymous classes are destroyed once the metaclass they are attached
1472 to goes out of scope, and will be removed from Perl's internal symbol
1475 All instances of an anonymous class keep a special reference to the
1476 metaclass object, which prevents the metaclass from going out of scope
1477 while any instances exist.
1479 This only works if the instance is based on a hash reference, however.
1481 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1483 This method will initialize a C<Class::MOP::Class> object for the
1484 named package. Unlike C<create>, this method I<will not> create a new
1487 The purpose of this method is to retrieve a C<Class::MOP::Class>
1488 object for introspecting an existing class.
1490 If an existing C<Class::MOP::Class> object exists for the named
1491 package, it will be returned, and any options provided will be
1494 If the object does not yet exist, it will be created.
1496 The valid options that can be passed to this method are
1497 C<attribute_metaclass>, C<method_metaclass>,
1498 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1499 optional, and default to the appropriate class in the C<Class::MOP>
1504 =head2 Object instance construction and cloning
1506 These methods are all related to creating and/or cloning object
1511 =item B<< $metaclass->clone_object($instance, %params) >>
1513 This method clones an existing object instance. Any parameters you
1514 provide are will override existing attribute values in the object.
1516 This is a convenience method for cloning an object instance, then
1517 blessing it into the appropriate package.
1519 You could implement a clone method in your class, using this method:
1522 my ($self, %params) = @_;
1523 $self->meta->clone_object($self, %params);
1526 =item B<< $metaclass->rebless_instance($instance, %params) >>
1528 This method changes the class of C<$instance> to the metaclass's class.
1530 You can only rebless an instance into a subclass of its current
1531 class. If you pass any additional parameters, these will be treated
1532 like constructor parameters and used to initialize the object's
1533 attributes. Any existing attributes that are already set will be
1536 Before reblessing the instance, this method will call
1537 C<rebless_instance_away> on the instance's current metaclass. This method
1538 will be passed the instance, the new metaclass, and any parameters
1539 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1540 does nothing; it is merely a hook.
1542 =item B<< $metaclass->rebless_instance_back($instance) >>
1544 Does the same thing as C<rebless_instance>, except that you can only
1545 rebless an instance into one of its superclasses. Any attributes that
1546 do not exist in the superclass will be deinitialized.
1548 This is a much more dangerous operation than C<rebless_instance>,
1549 especially when multiple inheritance is involved, so use this carefully!
1551 =item B<< $metaclass->new_object(%params) >>
1553 This method is used to create a new object of the metaclass's
1554 class. Any parameters you provide are used to initialize the
1555 instance's attributes. A special C<__INSTANCE__> key can be passed to
1556 provide an already generated instance, rather than having Class::MOP
1557 generate it for you. This is mostly useful for using Class::MOP with
1558 foreign classes which generate instances using their own constructors.
1560 =item B<< $metaclass->instance_metaclass >>
1562 Returns the class name of the instance metaclass. See
1563 L<Class::MOP::Instance> for more information on the instance
1566 =item B<< $metaclass->get_meta_instance >>
1568 Returns an instance of the C<instance_metaclass> to be used in the
1569 construction of a new instance of the class.
1571 =item B<< $metaclass->inline_create_instance($class_var) >>
1573 =item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >>
1575 These methods takes variable names, and use them to create an inline snippet
1576 of code that will create a new instance of the class.
1580 =head2 Informational predicates
1582 These are a few predicate methods for asking information about the
1587 =item B<< $metaclass->is_anon_class >>
1589 This returns true if the class was created by calling C<<
1590 Class::MOP::Class->create_anon_class >>.
1592 =item B<< $metaclass->is_mutable >>
1594 This returns true if the class is still mutable.
1596 =item B<< $metaclass->is_immutable >>
1598 This returns true if the class has been made immutable.
1600 =item B<< $metaclass->is_pristine >>
1602 A class is I<not> pristine if it has non-inherited attributes or if it
1603 has any generated methods.
1607 =head2 Inheritance Relationships
1611 =item B<< $metaclass->superclasses(@superclasses) >>
1613 This is a read-write accessor which represents the superclass
1614 relationships of the metaclass's class.
1616 This is basically sugar around getting and setting C<@ISA>.
1618 =item B<< $metaclass->class_precedence_list >>
1620 This returns a list of all of the class's ancestor classes. The
1621 classes are returned in method dispatch order.
1623 =item B<< $metaclass->linearized_isa >>
1625 This returns a list based on C<class_precedence_list> but with all
1628 =item B<< $metaclass->subclasses >>
1630 This returns a list of all subclasses for this class, even indirect
1633 =item B<< $metaclass->direct_subclasses >>
1635 This returns a list of immediate subclasses for this class, which does not
1636 include indirect subclasses.
1640 =head2 Method introspection and creation
1642 These methods allow you to introspect a class's methods, as well as
1643 add, remove, or change methods.
1645 Determining what is truly a method in a Perl 5 class requires some
1646 heuristics (aka guessing).
1648 Methods defined outside the package with a fully qualified name (C<sub
1649 Package::name { ... }>) will be included. Similarly, methods named
1650 with a fully qualified name using L<Sub::Name> are also included.
1652 However, we attempt to ignore imported functions.
1654 Ultimately, we are using heuristics to determine what truly is a
1655 method in a class, and these heuristics may get the wrong answer in
1656 some edge cases. However, for most "normal" cases the heuristics work
1661 =item B<< $metaclass->get_method($method_name) >>
1663 This will return a L<Class::MOP::Method> for the specified
1664 C<$method_name>. If the class does not have the specified method, it
1667 =item B<< $metaclass->has_method($method_name) >>
1669 Returns a boolean indicating whether or not the class defines the
1670 named method. It does not include methods inherited from parent
1673 =item B<< $metaclass->get_method_list >>
1675 This will return a list of method I<names> for all methods defined in
1678 =item B<< $metaclass->add_method($method_name, $method) >>
1680 This method takes a method name and a subroutine reference, and adds
1681 the method to the class.
1683 The subroutine reference can be a L<Class::MOP::Method>, and you are
1684 strongly encouraged to pass a meta method object instead of a code
1685 reference. If you do so, that object gets stored as part of the
1686 class's method map directly. If not, the meta information will have to
1687 be recreated later, and may be incorrect.
1689 If you provide a method object, this method will clone that object if
1690 the object's package name does not match the class name. This lets us
1691 track the original source of any methods added from other classes
1692 (notably Moose roles).
1694 =item B<< $metaclass->remove_method($method_name) >>
1696 Remove the named method from the class. This method returns the
1697 L<Class::MOP::Method> object for the method.
1699 =item B<< $metaclass->method_metaclass >>
1701 Returns the class name of the method metaclass, see
1702 L<Class::MOP::Method> for more information on the method metaclass.
1704 =item B<< $metaclass->wrapped_method_metaclass >>
1706 Returns the class name of the wrapped method metaclass, see
1707 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1710 =item B<< $metaclass->get_all_methods >>
1712 This will traverse the inheritance hierarchy and return a list of all
1713 the L<Class::MOP::Method> objects for this class and its parents.
1715 =item B<< $metaclass->find_method_by_name($method_name) >>
1717 This will return a L<Class::MOP::Method> for the specified
1718 C<$method_name>. If the class does not have the specified method, it
1721 Unlike C<get_method>, this method I<will> look for the named method in
1724 =item B<< $metaclass->get_all_method_names >>
1726 This will return a list of method I<names> for all of this class's
1727 methods, including inherited methods.
1729 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1731 This method looks for the named method in the class and all of its
1732 parents. It returns every matching method it finds in the inheritance
1733 tree, so it returns a list of methods.
1735 Each method is returned as a hash reference with three keys. The keys
1736 are C<name>, C<class>, and C<code>. The C<code> key has a
1737 L<Class::MOP::Method> object as its value.
1739 The list of methods is distinct.
1741 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1743 This method returns the first method in any superclass matching the
1744 given name. It is effectively the method that C<SUPER::$method_name>
1749 =head2 Attribute introspection and creation
1751 Because Perl 5 does not have a core concept of attributes in classes,
1752 we can only return information about attributes which have been added
1753 via this class's methods. We cannot discover information about
1754 attributes which are defined in terms of "regular" Perl 5 methods.
1758 =item B<< $metaclass->get_attribute($attribute_name) >>
1760 This will return a L<Class::MOP::Attribute> for the specified
1761 C<$attribute_name>. If the class does not have the specified
1762 attribute, it returns C<undef>.
1764 NOTE that get_attribute does not search superclasses, for that you
1765 need to use C<find_attribute_by_name>.
1767 =item B<< $metaclass->has_attribute($attribute_name) >>
1769 Returns a boolean indicating whether or not the class defines the
1770 named attribute. It does not include attributes inherited from parent
1773 =item B<< $metaclass->get_attribute_list >>
1775 This will return a list of attributes I<names> for all attributes
1776 defined in this class. Note that this operates on the current class
1777 only, it does not traverse the inheritance hierarchy.
1779 =item B<< $metaclass->get_all_attributes >>
1781 This will traverse the inheritance hierarchy and return a list of all
1782 the L<Class::MOP::Attribute> objects for this class and its parents.
1784 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1786 This will return a L<Class::MOP::Attribute> for the specified
1787 C<$attribute_name>. If the class does not have the specified
1788 attribute, it returns C<undef>.
1790 Unlike C<get_attribute>, this attribute I<will> look for the named
1791 attribute in superclasses.
1793 =item B<< $metaclass->add_attribute(...) >>
1795 This method accepts either an existing L<Class::MOP::Attribute>
1796 object or parameters suitable for passing to that class's C<new>
1799 The attribute provided will be added to the class.
1801 Any accessor methods defined by the attribute will be added to the
1802 class when the attribute is added.
1804 If an attribute of the same name already exists, the old attribute
1805 will be removed first.
1807 =item B<< $metaclass->remove_attribute($attribute_name) >>
1809 This will remove the named attribute from the class, and
1810 L<Class::MOP::Attribute> object.
1812 Removing an attribute also removes any accessor methods defined by the
1815 However, note that removing an attribute will only affect I<future>
1816 object instances created for this class, not existing instances.
1818 =item B<< $metaclass->attribute_metaclass >>
1820 Returns the class name of the attribute metaclass for this class. By
1821 default, this is L<Class::MOP::Attribute>.
1825 =head2 Class Immutability
1827 Making a class immutable "freezes" the class definition. You can no
1828 longer call methods which alter the class, such as adding or removing
1829 methods or attributes.
1831 Making a class immutable lets us optimize the class by inlining some
1832 methods, and also allows us to optimize some methods on the metaclass
1835 After immutabilization, the metaclass object will cache most informational
1836 methods that returns information about methods or attributes. Methods which
1837 would alter the class, such as C<add_attribute> and C<add_method>, will
1838 throw an error on an immutable metaclass object.
1840 The immutabilization system in L<Moose> takes much greater advantage
1841 of the inlining features than Class::MOP itself does.
1845 =item B<< $metaclass->make_immutable(%options) >>
1847 This method will create an immutable transformer and use it to make
1848 the class and its metaclass object immutable.
1850 This method accepts the following options:
1854 =item * inline_accessors
1856 =item * inline_constructor
1858 =item * inline_destructor
1860 These are all booleans indicating whether the specified method(s)
1863 By default, accessors and the constructor are inlined, but not the
1866 =item * immutable_trait
1868 The name of a class which will be used as a parent class for the
1869 metaclass object being made immutable. This "trait" implements the
1870 post-immutability functionality of the metaclass (but not the
1871 transformation itself).
1873 This defaults to L<Class::MOP::Class::Immutable::Trait>.
1875 =item * constructor_name
1877 This is the constructor method name. This defaults to "new".
1879 =item * constructor_class
1881 The name of the method metaclass for constructors. It will be used to
1882 generate the inlined constructor. This defaults to
1883 "Class::MOP::Method::Constructor".
1885 =item * replace_constructor
1887 This is a boolean indicating whether an existing constructor should be
1888 replaced when inlining a constructor. This defaults to false.
1890 =item * destructor_class
1892 The name of the method metaclass for destructors. It will be used to
1893 generate the inlined destructor. This defaults to
1894 "Class::MOP::Method::Denstructor".
1896 =item * replace_destructor
1898 This is a boolean indicating whether an existing destructor should be
1899 replaced when inlining a destructor. This defaults to false.
1903 =item B<< $metaclass->immutable_options >>
1905 Returns a hash of the options used when making the class immutable, including
1906 both defaults and anything supplied by the user in the call to C<<
1907 $metaclass->make_immutable >>. This is useful if you need to temporarily make
1908 a class mutable and then restore immutability as it was before.
1910 =item B<< $metaclass->make_mutable >>
1912 Calling this method reverse the immutabilization transformation.
1916 =head2 Method Modifiers
1918 Method modifiers are hooks which allow a method to be wrapped with
1919 I<before>, I<after> and I<around> method modifiers. Every time a
1920 method is called, its modifiers are also called.
1922 A class can modify its own methods, as well as methods defined in
1925 =head3 How method modifiers work?
1927 Method modifiers work by wrapping the original method and then
1928 replacing it in the class's symbol table. The wrappers will handle
1929 calling all the modifiers in the appropriate order and preserving the
1930 calling context for the original method.
1932 The return values of C<before> and C<after> modifiers are
1933 ignored. This is because their purpose is B<not> to filter the input
1934 and output of the primary method (this is done with an I<around>
1937 This may seem like an odd restriction to some, but doing this allows
1938 for simple code to be added at the beginning or end of a method call
1939 without altering the function of the wrapped method or placing any
1940 extra responsibility on the code of the modifier.
1942 Of course if you have more complex needs, you can use the C<around>
1943 modifier which allows you to change both the parameters passed to the
1944 wrapped method, as well as its return value.
1946 Before and around modifiers are called in last-defined-first-called
1947 order, while after modifiers are called in first-defined-first-called
1948 order. So the call tree might looks something like this:
1960 =head3 What is the performance impact?
1962 Of course there is a performance cost associated with method
1963 modifiers, but we have made every effort to make that cost directly
1964 proportional to the number of modifier features you use.
1966 The wrapping method does its best to B<only> do as much work as it
1967 absolutely needs to. In order to do this we have moved some of the
1968 performance costs to set-up time, where they are easier to amortize.
1970 All this said, our benchmarks have indicated the following:
1972 simple wrapper with no modifiers 100% slower
1973 simple wrapper with simple before modifier 400% slower
1974 simple wrapper with simple after modifier 450% slower
1975 simple wrapper with simple around modifier 500-550% slower
1976 simple wrapper with all 3 modifiers 1100% slower
1978 These numbers may seem daunting, but you must remember, every feature
1979 comes with some cost. To put things in perspective, just doing a
1980 simple C<AUTOLOAD> which does nothing but extract the name of the
1981 method called and return it costs about 400% over a normal method
1986 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
1988 This wraps the specified method with the supplied subroutine
1989 reference. The modifier will be called as a method itself, and will
1990 receive the same arguments as are passed to the method.
1992 When the modifier exits, the wrapped method will be called.
1994 The return value of the modifier will be ignored.
1996 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
1998 This wraps the specified method with the supplied subroutine
1999 reference. The modifier will be called as a method itself, and will
2000 receive the same arguments as are passed to the method.
2002 When the wrapped methods exits, the modifier will be called.
2004 The return value of the modifier will be ignored.
2006 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
2008 This wraps the specified method with the supplied subroutine
2011 The first argument passed to the modifier will be a subroutine
2012 reference to the wrapped method. The second argument is the object,
2013 and after that come any arguments passed when the method is called.
2015 The around modifier can choose to call the original method, as well as
2016 what arguments to pass if it does so.
2018 The return value of the modifier is what will be seen by the caller.
2022 =head2 Introspection
2026 =item B<< Class::MOP::Class->meta >>
2028 This will return a L<Class::MOP::Class> instance for this class.
2030 It should also be noted that L<Class::MOP> will actually bootstrap
2031 this module by installing a number of attribute meta-objects into its
2038 Stevan Little E<lt>stevan@iinteractive.comE<gt>
2040 =head1 COPYRIGHT AND LICENSE
2042 Copyright 2006-2010 by Infinity Interactive, Inc.
2044 L<http://www.iinteractive.com>
2046 This library is free software; you can redistribute it and/or modify
2047 it under the same terms as Perl itself.