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('@ISA');
831 # on 5.8 and below, we need to call
832 # a method to get Perl to detect
833 # a cycle in the class hierarchy
834 my $class = $self->name;
838 # we need to check the metaclass
839 # compatibility here so that we can
840 # be sure that the superclass is
841 # not potentially creating an issues
842 # we don't know about
844 $self->_check_metaclass_compatibility();
845 $self->_superclasses_updated();
851 sub _superclasses_updated {
853 $self->update_meta_instance_dependencies();
854 # keep strong references to all our parents, so they don't disappear if
855 # they are anon classes and don't have any direct instances
856 $self->_superclass_metas(
857 map { Class::MOP::class_of($_) } $self->superclasses
861 sub _superclass_metas {
863 $self->{_superclass_metas} = [@_];
868 my $super_class = $self->name;
870 return @{ $super_class->mro::get_isarev() };
873 sub direct_subclasses {
875 my $super_class = $self->name;
880 } Class::MOP::Class->initialize($_)->superclasses
885 return @{ mro::get_linear_isa( (shift)->name ) };
888 sub class_precedence_list {
890 my $name = $self->name;
892 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
894 # We need to check for circular inheritance here
895 # if we are are not on 5.10, cause 5.8 detects it
896 # late. This will do nothing if all is well, and
897 # blow up otherwise. Yes, it's an ugly hack, better
898 # suggestions are welcome.
900 ($name || return)->isa('This is a test for circular inheritance')
903 # if our mro is c3, we can
904 # just grab the linear_isa
905 if (mro::get_mro($name) eq 'c3') {
906 return @{ mro::get_linear_isa($name) }
910 # we can't grab the linear_isa for dfs
911 # since it has all the duplicates
916 Class::MOP::Class->initialize($_)->class_precedence_list()
917 } $self->superclasses()
925 my $fetch_and_prepare_method = sub {
926 my ($self, $method_name) = @_;
927 my $wrapped_metaclass = $self->wrapped_method_metaclass;
929 my $method = $self->get_method($method_name);
930 # if we dont have local ...
932 # try to find the next method
933 $method = $self->find_next_method_by_name($method_name);
934 # die if it does not exist
936 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
937 # and now make sure to wrap it
938 # even if it is already wrapped
939 # because we need a new sub ref
940 $method = $wrapped_metaclass->wrap($method,
941 package_name => $self->name,
942 name => $method_name,
946 # now make sure we wrap it properly
947 $method = $wrapped_metaclass->wrap($method,
948 package_name => $self->name,
949 name => $method_name,
950 ) unless $method->isa($wrapped_metaclass);
952 $self->add_method($method_name => $method);
956 sub add_before_method_modifier {
957 my ($self, $method_name, $method_modifier) = @_;
958 (defined $method_name && length $method_name)
959 || confess "You must pass in a method name";
960 my $method = $fetch_and_prepare_method->($self, $method_name);
961 $method->add_before_modifier(
962 subname(':before' => $method_modifier)
966 sub add_after_method_modifier {
967 my ($self, $method_name, $method_modifier) = @_;
968 (defined $method_name && length $method_name)
969 || confess "You must pass in a method name";
970 my $method = $fetch_and_prepare_method->($self, $method_name);
971 $method->add_after_modifier(
972 subname(':after' => $method_modifier)
976 sub add_around_method_modifier {
977 my ($self, $method_name, $method_modifier) = @_;
978 (defined $method_name && length $method_name)
979 || confess "You must pass in a method name";
980 my $method = $fetch_and_prepare_method->($self, $method_name);
981 $method->add_around_modifier(
982 subname(':around' => $method_modifier)
987 # the methods above used to be named like this:
988 # ${pkg}::${method}:(before|after|around)
989 # but this proved problematic when using one modifier
990 # to wrap multiple methods (something which is likely
991 # to happen pretty regularly IMO). So instead of naming
992 # it like this, I have chosen to just name them purely
993 # with their modifier names, like so:
994 # :(before|after|around)
995 # The fact is that in a stack trace, it will be fairly
996 # evident from the context what method they are attached
997 # to, and so don't need the fully qualified name.
1000 sub find_method_by_name {
1001 my ($self, $method_name) = @_;
1002 (defined $method_name && length $method_name)
1003 || confess "You must define a method name to find";
1004 foreach my $class ($self->linearized_isa) {
1005 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1006 return $method if defined $method;
1011 sub get_all_methods {
1015 for my $class ( reverse $self->linearized_isa ) {
1016 my $meta = Class::MOP::Class->initialize($class);
1018 $methods{ $_->name } = $_ for $meta->_get_local_methods;
1021 return values %methods;
1024 sub get_all_method_names {
1027 return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
1030 sub find_all_methods_by_name {
1031 my ($self, $method_name) = @_;
1032 (defined $method_name && length $method_name)
1033 || confess "You must define a method name to find";
1035 foreach my $class ($self->linearized_isa) {
1036 # fetch the meta-class ...
1037 my $meta = Class::MOP::Class->initialize($class);
1039 name => $method_name,
1041 code => $meta->get_method($method_name)
1042 } if $meta->has_method($method_name);
1047 sub find_next_method_by_name {
1048 my ($self, $method_name) = @_;
1049 (defined $method_name && length $method_name)
1050 || confess "You must define a method name to find";
1051 my @cpl = $self->linearized_isa;
1052 shift @cpl; # discard ourselves
1053 foreach my $class (@cpl) {
1054 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1055 return $method if defined $method;
1060 sub update_meta_instance_dependencies {
1063 if ( $self->{meta_instance_dependencies} ) {
1064 return $self->add_meta_instance_dependencies;
1068 sub add_meta_instance_dependencies {
1071 $self->remove_meta_instance_dependencies;
1073 my @attrs = $self->get_all_attributes();
1076 my @classes = grep { not $seen{ $_->name }++ }
1077 map { $_->associated_class } @attrs;
1079 foreach my $class (@classes) {
1080 $class->add_dependent_meta_instance($self);
1083 $self->{meta_instance_dependencies} = \@classes;
1086 sub remove_meta_instance_dependencies {
1089 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
1090 foreach my $class (@$classes) {
1091 $class->remove_dependent_meta_instance($self);
1101 sub add_dependent_meta_instance {
1102 my ( $self, $metaclass ) = @_;
1103 push @{ $self->{dependent_meta_instances} }, $metaclass;
1106 sub remove_dependent_meta_instance {
1107 my ( $self, $metaclass ) = @_;
1108 my $name = $metaclass->name;
1109 @$_ = grep { $_->name ne $name } @$_
1110 for $self->{dependent_meta_instances};
1113 sub invalidate_meta_instances {
1115 $_->invalidate_meta_instance()
1116 for $self, @{ $self->{dependent_meta_instances} };
1119 sub invalidate_meta_instance {
1121 undef $self->{_meta_instance};
1124 # check if we can reinitialize
1128 # if any local attr is defined
1129 return if $self->get_attribute_list;
1131 # or any non-declared methods
1132 for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
1133 return if $method->isa("Class::MOP::Method::Generated");
1134 # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
1142 sub is_mutable { 1 }
1143 sub is_immutable { 0 }
1145 sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
1147 sub _immutable_options {
1148 my ( $self, @args ) = @_;
1151 inline_accessors => 1,
1152 inline_constructor => 1,
1153 inline_destructor => 0,
1155 immutable_trait => $self->immutable_trait,
1156 constructor_name => $self->constructor_name,
1157 constructor_class => $self->constructor_class,
1158 destructor_class => $self->destructor_class,
1163 sub make_immutable {
1164 my ( $self, @args ) = @_;
1166 if ( $self->is_mutable ) {
1167 $self->_initialize_immutable( $self->_immutable_options(@args) );
1168 $self->_rebless_as_immutable(@args);
1179 if ( $self->is_immutable ) {
1180 my @args = $self->immutable_options;
1181 $self->_rebless_as_mutable();
1182 $self->_remove_inlined_code(@args);
1183 delete $self->{__immutable};
1191 sub _rebless_as_immutable {
1192 my ( $self, @args ) = @_;
1194 $self->{__immutable}{original_class} = ref $self;
1196 bless $self => $self->_immutable_metaclass(@args);
1199 sub _immutable_metaclass {
1200 my ( $self, %args ) = @_;
1202 if ( my $class = $args{immutable_metaclass} ) {
1206 my $trait = $args{immutable_trait} = $self->immutable_trait
1207 || confess "no immutable trait specified for $self";
1209 my $meta = $self->meta;
1210 my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
1214 if ( $meta_attr and $trait eq $meta_attr->default ) {
1215 # if the trait is the same as the default we try and pick a
1216 # predictable name for the immutable metaclass
1217 $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1220 $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1221 $trait, 'ForMetaClass', ref($self);
1225 if Class::MOP::is_class_loaded($class_name);
1227 # If the metaclass is a subclass of CMOP::Class which has had
1228 # metaclass roles applied (via Moose), then we want to make sure
1229 # that we preserve that anonymous class (see Fey::ORM for an
1230 # example of where this matters).
1231 my $meta_name = $meta->_real_ref_name;
1233 my $immutable_meta = $meta_name->create(
1235 superclasses => [ ref $self ],
1238 Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
1240 $immutable_meta->make_immutable(
1241 inline_constructor => 0,
1242 inline_accessors => 0,
1248 sub _remove_inlined_code {
1251 $self->remove_method( $_->name ) for $self->_inlined_methods;
1253 delete $self->{__immutable}{inlined_methods};
1256 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1258 sub _add_inlined_method {
1259 my ( $self, $method ) = @_;
1261 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1264 sub _initialize_immutable {
1265 my ( $self, %args ) = @_;
1267 $self->{__immutable}{options} = \%args;
1268 $self->_install_inlined_code(%args);
1271 sub _install_inlined_code {
1272 my ( $self, %args ) = @_;
1275 $self->_inline_accessors(%args) if $args{inline_accessors};
1276 $self->_inline_constructor(%args) if $args{inline_constructor};
1277 $self->_inline_destructor(%args) if $args{inline_destructor};
1280 sub _rebless_as_mutable {
1283 bless $self, $self->_get_mutable_metaclass_name;
1288 sub _inline_accessors {
1291 foreach my $attr_name ( $self->get_attribute_list ) {
1292 $self->get_attribute($attr_name)->install_accessors(1);
1296 sub _inline_constructor {
1297 my ( $self, %args ) = @_;
1299 my $name = $args{constructor_name};
1300 # A class may not even have a constructor, and that's okay.
1301 return unless defined $name;
1303 if ( $self->has_method($name) && !$args{replace_constructor} ) {
1304 my $class = $self->name;
1305 warn "Not inlining a constructor for $class since it defines"
1306 . " its own constructor.\n"
1307 . "If you are certain you don't need to inline your"
1308 . " constructor, specify inline_constructor => 0 in your"
1309 . " call to $class->meta->make_immutable\n";
1313 my $constructor_class = $args{constructor_class};
1315 Class::MOP::load_class($constructor_class);
1317 my $constructor = $constructor_class->new(
1321 package_name => $self->name,
1325 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1326 $self->add_method( $name => $constructor );
1327 $self->_add_inlined_method($constructor);
1331 sub _inline_destructor {
1332 my ( $self, %args ) = @_;
1334 ( exists $args{destructor_class} && defined $args{destructor_class} )
1335 || confess "The 'inline_destructor' option is present, but "
1336 . "no destructor class was specified";
1338 if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1339 my $class = $self->name;
1340 warn "Not inlining a destructor for $class since it defines"
1341 . " its own destructor.\n";
1345 my $destructor_class = $args{destructor_class};
1347 Class::MOP::load_class($destructor_class);
1349 return unless $destructor_class->is_needed($self);
1351 my $destructor = $destructor_class->new(
1354 package_name => $self->name,
1358 if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1359 $self->add_method( 'DESTROY' => $destructor );
1360 $self->_add_inlined_method($destructor);
1372 Class::MOP::Class - Class Meta Object
1376 # assuming that class Foo
1377 # has been defined, you can
1379 # use this for introspection ...
1381 # add a method to Foo ...
1382 Foo->meta->add_method( 'bar' => sub {...} )
1384 # get a list of all the classes searched
1385 # the method dispatcher in the correct order
1386 Foo->meta->class_precedence_list()
1388 # remove a method from Foo
1389 Foo->meta->remove_method('bar');
1391 # or use this to actually create classes ...
1393 Class::MOP::Class->create(
1396 superclasses => ['Foo'],
1398 Class::MOP::Attribute->new('$bar'),
1399 Class::MOP::Attribute->new('$baz'),
1402 calculate_bar => sub {...},
1403 construct_baz => sub {...}
1410 The Class Protocol is the largest and most complex part of the
1411 Class::MOP meta-object protocol. It controls the introspection and
1412 manipulation of Perl 5 classes, and it can create them as well. The
1413 best way to understand what this module can do is to read the
1414 documentation for each of its methods.
1418 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1422 =head2 Class construction
1424 These methods all create new C<Class::MOP::Class> objects. These
1425 objects can represent existing classes or they can be used to create
1426 new classes from scratch.
1428 The metaclass object for a given class is a singleton. If you attempt
1429 to create a metaclass for the same class twice, you will just get the
1434 =item B<< Class::MOP::Class->create($package_name, %options) >>
1436 This method creates a new C<Class::MOP::Class> object with the given
1437 package name. It accepts a number of options:
1443 An optional version number for the newly created package.
1447 An optional authority for the newly created package.
1449 =item * superclasses
1451 An optional array reference of superclass names.
1455 An optional hash reference of methods for the class. The keys of the
1456 hash reference are method names and values are subroutine references.
1460 An optional array reference of L<Class::MOP::Attribute> objects.
1464 Specifies the name to install the C<meta> method for this class under.
1465 If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
1466 given, no meta method will be installed.
1470 If true, the metaclass that is stored in the global cache will be a
1473 Classes created in this way are destroyed once the metaclass they are
1474 attached to goes out of scope, and will be removed from Perl's internal
1477 All instances of a class with a weakened metaclass keep a special
1478 reference to the metaclass object, which prevents the metaclass from
1479 going out of scope while any instances exist.
1481 This only works if the instance is based on a hash reference, however.
1485 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1487 This method works just like C<< Class::MOP::Class->create >> but it
1488 creates an "anonymous" class. In fact, the class does have a name, but
1489 that name is a unique name generated internally by this module.
1491 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1492 parameters that C<create> accepts.
1494 Anonymous classes default to C<< weaken => 1 >>, although this can be
1497 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1499 This method will initialize a C<Class::MOP::Class> object for the
1500 named package. Unlike C<create>, this method I<will not> create a new
1503 The purpose of this method is to retrieve a C<Class::MOP::Class>
1504 object for introspecting an existing class.
1506 If an existing C<Class::MOP::Class> object exists for the named
1507 package, it will be returned, and any options provided will be
1510 If the object does not yet exist, it will be created.
1512 The valid options that can be passed to this method are
1513 C<attribute_metaclass>, C<method_metaclass>,
1514 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1515 optional, and default to the appropriate class in the C<Class::MOP>
1520 =head2 Object instance construction and cloning
1522 These methods are all related to creating and/or cloning object
1527 =item B<< $metaclass->clone_object($instance, %params) >>
1529 This method clones an existing object instance. Any parameters you
1530 provide are will override existing attribute values in the object.
1532 This is a convenience method for cloning an object instance, then
1533 blessing it into the appropriate package.
1535 You could implement a clone method in your class, using this method:
1538 my ($self, %params) = @_;
1539 $self->meta->clone_object($self, %params);
1542 =item B<< $metaclass->rebless_instance($instance, %params) >>
1544 This method changes the class of C<$instance> to the metaclass's class.
1546 You can only rebless an instance into a subclass of its current
1547 class. If you pass any additional parameters, these will be treated
1548 like constructor parameters and used to initialize the object's
1549 attributes. Any existing attributes that are already set will be
1552 Before reblessing the instance, this method will call
1553 C<rebless_instance_away> on the instance's current metaclass. This method
1554 will be passed the instance, the new metaclass, and any parameters
1555 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1556 does nothing; it is merely a hook.
1558 =item B<< $metaclass->rebless_instance_back($instance) >>
1560 Does the same thing as C<rebless_instance>, except that you can only
1561 rebless an instance into one of its superclasses. Any attributes that
1562 do not exist in the superclass will be deinitialized.
1564 This is a much more dangerous operation than C<rebless_instance>,
1565 especially when multiple inheritance is involved, so use this carefully!
1567 =item B<< $metaclass->new_object(%params) >>
1569 This method is used to create a new object of the metaclass's
1570 class. Any parameters you provide are used to initialize the
1571 instance's attributes. A special C<__INSTANCE__> key can be passed to
1572 provide an already generated instance, rather than having Class::MOP
1573 generate it for you. This is mostly useful for using Class::MOP with
1574 foreign classes which generate instances using their own constructors.
1576 =item B<< $metaclass->instance_metaclass >>
1578 Returns the class name of the instance metaclass. See
1579 L<Class::MOP::Instance> for more information on the instance
1582 =item B<< $metaclass->get_meta_instance >>
1584 Returns an instance of the C<instance_metaclass> to be used in the
1585 construction of a new instance of the class.
1587 =item B<< $metaclass->inline_create_instance($class_var) >>
1589 =item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >>
1591 These methods takes variable names, and use them to create an inline snippet
1592 of code that will create a new instance of the class.
1596 =head2 Informational predicates
1598 These are a few predicate methods for asking information about the
1603 =item B<< $metaclass->is_anon_class >>
1605 This returns true if the class was created by calling C<<
1606 Class::MOP::Class->create_anon_class >>.
1608 =item B<< $metaclass->is_mutable >>
1610 This returns true if the class is still mutable.
1612 =item B<< $metaclass->is_immutable >>
1614 This returns true if the class has been made immutable.
1616 =item B<< $metaclass->is_pristine >>
1618 A class is I<not> pristine if it has non-inherited attributes or if it
1619 has any generated methods.
1623 =head2 Inheritance Relationships
1627 =item B<< $metaclass->superclasses(@superclasses) >>
1629 This is a read-write accessor which represents the superclass
1630 relationships of the metaclass's class.
1632 This is basically sugar around getting and setting C<@ISA>.
1634 =item B<< $metaclass->class_precedence_list >>
1636 This returns a list of all of the class's ancestor classes. The
1637 classes are returned in method dispatch order.
1639 =item B<< $metaclass->linearized_isa >>
1641 This returns a list based on C<class_precedence_list> but with all
1644 =item B<< $metaclass->subclasses >>
1646 This returns a list of all subclasses for this class, even indirect
1649 =item B<< $metaclass->direct_subclasses >>
1651 This returns a list of immediate subclasses for this class, which does not
1652 include indirect subclasses.
1656 =head2 Method introspection and creation
1658 These methods allow you to introspect a class's methods, as well as
1659 add, remove, or change methods.
1661 Determining what is truly a method in a Perl 5 class requires some
1662 heuristics (aka guessing).
1664 Methods defined outside the package with a fully qualified name (C<sub
1665 Package::name { ... }>) will be included. Similarly, methods named
1666 with a fully qualified name using L<Sub::Name> are also included.
1668 However, we attempt to ignore imported functions.
1670 Ultimately, we are using heuristics to determine what truly is a
1671 method in a class, and these heuristics may get the wrong answer in
1672 some edge cases. However, for most "normal" cases the heuristics work
1677 =item B<< $metaclass->get_method($method_name) >>
1679 This will return a L<Class::MOP::Method> for the specified
1680 C<$method_name>. If the class does not have the specified method, it
1683 =item B<< $metaclass->has_method($method_name) >>
1685 Returns a boolean indicating whether or not the class defines the
1686 named method. It does not include methods inherited from parent
1689 =item B<< $metaclass->get_method_list >>
1691 This will return a list of method I<names> for all methods defined in
1694 =item B<< $metaclass->add_method($method_name, $method) >>
1696 This method takes a method name and a subroutine reference, and adds
1697 the method to the class.
1699 The subroutine reference can be a L<Class::MOP::Method>, and you are
1700 strongly encouraged to pass a meta method object instead of a code
1701 reference. If you do so, that object gets stored as part of the
1702 class's method map directly. If not, the meta information will have to
1703 be recreated later, and may be incorrect.
1705 If you provide a method object, this method will clone that object if
1706 the object's package name does not match the class name. This lets us
1707 track the original source of any methods added from other classes
1708 (notably Moose roles).
1710 =item B<< $metaclass->remove_method($method_name) >>
1712 Remove the named method from the class. This method returns the
1713 L<Class::MOP::Method> object for the method.
1715 =item B<< $metaclass->method_metaclass >>
1717 Returns the class name of the method metaclass, see
1718 L<Class::MOP::Method> for more information on the method metaclass.
1720 =item B<< $metaclass->wrapped_method_metaclass >>
1722 Returns the class name of the wrapped method metaclass, see
1723 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1726 =item B<< $metaclass->get_all_methods >>
1728 This will traverse the inheritance hierarchy and return a list of all
1729 the L<Class::MOP::Method> objects for this class and its parents.
1731 =item B<< $metaclass->find_method_by_name($method_name) >>
1733 This will return a L<Class::MOP::Method> for the specified
1734 C<$method_name>. If the class does not have the specified method, it
1737 Unlike C<get_method>, this method I<will> look for the named method in
1740 =item B<< $metaclass->get_all_method_names >>
1742 This will return a list of method I<names> for all of this class's
1743 methods, including inherited methods.
1745 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1747 This method looks for the named method in the class and all of its
1748 parents. It returns every matching method it finds in the inheritance
1749 tree, so it returns a list of methods.
1751 Each method is returned as a hash reference with three keys. The keys
1752 are C<name>, C<class>, and C<code>. The C<code> key has a
1753 L<Class::MOP::Method> object as its value.
1755 The list of methods is distinct.
1757 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1759 This method returns the first method in any superclass matching the
1760 given name. It is effectively the method that C<SUPER::$method_name>
1765 =head2 Attribute introspection and creation
1767 Because Perl 5 does not have a core concept of attributes in classes,
1768 we can only return information about attributes which have been added
1769 via this class's methods. We cannot discover information about
1770 attributes which are defined in terms of "regular" Perl 5 methods.
1774 =item B<< $metaclass->get_attribute($attribute_name) >>
1776 This will return a L<Class::MOP::Attribute> for the specified
1777 C<$attribute_name>. If the class does not have the specified
1778 attribute, it returns C<undef>.
1780 NOTE that get_attribute does not search superclasses, for that you
1781 need to use C<find_attribute_by_name>.
1783 =item B<< $metaclass->has_attribute($attribute_name) >>
1785 Returns a boolean indicating whether or not the class defines the
1786 named attribute. It does not include attributes inherited from parent
1789 =item B<< $metaclass->get_attribute_list >>
1791 This will return a list of attributes I<names> for all attributes
1792 defined in this class. Note that this operates on the current class
1793 only, it does not traverse the inheritance hierarchy.
1795 =item B<< $metaclass->get_all_attributes >>
1797 This will traverse the inheritance hierarchy and return a list of all
1798 the L<Class::MOP::Attribute> objects for this class and its parents.
1800 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1802 This will return a L<Class::MOP::Attribute> for the specified
1803 C<$attribute_name>. If the class does not have the specified
1804 attribute, it returns C<undef>.
1806 Unlike C<get_attribute>, this attribute I<will> look for the named
1807 attribute in superclasses.
1809 =item B<< $metaclass->add_attribute(...) >>
1811 This method accepts either an existing L<Class::MOP::Attribute>
1812 object or parameters suitable for passing to that class's C<new>
1815 The attribute provided will be added to the class.
1817 Any accessor methods defined by the attribute will be added to the
1818 class when the attribute is added.
1820 If an attribute of the same name already exists, the old attribute
1821 will be removed first.
1823 =item B<< $metaclass->remove_attribute($attribute_name) >>
1825 This will remove the named attribute from the class, and
1826 L<Class::MOP::Attribute> object.
1828 Removing an attribute also removes any accessor methods defined by the
1831 However, note that removing an attribute will only affect I<future>
1832 object instances created for this class, not existing instances.
1834 =item B<< $metaclass->attribute_metaclass >>
1836 Returns the class name of the attribute metaclass for this class. By
1837 default, this is L<Class::MOP::Attribute>.
1841 =head2 Class Immutability
1843 Making a class immutable "freezes" the class definition. You can no
1844 longer call methods which alter the class, such as adding or removing
1845 methods or attributes.
1847 Making a class immutable lets us optimize the class by inlining some
1848 methods, and also allows us to optimize some methods on the metaclass
1851 After immutabilization, the metaclass object will cache most informational
1852 methods that returns information about methods or attributes. Methods which
1853 would alter the class, such as C<add_attribute> and C<add_method>, will
1854 throw an error on an immutable metaclass object.
1856 The immutabilization system in L<Moose> takes much greater advantage
1857 of the inlining features than Class::MOP itself does.
1861 =item B<< $metaclass->make_immutable(%options) >>
1863 This method will create an immutable transformer and use it to make
1864 the class and its metaclass object immutable.
1866 This method accepts the following options:
1870 =item * inline_accessors
1872 =item * inline_constructor
1874 =item * inline_destructor
1876 These are all booleans indicating whether the specified method(s)
1879 By default, accessors and the constructor are inlined, but not the
1882 =item * immutable_trait
1884 The name of a class which will be used as a parent class for the
1885 metaclass object being made immutable. This "trait" implements the
1886 post-immutability functionality of the metaclass (but not the
1887 transformation itself).
1889 This defaults to L<Class::MOP::Class::Immutable::Trait>.
1891 =item * constructor_name
1893 This is the constructor method name. This defaults to "new".
1895 =item * constructor_class
1897 The name of the method metaclass for constructors. It will be used to
1898 generate the inlined constructor. This defaults to
1899 "Class::MOP::Method::Constructor".
1901 =item * replace_constructor
1903 This is a boolean indicating whether an existing constructor should be
1904 replaced when inlining a constructor. This defaults to false.
1906 =item * destructor_class
1908 The name of the method metaclass for destructors. It will be used to
1909 generate the inlined destructor. This defaults to
1910 "Class::MOP::Method::Denstructor".
1912 =item * replace_destructor
1914 This is a boolean indicating whether an existing destructor should be
1915 replaced when inlining a destructor. This defaults to false.
1919 =item B<< $metaclass->immutable_options >>
1921 Returns a hash of the options used when making the class immutable, including
1922 both defaults and anything supplied by the user in the call to C<<
1923 $metaclass->make_immutable >>. This is useful if you need to temporarily make
1924 a class mutable and then restore immutability as it was before.
1926 =item B<< $metaclass->make_mutable >>
1928 Calling this method reverse the immutabilization transformation.
1932 =head2 Method Modifiers
1934 Method modifiers are hooks which allow a method to be wrapped with
1935 I<before>, I<after> and I<around> method modifiers. Every time a
1936 method is called, its modifiers are also called.
1938 A class can modify its own methods, as well as methods defined in
1941 =head3 How method modifiers work?
1943 Method modifiers work by wrapping the original method and then
1944 replacing it in the class's symbol table. The wrappers will handle
1945 calling all the modifiers in the appropriate order and preserving the
1946 calling context for the original method.
1948 The return values of C<before> and C<after> modifiers are
1949 ignored. This is because their purpose is B<not> to filter the input
1950 and output of the primary method (this is done with an I<around>
1953 This may seem like an odd restriction to some, but doing this allows
1954 for simple code to be added at the beginning or end of a method call
1955 without altering the function of the wrapped method or placing any
1956 extra responsibility on the code of the modifier.
1958 Of course if you have more complex needs, you can use the C<around>
1959 modifier which allows you to change both the parameters passed to the
1960 wrapped method, as well as its return value.
1962 Before and around modifiers are called in last-defined-first-called
1963 order, while after modifiers are called in first-defined-first-called
1964 order. So the call tree might looks something like this:
1976 =head3 What is the performance impact?
1978 Of course there is a performance cost associated with method
1979 modifiers, but we have made every effort to make that cost directly
1980 proportional to the number of modifier features you use.
1982 The wrapping method does its best to B<only> do as much work as it
1983 absolutely needs to. In order to do this we have moved some of the
1984 performance costs to set-up time, where they are easier to amortize.
1986 All this said, our benchmarks have indicated the following:
1988 simple wrapper with no modifiers 100% slower
1989 simple wrapper with simple before modifier 400% slower
1990 simple wrapper with simple after modifier 450% slower
1991 simple wrapper with simple around modifier 500-550% slower
1992 simple wrapper with all 3 modifiers 1100% slower
1994 These numbers may seem daunting, but you must remember, every feature
1995 comes with some cost. To put things in perspective, just doing a
1996 simple C<AUTOLOAD> which does nothing but extract the name of the
1997 method called and return it costs about 400% over a normal method
2002 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
2004 This wraps the specified method with the supplied subroutine
2005 reference. The modifier will be called as a method itself, and will
2006 receive the same arguments as are passed to the method.
2008 When the modifier exits, the wrapped method will be called.
2010 The return value of the modifier will be ignored.
2012 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
2014 This wraps the specified method with the supplied subroutine
2015 reference. The modifier will be called as a method itself, and will
2016 receive the same arguments as are passed to the method.
2018 When the wrapped methods exits, the modifier will be called.
2020 The return value of the modifier will be ignored.
2022 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
2024 This wraps the specified method with the supplied subroutine
2027 The first argument passed to the modifier will be a subroutine
2028 reference to the wrapped method. The second argument is the object,
2029 and after that come any arguments passed when the method is called.
2031 The around modifier can choose to call the original method, as well as
2032 what arguments to pass if it does so.
2034 The return value of the modifier is what will be seen by the caller.
2038 =head2 Introspection
2042 =item B<< Class::MOP::Class->meta >>
2044 This will return a L<Class::MOP::Class> instance for this class.
2046 It should also be noted that L<Class::MOP> will actually bootstrap
2047 this module by installing a number of attribute meta-objects into its
2054 Stevan Little E<lt>stevan@iinteractive.comE<gt>
2056 =head1 COPYRIGHT AND LICENSE
2058 Copyright 2006-2010 by Infinity Interactive, Inc.
2060 L<http://www.iinteractive.com>
2062 This library is free software; you can redistribute it and/or modify
2063 it under the same terms as Perl itself.