2 package Class::MOP::Class;
7 use Class::MOP::Immutable;
8 use Class::MOP::Instance;
9 use Class::MOP::Method::Wrapped;
12 use Scalar::Util 'blessed', 'reftype', 'weaken';
13 use Sub::Name 'subname';
15 our $VERSION = '0.31';
16 our $AUTHORITY = 'cpan:STEVAN';
18 use base 'Class::MOP::Module';
24 my $package_name = shift;
25 (defined $package_name && $package_name && !blessed($package_name))
26 || confess "You must pass a package name and it cannot be blessed";
27 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
30 $class->construct_class_instance('package' => $package_name, @_);
35 my $package_name = shift;
36 (defined $package_name && $package_name && !blessed($package_name))
37 || confess "You must pass a package name and it cannot be blessed";
38 Class::MOP::remove_metaclass_by_name($package_name);
39 $class->construct_class_instance('package' => $package_name, @_);
42 # NOTE: (meta-circularity)
43 # this is a special form of &construct_instance
44 # (see below), which is used to construct class
45 # meta-object instances for any Class::MOP::*
46 # class. All other classes will use the more
47 # normal &construct_instance.
48 sub construct_class_instance {
51 my $package_name = $options{'package'};
52 (defined $package_name && $package_name)
53 || confess "You must pass a package name";
55 # return the metaclass if we have it cached,
56 # and it is still defined (it has not been
57 # reaped by DESTROY yet, which can happen
58 # annoyingly enough during global destruction)
60 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
65 # we need to deal with the possibility
66 # of class immutability here, and then
67 # get the name of the class appropriately
68 $class = (blessed($class)
69 ? ($class->is_immutable
70 ? $class->get_mutable_metaclass_name()
74 # now create the metaclass
76 if ($class eq 'Class::MOP::Class') {
79 # inherited from Class::MOP::Package
80 '$!package' => $package_name,
83 # since the following attributes will
84 # actually be loaded from the symbol
85 # table, and actually bypass the instance
86 # entirely, we can just leave these things
87 # listed here for reference, because they
88 # should not actually have a value associated
90 '%!namespace' => \undef,
91 # inherited from Class::MOP::Module
92 '$!version' => \undef,
93 '$!authority' => \undef,
94 # defined in Class::MOP::Class
95 '@!superclasses' => \undef,
99 '$!attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute',
100 '$!method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method',
101 '$!instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance',
103 ## uber-private variables
105 # this starts out as undef so that
106 # we can tell the first time the
107 # methods are fetched
109 '$!_package_cache_flag' => undef,
114 # it is safe to use meta here because
115 # class will always be a subclass of
116 # Class::MOP::Class, which defines meta
117 $meta = $class->meta->construct_instance(%options)
120 # and check the metaclass compatibility
121 $meta->check_metaclass_compatability();
123 Class::MOP::store_metaclass_by_name($package_name, $meta);
126 # we need to weaken any anon classes
127 # so that they can call DESTROY properly
128 Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class;
133 sub reset_package_cache_flag { (shift)->{'$!_package_cache_flag'} = undef }
134 sub update_package_cache_flag {
137 # we can manually update the cache number
138 # since we are actually adding the method
139 # to our cache as well. This avoids us
140 # having to regenerate the method_map.
142 $self->{'$!_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
145 sub check_metaclass_compatability {
148 # this is always okay ...
149 return if blessed($self) eq 'Class::MOP::Class' &&
150 $self->instance_metaclass eq 'Class::MOP::Instance';
152 my @class_list = $self->linearized_isa;
153 shift @class_list; # shift off $self->name
155 foreach my $class_name (@class_list) {
156 my $meta = Class::MOP::get_metaclass_by_name($class_name) || next;
159 # we need to deal with the possibility
160 # of class immutability here, and then
161 # get the name of the class appropriately
162 my $meta_type = ($meta->is_immutable
163 ? $meta->get_mutable_metaclass_name()
166 ($self->isa($meta_type))
167 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
168 " is not compatible with the " .
169 $class_name . "->meta => (" . ($meta_type) . ")";
171 # we also need to check that instance metaclasses
172 # are compatabile in the same the class.
173 ($self->instance_metaclass->isa($meta->instance_metaclass))
174 || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" .
175 " is not compatible with the " .
176 $class_name . "->meta => (" . ($meta->instance_metaclass) . ")";
184 # this should be sufficient, if you have a
185 # use case where it is not, write a test and
187 my $ANON_CLASS_SERIAL = 0;
190 # we need a sufficiently annoying prefix
191 # this should suffice for now, this is
192 # used in a couple of places below, so
193 # need to put it up here for now.
194 my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
198 no warnings 'uninitialized';
199 $self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0;
202 sub create_anon_class {
203 my ($class, %options) = @_;
204 my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
205 return $class->create($package_name, %options);
209 # this will only get called for
210 # anon-classes, all other calls
211 # are assumed to occur during
212 # global destruction and so don't
213 # really need to be handled explicitly
216 no warnings 'uninitialized';
217 return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
218 my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
220 foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
221 delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
223 delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
228 # creating classes with MOP ...
232 my $package_name = shift;
234 (defined $package_name && $package_name)
235 || confess "You must pass a package name";
238 || confess "You much pass all parameters as name => value pairs " .
239 "(I found an uneven number of params in \@_)";
243 (ref $options{superclasses} eq 'ARRAY')
244 || confess "You must pass an ARRAY ref of superclasses"
245 if exists $options{superclasses};
247 (ref $options{attributes} eq 'ARRAY')
248 || confess "You must pass an ARRAY ref of attributes"
249 if exists $options{attributes};
251 (ref $options{methods} eq 'HASH')
252 || confess "You must pass an HASH ref of methods"
253 if exists $options{methods};
255 my $code = "package $package_name;";
256 $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
257 if exists $options{version};
258 $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
259 if exists $options{authority};
262 confess "creation of $package_name failed : $@" if $@;
264 my $meta = $class->initialize($package_name);
266 $meta->add_method('meta' => sub {
267 $class->initialize(blessed($_[0]) || $_[0]);
270 $meta->superclasses(@{$options{superclasses}})
271 if exists $options{superclasses};
273 # process attributes first, so that they can
274 # install accessors, but locally defined methods
275 # can then overwrite them. It is maybe a little odd, but
276 # I think this should be the order of things.
277 if (exists $options{attributes}) {
278 foreach my $attr (@{$options{attributes}}) {
279 $meta->add_attribute($attr);
282 if (exists $options{methods}) {
283 foreach my $method_name (keys %{$options{methods}}) {
284 $meta->add_method($method_name, $options{methods}->{$method_name});
293 # all these attribute readers will be bootstrapped
294 # away in the Class::MOP bootstrap section
296 sub get_attribute_map { $_[0]->{'%!attributes'} }
297 sub attribute_metaclass { $_[0]->{'$!attribute_metaclass'} }
298 sub method_metaclass { $_[0]->{'$!method_metaclass'} }
299 sub instance_metaclass { $_[0]->{'$!instance_metaclass'} }
302 # this is a prime canidate for conversion to XS
306 if (defined $self->{'$!_package_cache_flag'} &&
307 $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name)) {
308 return $self->{'%!methods'};
311 my $map = $self->{'%!methods'};
313 my $class_name = $self->name;
314 my $method_metaclass = $self->method_metaclass;
316 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
317 my $code = $self->get_package_symbol('&' . $symbol);
319 next if exists $map->{$symbol} &&
320 defined $map->{$symbol} &&
321 $map->{$symbol}->body == $code;
323 my ($pkg, $name) = Class::MOP::get_code_info($code);
325 next if ($pkg || '') ne $class_name ||
326 (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
328 #warn "Checking $pkg against $class_name && $name against __ANON__";
330 $map->{$symbol} = $method_metaclass->wrap($code);
336 # Instance Construction & Cloning
341 # we need to protect the integrity of the
342 # Class::MOP::Class singletons here, so we
343 # delegate this to &construct_class_instance
344 # which will deal with the singletons
345 return $class->construct_class_instance(@_)
346 if $class->name->isa('Class::MOP::Class');
347 return $class->construct_instance(@_);
350 sub construct_instance {
351 my ($class, %params) = @_;
352 my $meta_instance = $class->get_meta_instance();
353 my $instance = $meta_instance->create_instance();
354 foreach my $attr ($class->compute_all_applicable_attributes()) {
355 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
358 # this will only work for a HASH instance type
359 if ($class->is_anon_class) {
360 (reftype($instance) eq 'HASH')
361 || confess "Currently only HASH based instances are supported with instance of anon-classes";
363 # At some point we should make this official
364 # as a reserved slot name, but right now I am
365 # going to keep it here.
366 # my $RESERVED_MOP_SLOT = '__MOP__';
367 $instance->{'__MOP__'} = $class;
372 sub get_meta_instance {
374 return $class->instance_metaclass->new(
376 $class->compute_all_applicable_attributes()
382 my $instance = shift;
383 (blessed($instance) && $instance->isa($class->name))
384 || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
386 # we need to protect the integrity of the
387 # Class::MOP::Class singletons here, they
388 # should not be cloned.
389 return $instance if $instance->isa('Class::MOP::Class');
390 $class->clone_instance($instance, @_);
394 my ($class, $instance, %params) = @_;
396 || confess "You can only clone instances, \$self is not a blessed instance";
397 my $meta_instance = $class->get_meta_instance();
398 my $clone = $meta_instance->clone_instance($instance);
399 foreach my $attr ($class->compute_all_applicable_attributes()) {
400 if ( defined( my $init_arg = $attr->init_arg ) ) {
401 if (exists $params{$init_arg}) {
402 $attr->set_value($clone, $params{$init_arg});
409 sub rebless_instance {
410 my ($self, $instance, %params) = @_;
413 if ($instance->can('meta')) {
414 ($instance->meta->isa('Class::MOP::Class'))
415 || confess 'Cannot rebless instance if ->meta is not an instance of Class::MOP::Class';
416 $old_metaclass = $instance->meta;
419 $old_metaclass = $self->initialize(blessed($instance));
422 my $meta_instance = $self->get_meta_instance();
424 $self->name->isa($old_metaclass->name)
425 || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't.";
428 $meta_instance->rebless_instance_structure($instance, $self);
430 foreach my $attr ( $self->compute_all_applicable_attributes ) {
431 if ( $attr->has_value($instance) ) {
432 if ( defined( my $init_arg = $attr->init_arg ) ) {
433 $params{$init_arg} = $attr->get_value($instance)
434 unless exists $params{$init_arg};
437 $attr->set_value($instance, $attr->get_value($instance));
442 foreach my $attr ($self->compute_all_applicable_attributes) {
443 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
455 @{$self->get_package_symbol('@ISA')} = @supers;
457 # we need to check the metaclass
458 # compatibility here so that we can
459 # be sure that the superclass is
460 # not potentially creating an issues
461 # we don't know about
462 $self->check_metaclass_compatability();
464 @{$self->get_package_symbol('@ISA')};
470 my $super_class = $self->name;
473 my $find_derived_classes;
474 $find_derived_classes = sub {
475 my ($outer_class) = @_;
477 my $symbol_table_hashref = do { no strict 'refs'; \%{"${outer_class}::"} };
480 for my $symbol ( keys %$symbol_table_hashref ) {
481 next SYMBOL if $symbol !~ /\A (\w+):: \z/x;
482 my $inner_class = $1;
484 next SYMBOL if $inner_class eq 'SUPER'; # skip '*::SUPER'
488 ? "${outer_class}::$inner_class"
491 if ( $class->isa($super_class) and $class ne $super_class ) {
492 push @derived_classes, $class;
495 next SYMBOL if $class eq 'main'; # skip 'main::*'
497 $find_derived_classes->($class);
501 my $root_class = q{};
502 $find_derived_classes->($root_class);
504 undef $find_derived_classes;
506 @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes;
508 return @derived_classes;
513 return @{ mro::get_linear_isa( (shift)->name ) };
516 sub class_precedence_list {
518 my $name = $self->name;
520 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
522 # We need to check for circular inheritance here
523 # if we are are not on 5.10, cause 5.8 detects it
524 # late. This will do nothing if all is well, and
525 # blow up otherwise. Yes, it's an ugly hack, better
526 # suggestions are welcome.
528 ($name || return)->isa('This is a test for circular inheritance')
531 # if our mro is c3, we can
532 # just grab the linear_isa
533 if (mro::get_mro($name) eq 'c3') {
534 return @{ mro::get_linear_isa($name) }
538 # we can't grab the linear_isa for dfs
539 # since it has all the duplicates
544 $self->initialize($_)->class_precedence_list()
545 } $self->superclasses()
553 my ($self, $method_name, $method) = @_;
554 (defined $method_name && $method_name)
555 || confess "You must define a method name";
558 if (blessed($method)) {
559 $body = $method->body;
563 ('CODE' eq (reftype($body) || ''))
564 || confess "Your code block must be a CODE reference";
565 $method = $self->method_metaclass->wrap($body);
567 $self->get_method_map->{$method_name} = $method;
569 my $full_method_name = ($self->name . '::' . $method_name);
570 $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body);
571 $self->update_package_cache_flag;
575 my $fetch_and_prepare_method = sub {
576 my ($self, $method_name) = @_;
578 my $method = $self->get_method($method_name);
579 # if we dont have local ...
581 # try to find the next method
582 $method = $self->find_next_method_by_name($method_name);
583 # die if it does not exist
585 || confess "The method '$method_name' is not found in the inheritance hierarchy for class " . $self->name;
586 # and now make sure to wrap it
587 # even if it is already wrapped
588 # because we need a new sub ref
589 $method = Class::MOP::Method::Wrapped->wrap($method);
592 # now make sure we wrap it properly
593 $method = Class::MOP::Method::Wrapped->wrap($method)
594 unless $method->isa('Class::MOP::Method::Wrapped');
596 $self->add_method($method_name => $method);
600 sub add_before_method_modifier {
601 my ($self, $method_name, $method_modifier) = @_;
602 (defined $method_name && $method_name)
603 || confess "You must pass in a method name";
604 my $method = $fetch_and_prepare_method->($self, $method_name);
605 $method->add_before_modifier(subname ':before' => $method_modifier);
608 sub add_after_method_modifier {
609 my ($self, $method_name, $method_modifier) = @_;
610 (defined $method_name && $method_name)
611 || confess "You must pass in a method name";
612 my $method = $fetch_and_prepare_method->($self, $method_name);
613 $method->add_after_modifier(subname ':after' => $method_modifier);
616 sub add_around_method_modifier {
617 my ($self, $method_name, $method_modifier) = @_;
618 (defined $method_name && $method_name)
619 || confess "You must pass in a method name";
620 my $method = $fetch_and_prepare_method->($self, $method_name);
621 $method->add_around_modifier(subname ':around' => $method_modifier);
625 # the methods above used to be named like this:
626 # ${pkg}::${method}:(before|after|around)
627 # but this proved problematic when using one modifier
628 # to wrap multiple methods (something which is likely
629 # to happen pretty regularly IMO). So instead of naming
630 # it like this, I have chosen to just name them purely
631 # with their modifier names, like so:
632 # :(before|after|around)
633 # The fact is that in a stack trace, it will be fairly
634 # evident from the context what method they are attached
635 # to, and so don't need the fully qualified name.
639 my ($self, $method_name, $method) = @_;
640 (defined $method_name && $method_name)
641 || confess "You must define a method name";
643 my $body = (blessed($method) ? $method->body : $method);
644 ('CODE' eq (reftype($body) || ''))
645 || confess "Your code block must be a CODE reference";
647 $self->add_package_symbol("&${method_name}" => $body);
648 $self->update_package_cache_flag;
652 my ($self, $method_name) = @_;
653 (defined $method_name && $method_name)
654 || confess "You must define a method name";
656 return 0 unless exists $self->get_method_map->{$method_name};
661 my ($self, $method_name) = @_;
662 (defined $method_name && $method_name)
663 || confess "You must define a method name";
666 # I don't really need this here, because
667 # if the method_map is missing a key it
668 # will just return undef for me now
669 # return unless $self->has_method($method_name);
671 return $self->get_method_map->{$method_name};
675 my ($self, $method_name) = @_;
676 (defined $method_name && $method_name)
677 || confess "You must define a method name";
679 my $removed_method = delete $self->get_method_map->{$method_name};
681 $self->remove_package_symbol("&${method_name}");
683 $self->update_package_cache_flag;
685 return $removed_method;
688 sub get_method_list {
690 keys %{$self->get_method_map};
693 sub find_method_by_name {
694 my ($self, $method_name) = @_;
695 (defined $method_name && $method_name)
696 || confess "You must define a method name to find";
697 foreach my $class ($self->linearized_isa) {
698 # fetch the meta-class ...
699 my $meta = $self->initialize($class);
700 return $meta->get_method($method_name)
701 if $meta->has_method($method_name);
706 sub compute_all_applicable_methods {
708 my (@methods, %seen_method);
709 foreach my $class ($self->linearized_isa) {
710 # fetch the meta-class ...
711 my $meta = $self->initialize($class);
712 foreach my $method_name ($meta->get_method_list()) {
713 next if exists $seen_method{$method_name};
714 $seen_method{$method_name}++;
716 name => $method_name,
718 code => $meta->get_method($method_name)
725 sub find_all_methods_by_name {
726 my ($self, $method_name) = @_;
727 (defined $method_name && $method_name)
728 || confess "You must define a method name to find";
730 foreach my $class ($self->linearized_isa) {
731 # fetch the meta-class ...
732 my $meta = $self->initialize($class);
734 name => $method_name,
736 code => $meta->get_method($method_name)
737 } if $meta->has_method($method_name);
742 sub find_next_method_by_name {
743 my ($self, $method_name) = @_;
744 (defined $method_name && $method_name)
745 || confess "You must define a method name to find";
746 my @cpl = $self->linearized_isa;
747 shift @cpl; # discard ourselves
748 foreach my $class (@cpl) {
749 # fetch the meta-class ...
750 my $meta = $self->initialize($class);
751 return $meta->get_method($method_name)
752 if $meta->has_method($method_name);
761 # either we have an attribute object already
762 # or we need to create one from the args provided
763 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
764 # make sure it is derived from the correct type though
765 ($attribute->isa('Class::MOP::Attribute'))
766 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
768 # first we attach our new attribute
769 # because it might need certain information
770 # about the class which it is attached to
771 $attribute->attach_to_class($self);
773 # then we remove attributes of a conflicting
774 # name here so that we can properly detach
775 # the old attr object, and remove any
776 # accessors it would have generated
777 $self->remove_attribute($attribute->name)
778 if $self->has_attribute($attribute->name);
780 # then onto installing the new accessors
781 $attribute->install_accessors();
782 $self->get_attribute_map->{$attribute->name} = $attribute;
786 my ($self, $attribute_name) = @_;
787 (defined $attribute_name && $attribute_name)
788 || confess "You must define an attribute name";
789 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
793 my ($self, $attribute_name) = @_;
794 (defined $attribute_name && $attribute_name)
795 || confess "You must define an attribute name";
796 return $self->get_attribute_map->{$attribute_name}
798 # this will return undef anyway, so no need ...
799 # if $self->has_attribute($attribute_name);
803 sub remove_attribute {
804 my ($self, $attribute_name) = @_;
805 (defined $attribute_name && $attribute_name)
806 || confess "You must define an attribute name";
807 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
808 return unless defined $removed_attribute;
809 delete $self->get_attribute_map->{$attribute_name};
810 $removed_attribute->remove_accessors();
811 $removed_attribute->detach_from_class();
812 return $removed_attribute;
815 sub get_attribute_list {
817 keys %{$self->get_attribute_map};
820 sub compute_all_applicable_attributes {
822 my (@attrs, %seen_attr);
823 foreach my $class ($self->linearized_isa) {
824 # fetch the meta-class ...
825 my $meta = $self->initialize($class);
826 foreach my $attr_name ($meta->get_attribute_list()) {
827 next if exists $seen_attr{$attr_name};
828 $seen_attr{$attr_name}++;
829 push @attrs => $meta->get_attribute($attr_name);
835 sub find_attribute_by_name {
836 my ($self, $attr_name) = @_;
837 foreach my $class ($self->linearized_isa) {
838 # fetch the meta-class ...
839 my $meta = $self->initialize($class);
840 return $meta->get_attribute($attr_name)
841 if $meta->has_attribute($attr_name);
849 sub is_immutable { 0 }
852 # Why I changed this (groditi)
853 # - One Metaclass may have many Classes through many Metaclass instances
854 # - One Metaclass should only have one Immutable Transformer instance
855 # - Each Class may have different Immutabilizing options
856 # - Therefore each Metaclass instance may have different Immutabilizing options
857 # - We need to store one Immutable Transformer instance per Metaclass
858 # - We need to store one set of Immutable Transformer options per Class
859 # - Upon make_mutable we may delete the Immutabilizing options
860 # - We could clean the immutable Transformer instance when there is no more
861 # immutable Classes of that type, but we can also keep it in case
862 # another class with this same Metaclass becomes immutable. It is a case
863 # of trading of storing an instance to avoid unnecessary instantiations of
864 # Immutable Transformers. You may view this as a memory leak, however
865 # Because we have few Metaclasses, in practice it seems acceptable
866 # - To allow Immutable Transformers instances to be cleaned up we could weaken
867 # the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM
870 my %IMMUTABLE_TRANSFORMERS;
871 my %IMMUTABLE_OPTIONS;
875 my $class = blessed $self || $self;
877 $IMMUTABLE_TRANSFORMERS{$class} ||= $self->create_immutable_transformer;
878 my $transformer = $IMMUTABLE_TRANSFORMERS{$class};
880 $transformer->make_metaclass_immutable($self, \%options);
881 $IMMUTABLE_OPTIONS{$self->name} =
882 { %options, IMMUTABLE_TRANSFORMER => $transformer };
884 if( exists $options{debug} && $options{debug} ){
885 print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS;
886 print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS;
894 return if $self->is_mutable;
895 my $options = delete $IMMUTABLE_OPTIONS{$self->name};
896 confess "unable to find immutabilizing options" unless ref $options;
897 my $transformer = delete $options->{IMMUTABLE_TRANSFORMER};
898 $transformer->make_metaclass_mutable($self, $options);
903 sub create_immutable_transformer {
905 my $class = Class::MOP::Immutable->new($self, {
906 read_only => [qw/superclasses/],
913 remove_package_symbol
916 class_precedence_list => 'ARRAY',
917 linearized_isa => 'ARRAY',
918 compute_all_applicable_attributes => 'ARRAY',
919 get_meta_instance => 'SCALAR',
920 get_method_map => 'SCALAR',
923 # this is ugly, but so are typeglobs,
924 # so whattayahgonnadoboutit
927 add_package_symbol => sub {
928 my $original = shift;
929 confess "Cannot add package symbols to an immutable metaclass"
930 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
931 goto $original->body;
946 Class::MOP::Class - Class Meta Object
950 # assuming that class Foo
951 # has been defined, you can
953 # use this for introspection ...
955 # add a method to Foo ...
956 Foo->meta->add_method('bar' => sub { ... })
958 # get a list of all the classes searched
959 # the method dispatcher in the correct order
960 Foo->meta->class_precedence_list()
962 # remove a method from Foo
963 Foo->meta->remove_method('bar');
965 # or use this to actually create classes ...
967 Class::MOP::Class->create('Bar' => (
969 superclasses => [ 'Foo' ],
971 Class::MOP:::Attribute->new('$bar'),
972 Class::MOP:::Attribute->new('$baz'),
975 calculate_bar => sub { ... },
976 construct_baz => sub { ... }
982 This is the largest and currently most complex part of the Perl 5
983 meta-object protocol. It controls the introspection and
984 manipulation of Perl 5 classes (and it can create them too). The
985 best way to understand what this module can do, is to read the
986 documentation for each of it's methods.
990 =head2 Self Introspection
996 This will return a B<Class::MOP::Class> instance which is related
997 to this class. Thereby allowing B<Class::MOP::Class> to actually
1000 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
1001 bootstrap this module by installing a number of attribute meta-objects
1002 into it's metaclass. This will allow this class to reap all the benifits
1003 of the MOP when subclassing it.
1007 =head2 Class construction
1009 These methods will handle creating B<Class::MOP::Class> objects,
1010 which can be used to both create new classes, and analyze
1011 pre-existing classes.
1013 This module will internally store references to all the instances
1014 you create with these methods, so that they do not need to be
1015 created any more than nessecary. Basically, they are singletons.
1019 =item B<create ($package_name,
1020 version =E<gt> ?$version,
1021 authority =E<gt> ?$authority,
1022 superclasses =E<gt> ?@superclasses,
1023 methods =E<gt> ?%methods,
1024 attributes =E<gt> ?%attributes)>
1026 This returns a B<Class::MOP::Class> object, bringing the specified
1027 C<$package_name> into existence and adding any of the C<$version>,
1028 C<$authority>, C<@superclasses>, C<%methods> and C<%attributes> to
1031 =item B<create_anon_class (superclasses =E<gt> ?@superclasses,
1032 methods =E<gt> ?%methods,
1033 attributes =E<gt> ?%attributes)>
1035 This will create an anonymous class, it works much like C<create> but
1036 it does not need a C<$package_name>. Instead it will create a suitably
1037 unique package name for you to stash things into.
1039 On very important distinction is that anon classes are destroyed once
1040 the metaclass they are attached to goes out of scope. In the DESTROY
1041 method, the created package will be removed from the symbol table.
1043 It is also worth noting that any instances created with an anon-class
1044 will keep a special reference to the anon-meta which will prevent the
1045 anon-class from going out of scope until all instances of it have also
1046 been destroyed. This however only works for HASH based instance types,
1047 as we use a special reserved slot (C<__MOP__>) to store this.
1049 =item B<initialize ($package_name, %options)>
1051 This initializes and returns returns a B<Class::MOP::Class> object
1052 for a given a C<$package_name>.
1054 =item B<reinitialize ($package_name, %options)>
1056 This removes the old metaclass, and creates a new one in it's place.
1057 Do B<not> use this unless you really know what you are doing, it could
1058 very easily make a very large mess of your program.
1060 =item B<construct_class_instance (%options)>
1062 This will construct an instance of B<Class::MOP::Class>, it is
1063 here so that we can actually "tie the knot" for B<Class::MOP::Class>
1064 to use C<construct_instance> once all the bootstrapping is done. This
1065 method is used internally by C<initialize> and should never be called
1066 from outside of that method really.
1068 =item B<check_metaclass_compatability>
1070 This method is called as the very last thing in the
1071 C<construct_class_instance> method. This will check that the
1072 metaclass you are creating is compatible with the metaclasses of all
1073 your ancestors. For more inforamtion about metaclass compatibility
1074 see the C<About Metaclass compatibility> section in L<Class::MOP>.
1076 =item B<update_package_cache_flag>
1078 This will reset the package cache flag for this particular metaclass
1079 it is basically the value of the C<Class::MOP::get_package_cache_flag>
1080 function. This is very rarely needed from outside of C<Class::MOP::Class>
1081 but in some cases you might want to use it, so it is here.
1083 =item B<reset_package_cache_flag>
1085 Clears the package cache flag to announce to the internals that we need
1086 to rebuild the method map.
1090 =head2 Object instance construction and cloning
1092 These methods are B<entirely optional>, it is up to you whether you want
1097 =item B<instance_metaclass>
1099 Returns the class name of the instance metaclass, see L<Class::MOP::Instance>
1100 for more information on the instance metaclasses.
1102 =item B<get_meta_instance>
1104 Returns an instance of L<Class::MOP::Instance> to be used in the construction
1105 of a new instance of the class.
1107 =item B<new_object (%params)>
1109 This is a convience method for creating a new object of the class, and
1110 blessing it into the appropriate package as well. Ideally your class
1111 would call a C<new> this method like so:
1114 my ($class, %param) = @_;
1115 $class->meta->new_object(%params);
1118 =item B<construct_instance (%params)>
1120 This method is used to construct an instance structure suitable for
1121 C<bless>-ing into your package of choice. It works in conjunction
1122 with the Attribute protocol to collect all applicable attributes.
1124 This will construct and instance using a HASH ref as storage
1125 (currently only HASH references are supported). This will collect all
1126 the applicable attributes and layout out the fields in the HASH ref,
1127 it will then initialize them using either use the corresponding key
1128 in C<%params> or any default value or initializer found in the
1129 attribute meta-object.
1131 =item B<clone_object ($instance, %params)>
1133 This is a convience method for cloning an object instance, then
1134 blessing it into the appropriate package. This method will call
1135 C<clone_instance>, which performs a shallow copy of the object,
1136 see that methods documentation for more details. Ideally your
1137 class would call a C<clone> this method like so:
1139 sub MyClass::clone {
1140 my ($self, %param) = @_;
1141 $self->meta->clone_object($self, %params);
1144 =item B<clone_instance($instance, %params)>
1146 This method is a compliment of C<construct_instance> (which means if
1147 you override C<construct_instance>, you need to override this one too),
1148 and clones the instance shallowly.
1150 The cloned structure returned is (like with C<construct_instance>) an
1151 unC<bless>ed HASH reference, it is your responsibility to then bless
1152 this cloned structure into the right class (which C<clone_object> will
1155 As of 0.11, this method will clone the C<$instance> structure shallowly,
1156 as opposed to the deep cloning implemented in prior versions. After much
1157 thought, research and discussion, I have decided that anything but basic
1158 shallow cloning is outside the scope of the meta-object protocol. I
1159 think Yuval "nothingmuch" Kogman put it best when he said that cloning
1160 is too I<context-specific> to be part of the MOP.
1162 =item B<rebless_instance($instance, ?%params)>
1164 This will change the class of C<$instance> to the class of the invoking
1165 C<Class::MOP::Class>. You may only rebless the instance to a subclass of
1166 itself. You may pass in optional C<%params> which are like constructor
1167 params and will override anything already defined in the instance.
1171 =head2 Informational
1173 These are a few predicate methods for asking information about the class.
1177 =item B<is_anon_class>
1179 This returns true if the class is a C<Class::MOP::Class> created anon class.
1183 This returns true if the class is still mutable.
1185 =item B<is_immutable>
1187 This returns true if the class has been made immutable.
1191 =head2 Inheritance Relationships
1195 =item B<superclasses (?@superclasses)>
1197 This is a read-write attribute which represents the superclass
1198 relationships of the class the B<Class::MOP::Class> instance is
1199 associated with. Basically, it can get and set the C<@ISA> for you.
1201 =item B<class_precedence_list>
1203 This computes the a list of all the class's ancestors in the same order
1204 in which method dispatch will be done. This is similair to what
1205 B<Class::ISA::super_path> does, but we don't remove duplicate names.
1207 =item B<linearized_isa>
1209 This returns a list based on C<class_precedence_list> but with all
1214 This returns a list of subclasses for this class.
1222 =item B<get_method_map>
1224 Returns a HASH ref of name to CODE reference mapping for this class.
1226 =item B<method_metaclass>
1228 Returns the class name of the method metaclass, see L<Class::MOP::Method>
1229 for more information on the method metaclasses.
1231 =item B<add_method ($method_name, $method)>
1233 This will take a C<$method_name> and CODE reference to that
1234 C<$method> and install it into the class's package.
1237 This does absolutely nothing special to C<$method>
1238 other than use B<Sub::Name> to make sure it is tagged with the
1239 correct name, and therefore show up correctly in stack traces and
1242 =item B<alias_method ($method_name, $method)>
1244 This will take a C<$method_name> and CODE reference to that
1245 C<$method> and alias the method into the class's package.
1248 Unlike C<add_method>, this will B<not> try to name the
1249 C<$method> using B<Sub::Name>, it only aliases the method in
1250 the class's package.
1252 =item B<has_method ($method_name)>
1254 This just provides a simple way to check if the class implements
1255 a specific C<$method_name>. It will I<not> however, attempt to check
1256 if the class inherits the method (use C<UNIVERSAL::can> for that).
1258 This will correctly handle functions defined outside of the package
1259 that use a fully qualified name (C<sub Package::name { ... }>).
1261 This will correctly handle functions renamed with B<Sub::Name> and
1262 installed using the symbol tables. However, if you are naming the
1263 subroutine outside of the package scope, you must use the fully
1264 qualified name, including the package name, for C<has_method> to
1265 correctly identify it.
1267 This will attempt to correctly ignore functions imported from other
1268 packages using B<Exporter>. It breaks down if the function imported
1269 is an C<__ANON__> sub (such as with C<use constant>), which very well
1270 may be a valid method being applied to the class.
1272 In short, this method cannot always be trusted to determine if the
1273 C<$method_name> is actually a method. However, it will DWIM about
1274 90% of the time, so it's a small trade off I think.
1276 =item B<get_method ($method_name)>
1278 This will return a Class::MOP::Method instance related to the specified
1279 C<$method_name>, or return undef if that method does not exist.
1281 The Class::MOP::Method is codifiable, so you can use it like a normal
1282 CODE reference, see L<Class::MOP::Method> for more information.
1284 =item B<find_method_by_name ($method_name)>
1286 This will return a CODE reference of the specified C<$method_name>,
1287 or return undef if that method does not exist.
1289 Unlike C<get_method> this will also look in the superclasses.
1291 =item B<remove_method ($method_name)>
1293 This will attempt to remove a given C<$method_name> from the class.
1294 It will return the CODE reference that it has removed, and will
1295 attempt to use B<Sub::Name> to clear the methods associated name.
1297 =item B<get_method_list>
1299 This will return a list of method names for all I<locally> defined
1300 methods. It does B<not> provide a list of all applicable methods,
1301 including any inherited ones. If you want a list of all applicable
1302 methods, use the C<compute_all_applicable_methods> method.
1304 =item B<compute_all_applicable_methods>
1306 This will return a list of all the methods names this class will
1307 respond to, taking into account inheritance. The list will be a list of
1308 HASH references, each one containing the following information; method
1309 name, the name of the class in which the method lives and a CODE
1310 reference for the actual method.
1312 =item B<find_all_methods_by_name ($method_name)>
1314 This will traverse the inheritence hierarchy and locate all methods
1315 with a given C<$method_name>. Similar to
1316 C<compute_all_applicable_methods> it returns a list of HASH references
1317 with the following information; method name (which will always be the
1318 same as C<$method_name>), the name of the class in which the method
1319 lives and a CODE reference for the actual method.
1321 The list of methods produced is a distinct list, meaning there are no
1322 duplicates in it. This is especially useful for things like object
1323 initialization and destruction where you only want the method called
1324 once, and in the correct order.
1326 =item B<find_next_method_by_name ($method_name)>
1328 This will return the first method to match a given C<$method_name> in
1329 the superclasses, this is basically equivalent to calling
1330 C<SUPER::$method_name>, but it can be dispatched at runtime.
1334 =head2 Method Modifiers
1336 Method modifiers are a concept borrowed from CLOS, in which a method
1337 can be wrapped with I<before>, I<after> and I<around> method modifiers
1338 that will be called everytime the method is called.
1340 =head3 How method modifiers work?
1342 Method modifiers work by wrapping the original method and then replacing
1343 it in the classes symbol table. The wrappers will handle calling all the
1344 modifiers in the appropariate orders and preserving the calling context
1345 for the original method.
1347 Each method modifier serves a particular purpose, which may not be
1348 obvious to users of other method wrapping modules. To start with, the
1349 return values of I<before> and I<after> modifiers are ignored. This is
1350 because thier purpose is B<not> to filter the input and output of the
1351 primary method (this is done with an I<around> modifier). This may seem
1352 like an odd restriction to some, but doing this allows for simple code
1353 to be added at the begining or end of a method call without jeapordizing
1354 the normal functioning of the primary method or placing any extra
1355 responsibility on the code of the modifier. Of course if you have more
1356 complex needs, then use the I<around> modifier, which uses a variation
1357 of continutation passing style to allow for a high degree of flexibility.
1359 Before and around modifiers are called in last-defined-first-called order,
1360 while after modifiers are called in first-defined-first-called order. So
1361 the call tree might looks something like this:
1371 To see examples of using method modifiers, see the following examples
1372 included in the distribution; F<InstanceCountingClass>, F<Perl6Attribute>,
1373 F<AttributesWithHistory> and F<C3MethodDispatchOrder>. There is also a
1374 classic CLOS usage example in the test F<017_add_method_modifier.t>.
1376 =head3 What is the performance impact?
1378 Of course there is a performance cost associated with method modifiers,
1379 but we have made every effort to make that cost be directly proportional
1380 to the amount of modifier features you utilize.
1382 The wrapping method does it's best to B<only> do as much work as it
1383 absolutely needs to. In order to do this we have moved some of the
1384 performance costs to set-up time, where they are easier to amortize.
1386 All this said, my benchmarks have indicated the following:
1388 simple wrapper with no modifiers 100% slower
1389 simple wrapper with simple before modifier 400% slower
1390 simple wrapper with simple after modifier 450% slower
1391 simple wrapper with simple around modifier 500-550% slower
1392 simple wrapper with all 3 modifiers 1100% slower
1394 These numbers may seem daunting, but you must remember, every feature
1395 comes with some cost. To put things in perspective, just doing a simple
1396 C<AUTOLOAD> which does nothing but extract the name of the method called
1397 and return it costs about 400% over a normal method call.
1401 =item B<add_before_method_modifier ($method_name, $code)>
1403 This will wrap the method at C<$method_name> and the supplied C<$code>
1404 will be passed the C<@_> arguments, and called before the original
1405 method is called. As specified above, the return value of the I<before>
1406 method modifiers is ignored, and it's ability to modify C<@_> is
1407 fairly limited. If you need to do either of these things, use an
1408 C<around> method modifier.
1410 =item B<add_after_method_modifier ($method_name, $code)>
1412 This will wrap the method at C<$method_name> so that the original
1413 method will be called, it's return values stashed, and then the
1414 supplied C<$code> will be passed the C<@_> arguments, and called.
1415 As specified above, the return value of the I<after> method
1416 modifiers is ignored, and it cannot modify the return values of
1417 the original method. If you need to do either of these things, use an
1418 C<around> method modifier.
1420 =item B<add_around_method_modifier ($method_name, $code)>
1422 This will wrap the method at C<$method_name> so that C<$code>
1423 will be called and passed the original method as an extra argument
1424 at the begining of the C<@_> argument list. This is a variation of
1425 continuation passing style, where the function prepended to C<@_>
1426 can be considered a continuation. It is up to C<$code> if it calls
1427 the original method or not, there is no restriction on what the
1428 C<$code> can or cannot do.
1434 It should be noted that since there is no one consistent way to define
1435 the attributes of a class in Perl 5. These methods can only work with
1436 the information given, and can not easily discover information on
1437 their own. See L<Class::MOP::Attribute> for more details.
1441 =item B<attribute_metaclass>
1443 Returns the class name of the attribute metaclass, see L<Class::MOP::Attribute>
1444 for more information on the attribute metaclasses.
1446 =item B<get_attribute_map>
1448 This returns a HASH ref of name to attribute meta-object mapping.
1450 =item B<add_attribute ($attribute_meta_object | ($attribute_name, %attribute_spec))>
1452 This stores the C<$attribute_meta_object> (or creates one from the
1453 C<$attribute_name> and C<%attribute_spec>) in the B<Class::MOP::Class>
1454 instance associated with the given class. Unlike methods, attributes
1455 within the MOP are stored as meta-information only. They will be used
1456 later to construct instances from (see C<construct_instance> above).
1457 More details about the attribute meta-objects can be found in the
1458 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
1461 It should be noted that any accessor, reader/writer or predicate
1462 methods which the C<$attribute_meta_object> has will be installed
1463 into the class at this time.
1466 If an attribute already exists for C<$attribute_name>, the old one
1467 will be removed (as well as removing all it's accessors), and then
1470 =item B<has_attribute ($attribute_name)>
1472 Checks to see if this class has an attribute by the name of
1473 C<$attribute_name> and returns a boolean.
1475 =item B<get_attribute ($attribute_name)>
1477 Returns the attribute meta-object associated with C<$attribute_name>,
1478 if none is found, it will return undef.
1480 =item B<remove_attribute ($attribute_name)>
1482 This will remove the attribute meta-object stored at
1483 C<$attribute_name>, then return the removed attribute meta-object.
1486 Removing an attribute will only affect future instances of
1487 the class, it will not make any attempt to remove the attribute from
1488 any existing instances of the class.
1490 It should be noted that any accessor, reader/writer or predicate
1491 methods which the attribute meta-object stored at C<$attribute_name>
1492 has will be removed from the class at this time. This B<will> make
1493 these attributes somewhat inaccessable in previously created
1494 instances. But if you are crazy enough to do this at runtime, then
1495 you are crazy enough to deal with something like this :).
1497 =item B<get_attribute_list>
1499 This returns a list of attribute names which are defined in the local
1500 class. If you want a list of all applicable attributes for a class,
1501 use the C<compute_all_applicable_attributes> method.
1503 =item B<compute_all_applicable_attributes>
1505 This will traverse the inheritance heirachy and return a list of all
1506 the applicable attributes for this class. It does not construct a
1507 HASH reference like C<compute_all_applicable_methods> because all
1508 that same information is discoverable through the attribute
1511 =item B<find_attribute_by_name ($attr_name)>
1513 This method will traverse the inheritance heirachy and find the
1514 first attribute whose name matches C<$attr_name>, then return it.
1515 It will return undef if nothing is found.
1519 =head2 Class Immutability
1523 =item B<make_immutable (%options)>
1525 This method will invoke a tranforamtion upon the class which will
1526 make it immutable. Details of this transformation can be found in
1527 the L<Class::MOP::Immutable> documentation.
1529 =item B<make_mutable>
1531 This method will reverse tranforamtion upon the class which
1534 =item B<create_immutable_transformer>
1536 Create a transformer suitable for making this class immutable
1542 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1544 =head1 COPYRIGHT AND LICENSE
1546 Copyright 2006-2008 by Infinity Interactive, Inc.
1548 L<http://www.iinteractive.com>
1550 This library is free software; you can redistribute it and/or modify
1551 it under the same terms as Perl itself.