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});
543 # all these attribute readers will be bootstrapped
544 # away in the Class::MOP bootstrap section
546 sub instance_metaclass { $_[0]->{'instance_metaclass'} }
547 sub immutable_trait { $_[0]->{'immutable_trait'} }
548 sub constructor_class { $_[0]->{'constructor_class'} }
549 sub constructor_name { $_[0]->{'constructor_name'} }
550 sub destructor_class { $_[0]->{'destructor_class'} }
552 # Instance Construction & Cloning
558 # we need to protect the integrity of the
559 # Class::MOP::Class singletons here, so we
560 # delegate this to &construct_class_instance
561 # which will deal with the singletons
562 return $class->_construct_class_instance(@_)
563 if $class->name->isa('Class::MOP::Class');
564 return $class->_construct_instance(@_);
567 sub _construct_instance {
569 my $params = @_ == 1 ? $_[0] : {@_};
570 my $meta_instance = $class->get_meta_instance();
572 # the code below is almost certainly incorrect
573 # but this is foreign inheritance, so we might
574 # have to kludge it in the end.
576 if (my $instance_class = blessed($params->{__INSTANCE__})) {
577 ($instance_class eq $class->name)
578 || confess "Objects passed as the __INSTANCE__ parameter must "
579 . "already be blessed into the correct class, but "
580 . "$params->{__INSTANCE__} is not a " . $class->name;
581 $instance = $params->{__INSTANCE__};
583 elsif (exists $params->{__INSTANCE__}) {
584 confess "The __INSTANCE__ parameter must be a blessed reference, not "
585 . $params->{__INSTANCE__};
588 $instance = $meta_instance->create_instance();
590 foreach my $attr ($class->get_all_attributes()) {
591 $attr->initialize_instance_slot($meta_instance, $instance, $params);
593 if (Class::MOP::metaclass_is_weak($class->name)) {
594 $meta_instance->_set_mop_slot($instance, $class);
600 sub get_meta_instance {
602 $self->{'_meta_instance'} ||= $self->_create_meta_instance();
605 sub _create_meta_instance {
608 my $instance = $self->instance_metaclass->new(
609 associated_metaclass => $self,
610 attributes => [ $self->get_all_attributes() ],
613 $self->add_meta_instance_dependencies()
614 if $instance->is_dependent_on_superclasses();
619 sub inline_create_instance {
622 return $self->get_meta_instance->inline_create_instance(@_);
625 sub inline_rebless_instance {
628 return $self->get_meta_instance->inline_rebless_instance_structure(@_);
631 sub _inline_get_mop_slot {
634 return $self->get_meta_instance->_inline_get_mop_slot(@_);
637 sub _inline_set_mop_slot {
640 return $self->get_meta_instance->_inline_set_mop_slot(@_);
643 sub _inline_clear_mop_slot {
646 return $self->get_meta_instance->_inline_clear_mop_slot(@_);
651 my $instance = shift;
652 (blessed($instance) && $instance->isa($class->name))
653 || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
656 # we need to protect the integrity of the
657 # Class::MOP::Class singletons here, they
658 # should not be cloned.
659 return $instance if $instance->isa('Class::MOP::Class');
660 $class->_clone_instance($instance, @_);
663 sub _clone_instance {
664 my ($class, $instance, %params) = @_;
666 || confess "You can only clone instances, ($instance) is not a blessed instance";
667 my $meta_instance = $class->get_meta_instance();
668 my $clone = $meta_instance->clone_instance($instance);
669 foreach my $attr ($class->get_all_attributes()) {
670 if ( defined( my $init_arg = $attr->init_arg ) ) {
671 if (exists $params{$init_arg}) {
672 $attr->set_value($clone, $params{$init_arg});
679 sub _force_rebless_instance {
680 my ($self, $instance, %params) = @_;
681 my $old_metaclass = Class::MOP::class_of($instance);
683 $old_metaclass->rebless_instance_away($instance, $self, %params)
686 my $meta_instance = $self->get_meta_instance;
688 if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
689 $meta_instance->_clear_mop_slot($instance);
693 # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
694 $meta_instance->rebless_instance_structure($_[1], $self);
696 $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
698 if (Class::MOP::metaclass_is_weak($self->name)) {
699 $meta_instance->_set_mop_slot($instance, $self);
703 sub rebless_instance {
704 my ($self, $instance, %params) = @_;
705 my $old_metaclass = Class::MOP::class_of($instance);
707 my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
708 $self->name->isa($old_class)
709 || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
711 $self->_force_rebless_instance($_[1], %params);
716 sub rebless_instance_back {
717 my ( $self, $instance ) = @_;
718 my $old_metaclass = Class::MOP::class_of($instance);
721 = $old_metaclass ? $old_metaclass->name : blessed($instance);
722 $old_class->isa( $self->name )
724 "You may rebless only into a superclass of ($old_class), of which ("
728 $self->_force_rebless_instance($_[1]);
733 sub rebless_instance_away {
734 # this intentionally does nothing, it is just a hook
737 sub _fixup_attributes_after_rebless {
739 my ($instance, $rebless_from, %params) = @_;
740 my $meta_instance = $self->get_meta_instance;
742 for my $attr ( $rebless_from->get_all_attributes ) {
743 next if $self->find_attribute_by_name( $attr->name );
744 $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
747 foreach my $attr ( $self->get_all_attributes ) {
748 if ( $attr->has_value($instance) ) {
749 if ( defined( my $init_arg = $attr->init_arg ) ) {
750 $params{$init_arg} = $attr->get_value($instance)
751 unless exists $params{$init_arg};
754 $attr->set_value($instance, $attr->get_value($instance));
759 foreach my $attr ($self->get_all_attributes) {
760 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
764 sub _attach_attribute {
765 my ($self, $attribute) = @_;
766 $attribute->attach_to_class($self);
769 sub _post_add_attribute {
770 my ( $self, $attribute ) = @_;
772 $self->invalidate_meta_instances;
774 # invalidate package flag here
777 $attribute->install_accessors;
780 $self->remove_attribute( $attribute->name );
785 sub remove_attribute {
788 my $removed_attribute = $self->SUPER::remove_attribute(@_)
791 $self->invalidate_meta_instances;
793 $removed_attribute->remove_accessors;
794 $removed_attribute->detach_from_class;
796 return$removed_attribute;
799 sub find_attribute_by_name {
800 my ( $self, $attr_name ) = @_;
802 foreach my $class ( $self->linearized_isa ) {
803 # fetch the meta-class ...
804 my $meta = Class::MOP::Class->initialize($class);
805 return $meta->get_attribute($attr_name)
806 if $meta->has_attribute($attr_name);
812 sub get_all_attributes {
814 my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
815 reverse $self->linearized_isa;
816 return values %attrs;
824 my $isa = $self->get_or_add_package_symbol(
825 { sigil => '@', type => 'ARRAY', name => 'ISA' } );
832 # on 5.8 and below, we need to call
833 # a method to get Perl to detect
834 # a cycle in the class hierarchy
835 my $class = $self->name;
839 # we need to check the metaclass
840 # compatibility here so that we can
841 # be sure that the superclass is
842 # not potentially creating an issues
843 # we don't know about
845 $self->_check_metaclass_compatibility();
846 $self->_superclasses_updated();
852 sub _superclasses_updated {
854 $self->update_meta_instance_dependencies();
855 # keep strong references to all our parents, so they don't disappear if
856 # they are anon classes and don't have any direct instances
857 $self->_superclass_metas(
858 map { Class::MOP::class_of($_) } $self->superclasses
862 sub _superclass_metas {
864 $self->{_superclass_metas} = [@_];
869 my $super_class = $self->name;
871 return @{ $super_class->mro::get_isarev() };
874 sub direct_subclasses {
876 my $super_class = $self->name;
881 } Class::MOP::Class->initialize($_)->superclasses
886 return @{ mro::get_linear_isa( (shift)->name ) };
889 sub class_precedence_list {
891 my $name = $self->name;
893 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
895 # We need to check for circular inheritance here
896 # if we are are not on 5.10, cause 5.8 detects it
897 # late. This will do nothing if all is well, and
898 # blow up otherwise. Yes, it's an ugly hack, better
899 # suggestions are welcome.
901 ($name || return)->isa('This is a test for circular inheritance')
904 # if our mro is c3, we can
905 # just grab the linear_isa
906 if (mro::get_mro($name) eq 'c3') {
907 return @{ mro::get_linear_isa($name) }
911 # we can't grab the linear_isa for dfs
912 # since it has all the duplicates
917 Class::MOP::Class->initialize($_)->class_precedence_list()
918 } $self->superclasses()
926 my $fetch_and_prepare_method = sub {
927 my ($self, $method_name) = @_;
928 my $wrapped_metaclass = $self->wrapped_method_metaclass;
930 my $method = $self->get_method($method_name);
931 # if we dont have local ...
933 # try to find the next method
934 $method = $self->find_next_method_by_name($method_name);
935 # die if it does not exist
937 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
938 # and now make sure to wrap it
939 # even if it is already wrapped
940 # because we need a new sub ref
941 $method = $wrapped_metaclass->wrap($method,
942 package_name => $self->name,
943 name => $method_name,
947 # now make sure we wrap it properly
948 $method = $wrapped_metaclass->wrap($method,
949 package_name => $self->name,
950 name => $method_name,
951 ) unless $method->isa($wrapped_metaclass);
953 $self->add_method($method_name => $method);
957 sub add_before_method_modifier {
958 my ($self, $method_name, $method_modifier) = @_;
959 (defined $method_name && length $method_name)
960 || confess "You must pass in a method name";
961 my $method = $fetch_and_prepare_method->($self, $method_name);
962 $method->add_before_modifier(
963 subname(':before' => $method_modifier)
967 sub add_after_method_modifier {
968 my ($self, $method_name, $method_modifier) = @_;
969 (defined $method_name && length $method_name)
970 || confess "You must pass in a method name";
971 my $method = $fetch_and_prepare_method->($self, $method_name);
972 $method->add_after_modifier(
973 subname(':after' => $method_modifier)
977 sub add_around_method_modifier {
978 my ($self, $method_name, $method_modifier) = @_;
979 (defined $method_name && length $method_name)
980 || confess "You must pass in a method name";
981 my $method = $fetch_and_prepare_method->($self, $method_name);
982 $method->add_around_modifier(
983 subname(':around' => $method_modifier)
988 # the methods above used to be named like this:
989 # ${pkg}::${method}:(before|after|around)
990 # but this proved problematic when using one modifier
991 # to wrap multiple methods (something which is likely
992 # to happen pretty regularly IMO). So instead of naming
993 # it like this, I have chosen to just name them purely
994 # with their modifier names, like so:
995 # :(before|after|around)
996 # The fact is that in a stack trace, it will be fairly
997 # evident from the context what method they are attached
998 # to, and so don't need the fully qualified name.
1001 sub find_method_by_name {
1002 my ($self, $method_name) = @_;
1003 (defined $method_name && length $method_name)
1004 || confess "You must define a method name to find";
1005 foreach my $class ($self->linearized_isa) {
1006 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1007 return $method if defined $method;
1012 sub get_all_methods {
1016 for my $class ( reverse $self->linearized_isa ) {
1017 my $meta = Class::MOP::Class->initialize($class);
1019 $methods{ $_->name } = $_ for $meta->_get_local_methods;
1022 return values %methods;
1025 sub get_all_method_names {
1028 return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
1031 sub find_all_methods_by_name {
1032 my ($self, $method_name) = @_;
1033 (defined $method_name && length $method_name)
1034 || confess "You must define a method name to find";
1036 foreach my $class ($self->linearized_isa) {
1037 # fetch the meta-class ...
1038 my $meta = Class::MOP::Class->initialize($class);
1040 name => $method_name,
1042 code => $meta->get_method($method_name)
1043 } if $meta->has_method($method_name);
1048 sub find_next_method_by_name {
1049 my ($self, $method_name) = @_;
1050 (defined $method_name && length $method_name)
1051 || confess "You must define a method name to find";
1052 my @cpl = $self->linearized_isa;
1053 shift @cpl; # discard ourselves
1054 foreach my $class (@cpl) {
1055 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1056 return $method if defined $method;
1061 sub update_meta_instance_dependencies {
1064 if ( $self->{meta_instance_dependencies} ) {
1065 return $self->add_meta_instance_dependencies;
1069 sub add_meta_instance_dependencies {
1072 $self->remove_meta_instance_dependencies;
1074 my @attrs = $self->get_all_attributes();
1077 my @classes = grep { not $seen{ $_->name }++ }
1078 map { $_->associated_class } @attrs;
1080 foreach my $class (@classes) {
1081 $class->add_dependent_meta_instance($self);
1084 $self->{meta_instance_dependencies} = \@classes;
1087 sub remove_meta_instance_dependencies {
1090 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
1091 foreach my $class (@$classes) {
1092 $class->remove_dependent_meta_instance($self);
1102 sub add_dependent_meta_instance {
1103 my ( $self, $metaclass ) = @_;
1104 push @{ $self->{dependent_meta_instances} }, $metaclass;
1107 sub remove_dependent_meta_instance {
1108 my ( $self, $metaclass ) = @_;
1109 my $name = $metaclass->name;
1110 @$_ = grep { $_->name ne $name } @$_
1111 for $self->{dependent_meta_instances};
1114 sub invalidate_meta_instances {
1116 $_->invalidate_meta_instance()
1117 for $self, @{ $self->{dependent_meta_instances} };
1120 sub invalidate_meta_instance {
1122 undef $self->{_meta_instance};
1125 # check if we can reinitialize
1129 # if any local attr is defined
1130 return if $self->get_attribute_list;
1132 # or any non-declared methods
1133 for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
1134 return if $method->isa("Class::MOP::Method::Generated");
1135 # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
1143 sub is_mutable { 1 }
1144 sub is_immutable { 0 }
1146 sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
1148 sub _immutable_options {
1149 my ( $self, @args ) = @_;
1152 inline_accessors => 1,
1153 inline_constructor => 1,
1154 inline_destructor => 0,
1156 immutable_trait => $self->immutable_trait,
1157 constructor_name => $self->constructor_name,
1158 constructor_class => $self->constructor_class,
1159 destructor_class => $self->destructor_class,
1164 sub make_immutable {
1165 my ( $self, @args ) = @_;
1167 if ( $self->is_mutable ) {
1168 $self->_initialize_immutable( $self->_immutable_options(@args) );
1169 $self->_rebless_as_immutable(@args);
1180 if ( $self->is_immutable ) {
1181 my @args = $self->immutable_options;
1182 $self->_rebless_as_mutable();
1183 $self->_remove_inlined_code(@args);
1184 delete $self->{__immutable};
1192 sub _rebless_as_immutable {
1193 my ( $self, @args ) = @_;
1195 $self->{__immutable}{original_class} = ref $self;
1197 bless $self => $self->_immutable_metaclass(@args);
1200 sub _immutable_metaclass {
1201 my ( $self, %args ) = @_;
1203 if ( my $class = $args{immutable_metaclass} ) {
1207 my $trait = $args{immutable_trait} = $self->immutable_trait
1208 || confess "no immutable trait specified for $self";
1210 my $meta = $self->meta;
1211 my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
1215 if ( $meta_attr and $trait eq $meta_attr->default ) {
1216 # if the trait is the same as the default we try and pick a
1217 # predictable name for the immutable metaclass
1218 $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1221 $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1222 $trait, 'ForMetaClass', ref($self);
1226 if Class::MOP::is_class_loaded($class_name);
1228 # If the metaclass is a subclass of CMOP::Class which has had
1229 # metaclass roles applied (via Moose), then we want to make sure
1230 # that we preserve that anonymous class (see Fey::ORM for an
1231 # example of where this matters).
1232 my $meta_name = $meta->_real_ref_name;
1234 my $immutable_meta = $meta_name->create(
1236 superclasses => [ ref $self ],
1239 Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
1241 $immutable_meta->make_immutable(
1242 inline_constructor => 0,
1243 inline_accessors => 0,
1249 sub _remove_inlined_code {
1252 $self->remove_method( $_->name ) for $self->_inlined_methods;
1254 delete $self->{__immutable}{inlined_methods};
1257 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1259 sub _add_inlined_method {
1260 my ( $self, $method ) = @_;
1262 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1265 sub _initialize_immutable {
1266 my ( $self, %args ) = @_;
1268 $self->{__immutable}{options} = \%args;
1269 $self->_install_inlined_code(%args);
1272 sub _install_inlined_code {
1273 my ( $self, %args ) = @_;
1276 $self->_inline_accessors(%args) if $args{inline_accessors};
1277 $self->_inline_constructor(%args) if $args{inline_constructor};
1278 $self->_inline_destructor(%args) if $args{inline_destructor};
1281 sub _rebless_as_mutable {
1284 bless $self, $self->_get_mutable_metaclass_name;
1289 sub _inline_accessors {
1292 foreach my $attr_name ( $self->get_attribute_list ) {
1293 $self->get_attribute($attr_name)->install_accessors(1);
1297 sub _inline_constructor {
1298 my ( $self, %args ) = @_;
1300 my $name = $args{constructor_name};
1301 # A class may not even have a constructor, and that's okay.
1302 return unless defined $name;
1304 if ( $self->has_method($name) && !$args{replace_constructor} ) {
1305 my $class = $self->name;
1306 warn "Not inlining a constructor for $class since it defines"
1307 . " its own constructor.\n"
1308 . "If you are certain you don't need to inline your"
1309 . " constructor, specify inline_constructor => 0 in your"
1310 . " call to $class->meta->make_immutable\n";
1314 my $constructor_class = $args{constructor_class};
1316 Class::MOP::load_class($constructor_class);
1318 my $constructor = $constructor_class->new(
1322 package_name => $self->name,
1326 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1327 $self->add_method( $name => $constructor );
1328 $self->_add_inlined_method($constructor);
1332 sub _inline_destructor {
1333 my ( $self, %args ) = @_;
1335 ( exists $args{destructor_class} && defined $args{destructor_class} )
1336 || confess "The 'inline_destructor' option is present, but "
1337 . "no destructor class was specified";
1339 if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1340 my $class = $self->name;
1341 warn "Not inlining a destructor for $class since it defines"
1342 . " its own destructor.\n";
1346 my $destructor_class = $args{destructor_class};
1348 Class::MOP::load_class($destructor_class);
1350 return unless $destructor_class->is_needed($self);
1352 my $destructor = $destructor_class->new(
1355 package_name => $self->name,
1359 if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1360 $self->add_method( 'DESTROY' => $destructor );
1361 $self->_add_inlined_method($destructor);
1373 Class::MOP::Class - Class Meta Object
1377 # assuming that class Foo
1378 # has been defined, you can
1380 # use this for introspection ...
1382 # add a method to Foo ...
1383 Foo->meta->add_method( 'bar' => sub {...} )
1385 # get a list of all the classes searched
1386 # the method dispatcher in the correct order
1387 Foo->meta->class_precedence_list()
1389 # remove a method from Foo
1390 Foo->meta->remove_method('bar');
1392 # or use this to actually create classes ...
1394 Class::MOP::Class->create(
1397 superclasses => ['Foo'],
1399 Class::MOP::Attribute->new('$bar'),
1400 Class::MOP::Attribute->new('$baz'),
1403 calculate_bar => sub {...},
1404 construct_baz => sub {...}
1411 The Class Protocol is the largest and most complex part of the
1412 Class::MOP meta-object protocol. It controls the introspection and
1413 manipulation of Perl 5 classes, and it can create them as well. The
1414 best way to understand what this module can do is to read the
1415 documentation for each of its methods.
1419 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1423 =head2 Class construction
1425 These methods all create new C<Class::MOP::Class> objects. These
1426 objects can represent existing classes or they can be used to create
1427 new classes from scratch.
1429 The metaclass object for a given class is a singleton. If you attempt
1430 to create a metaclass for the same class twice, you will just get the
1435 =item B<< Class::MOP::Class->create($package_name, %options) >>
1437 This method creates a new C<Class::MOP::Class> object with the given
1438 package name. It accepts a number of options:
1444 An optional version number for the newly created package.
1448 An optional authority for the newly created package.
1450 =item * superclasses
1452 An optional array reference of superclass names.
1456 An optional hash reference of methods for the class. The keys of the
1457 hash reference are method names and values are subroutine references.
1461 An optional array reference of L<Class::MOP::Attribute> objects.
1465 Specifies the name to install the C<meta> method for this class under.
1466 If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
1467 given, no meta method will be installed.
1471 If true, the metaclass that is stored in the global cache will be a
1474 Classes created in this way are destroyed once the metaclass they are
1475 attached to goes out of scope, and will be removed from Perl's internal
1478 All instances of a class with a weakened metaclass keep a special
1479 reference to the metaclass object, which prevents the metaclass from
1480 going out of scope while any instances exist.
1482 This only works if the instance is based on a hash reference, however.
1486 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1488 This method works just like C<< Class::MOP::Class->create >> but it
1489 creates an "anonymous" class. In fact, the class does have a name, but
1490 that name is a unique name generated internally by this module.
1492 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1493 parameters that C<create> accepts.
1495 Anonymous classes default to C<< weaken => 1 >>, although this can be
1498 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1500 This method will initialize a C<Class::MOP::Class> object for the
1501 named package. Unlike C<create>, this method I<will not> create a new
1504 The purpose of this method is to retrieve a C<Class::MOP::Class>
1505 object for introspecting an existing class.
1507 If an existing C<Class::MOP::Class> object exists for the named
1508 package, it will be returned, and any options provided will be
1511 If the object does not yet exist, it will be created.
1513 The valid options that can be passed to this method are
1514 C<attribute_metaclass>, C<method_metaclass>,
1515 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1516 optional, and default to the appropriate class in the C<Class::MOP>
1521 =head2 Object instance construction and cloning
1523 These methods are all related to creating and/or cloning object
1528 =item B<< $metaclass->clone_object($instance, %params) >>
1530 This method clones an existing object instance. Any parameters you
1531 provide are will override existing attribute values in the object.
1533 This is a convenience method for cloning an object instance, then
1534 blessing it into the appropriate package.
1536 You could implement a clone method in your class, using this method:
1539 my ($self, %params) = @_;
1540 $self->meta->clone_object($self, %params);
1543 =item B<< $metaclass->rebless_instance($instance, %params) >>
1545 This method changes the class of C<$instance> to the metaclass's class.
1547 You can only rebless an instance into a subclass of its current
1548 class. If you pass any additional parameters, these will be treated
1549 like constructor parameters and used to initialize the object's
1550 attributes. Any existing attributes that are already set will be
1553 Before reblessing the instance, this method will call
1554 C<rebless_instance_away> on the instance's current metaclass. This method
1555 will be passed the instance, the new metaclass, and any parameters
1556 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1557 does nothing; it is merely a hook.
1559 =item B<< $metaclass->rebless_instance_back($instance) >>
1561 Does the same thing as C<rebless_instance>, except that you can only
1562 rebless an instance into one of its superclasses. Any attributes that
1563 do not exist in the superclass will be deinitialized.
1565 This is a much more dangerous operation than C<rebless_instance>,
1566 especially when multiple inheritance is involved, so use this carefully!
1568 =item B<< $metaclass->new_object(%params) >>
1570 This method is used to create a new object of the metaclass's
1571 class. Any parameters you provide are used to initialize the
1572 instance's attributes. A special C<__INSTANCE__> key can be passed to
1573 provide an already generated instance, rather than having Class::MOP
1574 generate it for you. This is mostly useful for using Class::MOP with
1575 foreign classes which generate instances using their own constructors.
1577 =item B<< $metaclass->instance_metaclass >>
1579 Returns the class name of the instance metaclass. See
1580 L<Class::MOP::Instance> for more information on the instance
1583 =item B<< $metaclass->get_meta_instance >>
1585 Returns an instance of the C<instance_metaclass> to be used in the
1586 construction of a new instance of the class.
1588 =item B<< $metaclass->inline_create_instance($class_var) >>
1590 =item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >>
1592 These methods takes variable names, and use them to create an inline snippet
1593 of code that will create a new instance of the class.
1597 =head2 Informational predicates
1599 These are a few predicate methods for asking information about the
1604 =item B<< $metaclass->is_anon_class >>
1606 This returns true if the class was created by calling C<<
1607 Class::MOP::Class->create_anon_class >>.
1609 =item B<< $metaclass->is_mutable >>
1611 This returns true if the class is still mutable.
1613 =item B<< $metaclass->is_immutable >>
1615 This returns true if the class has been made immutable.
1617 =item B<< $metaclass->is_pristine >>
1619 A class is I<not> pristine if it has non-inherited attributes or if it
1620 has any generated methods.
1624 =head2 Inheritance Relationships
1628 =item B<< $metaclass->superclasses(@superclasses) >>
1630 This is a read-write accessor which represents the superclass
1631 relationships of the metaclass's class.
1633 This is basically sugar around getting and setting C<@ISA>.
1635 =item B<< $metaclass->class_precedence_list >>
1637 This returns a list of all of the class's ancestor classes. The
1638 classes are returned in method dispatch order.
1640 =item B<< $metaclass->linearized_isa >>
1642 This returns a list based on C<class_precedence_list> but with all
1645 =item B<< $metaclass->subclasses >>
1647 This returns a list of all subclasses for this class, even indirect
1650 =item B<< $metaclass->direct_subclasses >>
1652 This returns a list of immediate subclasses for this class, which does not
1653 include indirect subclasses.
1657 =head2 Method introspection and creation
1659 These methods allow you to introspect a class's methods, as well as
1660 add, remove, or change methods.
1662 Determining what is truly a method in a Perl 5 class requires some
1663 heuristics (aka guessing).
1665 Methods defined outside the package with a fully qualified name (C<sub
1666 Package::name { ... }>) will be included. Similarly, methods named
1667 with a fully qualified name using L<Sub::Name> are also included.
1669 However, we attempt to ignore imported functions.
1671 Ultimately, we are using heuristics to determine what truly is a
1672 method in a class, and these heuristics may get the wrong answer in
1673 some edge cases. However, for most "normal" cases the heuristics work
1678 =item B<< $metaclass->get_method($method_name) >>
1680 This will return a L<Class::MOP::Method> for the specified
1681 C<$method_name>. If the class does not have the specified method, it
1684 =item B<< $metaclass->has_method($method_name) >>
1686 Returns a boolean indicating whether or not the class defines the
1687 named method. It does not include methods inherited from parent
1690 =item B<< $metaclass->get_method_list >>
1692 This will return a list of method I<names> for all methods defined in
1695 =item B<< $metaclass->add_method($method_name, $method) >>
1697 This method takes a method name and a subroutine reference, and adds
1698 the method to the class.
1700 The subroutine reference can be a L<Class::MOP::Method>, and you are
1701 strongly encouraged to pass a meta method object instead of a code
1702 reference. If you do so, that object gets stored as part of the
1703 class's method map directly. If not, the meta information will have to
1704 be recreated later, and may be incorrect.
1706 If you provide a method object, this method will clone that object if
1707 the object's package name does not match the class name. This lets us
1708 track the original source of any methods added from other classes
1709 (notably Moose roles).
1711 =item B<< $metaclass->remove_method($method_name) >>
1713 Remove the named method from the class. This method returns the
1714 L<Class::MOP::Method> object for the method.
1716 =item B<< $metaclass->method_metaclass >>
1718 Returns the class name of the method metaclass, see
1719 L<Class::MOP::Method> for more information on the method metaclass.
1721 =item B<< $metaclass->wrapped_method_metaclass >>
1723 Returns the class name of the wrapped method metaclass, see
1724 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1727 =item B<< $metaclass->get_all_methods >>
1729 This will traverse the inheritance hierarchy and return a list of all
1730 the L<Class::MOP::Method> objects for this class and its parents.
1732 =item B<< $metaclass->find_method_by_name($method_name) >>
1734 This will return a L<Class::MOP::Method> for the specified
1735 C<$method_name>. If the class does not have the specified method, it
1738 Unlike C<get_method>, this method I<will> look for the named method in
1741 =item B<< $metaclass->get_all_method_names >>
1743 This will return a list of method I<names> for all of this class's
1744 methods, including inherited methods.
1746 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1748 This method looks for the named method in the class and all of its
1749 parents. It returns every matching method it finds in the inheritance
1750 tree, so it returns a list of methods.
1752 Each method is returned as a hash reference with three keys. The keys
1753 are C<name>, C<class>, and C<code>. The C<code> key has a
1754 L<Class::MOP::Method> object as its value.
1756 The list of methods is distinct.
1758 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1760 This method returns the first method in any superclass matching the
1761 given name. It is effectively the method that C<SUPER::$method_name>
1766 =head2 Attribute introspection and creation
1768 Because Perl 5 does not have a core concept of attributes in classes,
1769 we can only return information about attributes which have been added
1770 via this class's methods. We cannot discover information about
1771 attributes which are defined in terms of "regular" Perl 5 methods.
1775 =item B<< $metaclass->get_attribute($attribute_name) >>
1777 This will return a L<Class::MOP::Attribute> for the specified
1778 C<$attribute_name>. If the class does not have the specified
1779 attribute, it returns C<undef>.
1781 NOTE that get_attribute does not search superclasses, for that you
1782 need to use C<find_attribute_by_name>.
1784 =item B<< $metaclass->has_attribute($attribute_name) >>
1786 Returns a boolean indicating whether or not the class defines the
1787 named attribute. It does not include attributes inherited from parent
1790 =item B<< $metaclass->get_attribute_list >>
1792 This will return a list of attributes I<names> for all attributes
1793 defined in this class. Note that this operates on the current class
1794 only, it does not traverse the inheritance hierarchy.
1796 =item B<< $metaclass->get_all_attributes >>
1798 This will traverse the inheritance hierarchy and return a list of all
1799 the L<Class::MOP::Attribute> objects for this class and its parents.
1801 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1803 This will return a L<Class::MOP::Attribute> for the specified
1804 C<$attribute_name>. If the class does not have the specified
1805 attribute, it returns C<undef>.
1807 Unlike C<get_attribute>, this attribute I<will> look for the named
1808 attribute in superclasses.
1810 =item B<< $metaclass->add_attribute(...) >>
1812 This method accepts either an existing L<Class::MOP::Attribute>
1813 object or parameters suitable for passing to that class's C<new>
1816 The attribute provided will be added to the class.
1818 Any accessor methods defined by the attribute will be added to the
1819 class when the attribute is added.
1821 If an attribute of the same name already exists, the old attribute
1822 will be removed first.
1824 =item B<< $metaclass->remove_attribute($attribute_name) >>
1826 This will remove the named attribute from the class, and
1827 L<Class::MOP::Attribute> object.
1829 Removing an attribute also removes any accessor methods defined by the
1832 However, note that removing an attribute will only affect I<future>
1833 object instances created for this class, not existing instances.
1835 =item B<< $metaclass->attribute_metaclass >>
1837 Returns the class name of the attribute metaclass for this class. By
1838 default, this is L<Class::MOP::Attribute>.
1842 =head2 Class Immutability
1844 Making a class immutable "freezes" the class definition. You can no
1845 longer call methods which alter the class, such as adding or removing
1846 methods or attributes.
1848 Making a class immutable lets us optimize the class by inlining some
1849 methods, and also allows us to optimize some methods on the metaclass
1852 After immutabilization, the metaclass object will cache most informational
1853 methods that returns information about methods or attributes. Methods which
1854 would alter the class, such as C<add_attribute> and C<add_method>, will
1855 throw an error on an immutable metaclass object.
1857 The immutabilization system in L<Moose> takes much greater advantage
1858 of the inlining features than Class::MOP itself does.
1862 =item B<< $metaclass->make_immutable(%options) >>
1864 This method will create an immutable transformer and use it to make
1865 the class and its metaclass object immutable.
1867 This method accepts the following options:
1871 =item * inline_accessors
1873 =item * inline_constructor
1875 =item * inline_destructor
1877 These are all booleans indicating whether the specified method(s)
1880 By default, accessors and the constructor are inlined, but not the
1883 =item * immutable_trait
1885 The name of a class which will be used as a parent class for the
1886 metaclass object being made immutable. This "trait" implements the
1887 post-immutability functionality of the metaclass (but not the
1888 transformation itself).
1890 This defaults to L<Class::MOP::Class::Immutable::Trait>.
1892 =item * constructor_name
1894 This is the constructor method name. This defaults to "new".
1896 =item * constructor_class
1898 The name of the method metaclass for constructors. It will be used to
1899 generate the inlined constructor. This defaults to
1900 "Class::MOP::Method::Constructor".
1902 =item * replace_constructor
1904 This is a boolean indicating whether an existing constructor should be
1905 replaced when inlining a constructor. This defaults to false.
1907 =item * destructor_class
1909 The name of the method metaclass for destructors. It will be used to
1910 generate the inlined destructor. This defaults to
1911 "Class::MOP::Method::Denstructor".
1913 =item * replace_destructor
1915 This is a boolean indicating whether an existing destructor should be
1916 replaced when inlining a destructor. This defaults to false.
1920 =item B<< $metaclass->immutable_options >>
1922 Returns a hash of the options used when making the class immutable, including
1923 both defaults and anything supplied by the user in the call to C<<
1924 $metaclass->make_immutable >>. This is useful if you need to temporarily make
1925 a class mutable and then restore immutability as it was before.
1927 =item B<< $metaclass->make_mutable >>
1929 Calling this method reverse the immutabilization transformation.
1933 =head2 Method Modifiers
1935 Method modifiers are hooks which allow a method to be wrapped with
1936 I<before>, I<after> and I<around> method modifiers. Every time a
1937 method is called, its modifiers are also called.
1939 A class can modify its own methods, as well as methods defined in
1942 =head3 How method modifiers work?
1944 Method modifiers work by wrapping the original method and then
1945 replacing it in the class's symbol table. The wrappers will handle
1946 calling all the modifiers in the appropriate order and preserving the
1947 calling context for the original method.
1949 The return values of C<before> and C<after> modifiers are
1950 ignored. This is because their purpose is B<not> to filter the input
1951 and output of the primary method (this is done with an I<around>
1954 This may seem like an odd restriction to some, but doing this allows
1955 for simple code to be added at the beginning or end of a method call
1956 without altering the function of the wrapped method or placing any
1957 extra responsibility on the code of the modifier.
1959 Of course if you have more complex needs, you can use the C<around>
1960 modifier which allows you to change both the parameters passed to the
1961 wrapped method, as well as its return value.
1963 Before and around modifiers are called in last-defined-first-called
1964 order, while after modifiers are called in first-defined-first-called
1965 order. So the call tree might looks something like this:
1977 =head3 What is the performance impact?
1979 Of course there is a performance cost associated with method
1980 modifiers, but we have made every effort to make that cost directly
1981 proportional to the number of modifier features you use.
1983 The wrapping method does its best to B<only> do as much work as it
1984 absolutely needs to. In order to do this we have moved some of the
1985 performance costs to set-up time, where they are easier to amortize.
1987 All this said, our benchmarks have indicated the following:
1989 simple wrapper with no modifiers 100% slower
1990 simple wrapper with simple before modifier 400% slower
1991 simple wrapper with simple after modifier 450% slower
1992 simple wrapper with simple around modifier 500-550% slower
1993 simple wrapper with all 3 modifiers 1100% slower
1995 These numbers may seem daunting, but you must remember, every feature
1996 comes with some cost. To put things in perspective, just doing a
1997 simple C<AUTOLOAD> which does nothing but extract the name of the
1998 method called and return it costs about 400% over a normal method
2003 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
2005 This wraps the specified method with the supplied subroutine
2006 reference. The modifier will be called as a method itself, and will
2007 receive the same arguments as are passed to the method.
2009 When the modifier exits, the wrapped method will be called.
2011 The return value of the modifier will be ignored.
2013 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
2015 This wraps the specified method with the supplied subroutine
2016 reference. The modifier will be called as a method itself, and will
2017 receive the same arguments as are passed to the method.
2019 When the wrapped methods exits, the modifier will be called.
2021 The return value of the modifier will be ignored.
2023 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
2025 This wraps the specified method with the supplied subroutine
2028 The first argument passed to the modifier will be a subroutine
2029 reference to the wrapped method. The second argument is the object,
2030 and after that come any arguments passed when the method is called.
2032 The around modifier can choose to call the original method, as well as
2033 what arguments to pass if it does so.
2035 The return value of the modifier is what will be seen by the caller.
2039 =head2 Introspection
2043 =item B<< Class::MOP::Class->meta >>
2045 This will return a L<Class::MOP::Class> instance for this class.
2047 It should also be noted that L<Class::MOP> will actually bootstrap
2048 this module by installing a number of attribute meta-objects into its
2055 Stevan Little E<lt>stevan@iinteractive.comE<gt>
2057 =head1 COPYRIGHT AND LICENSE
2059 Copyright 2006-2010 by Infinity Interactive, Inc.
2061 L<http://www.iinteractive.com>
2063 This library is free software; you can redistribute it and/or modify
2064 it under the same terms as Perl itself.