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::Class::Immutable::Class::MOP::Class;
14 use Scalar::Util 'blessed', 'weaken';
17 our $VERSION = '0.83';
18 $VERSION = eval $VERSION;
19 our $AUTHORITY = 'cpan:STEVAN';
21 use base 'Class::MOP::Module';
31 $package_name = shift;
34 $package_name = $options{package};
37 (defined $package_name && $package_name && !ref($package_name))
38 || confess "You must pass a package name and it cannot be blessed";
40 return Class::MOP::get_metaclass_by_name($package_name)
41 || $class->_construct_class_instance(package => $package_name, @_);
44 sub construct_class_instance {
45 Carp::cluck('The construct_class_instance method has been made private.'
46 . " The public version is deprecated and will be removed in a future release.\n");
47 shift->_construct_class_instance(@_);
50 # NOTE: (meta-circularity)
51 # this is a special form of _construct_instance
52 # (see below), which is used to construct class
53 # meta-object instances for any Class::MOP::*
54 # class. All other classes will use the more
55 # normal &construct_instance.
56 sub _construct_class_instance {
58 my $options = @_ == 1 ? $_[0] : {@_};
59 my $package_name = $options->{package};
60 (defined $package_name && $package_name)
61 || confess "You must pass a package name";
63 # return the metaclass if we have it cached,
64 # and it is still defined (it has not been
65 # reaped by DESTROY yet, which can happen
66 # annoyingly enough during global destruction)
68 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
73 # we need to deal with the possibility
74 # of class immutability here, and then
75 # get the name of the class appropriately
77 ? ($class->is_immutable
78 ? $class->get_mutable_metaclass_name()
82 # now create the metaclass
84 if ($class eq 'Class::MOP::Class') {
85 $meta = $class->_new($options);
89 # it is safe to use meta here because
90 # class will always be a subclass of
91 # Class::MOP::Class, which defines meta
92 $meta = $class->meta->_construct_instance($options)
95 # and check the metaclass compatibility
96 $meta->_check_metaclass_compatibility();
98 Class::MOP::store_metaclass_by_name($package_name, $meta);
101 # we need to weaken any anon classes
102 # so that they can call DESTROY properly
103 Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class;
110 my $options = @_ == 1 ? $_[0] : {@_};
113 # inherited from Class::MOP::Package
114 'package' => $options->{package},
117 # since the following attributes will
118 # actually be loaded from the symbol
119 # table, and actually bypass the instance
120 # entirely, we can just leave these things
121 # listed here for reference, because they
122 # should not actually have a value associated
124 'namespace' => \undef,
126 # inherited from Class::MOP::Module
128 'authority' => \undef,
130 # defined in Class::MOP::Class
131 'superclasses' => \undef,
135 'attribute_metaclass' =>
136 ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
137 'method_metaclass' =>
138 ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
139 'wrapped_method_metaclass' => (
140 $options->{'wrapped_method_metaclass'}
141 || 'Class::MOP::Method::Wrapped'
143 'instance_metaclass' =>
144 ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
145 'immutable_trait' => (
146 $options->{'immutable_trait'}
147 || 'Class::MOP::Class::Immutable::Trait'
149 'constructor_name' => ( $options->{constructor_name} || 'new' ),
150 'constructor_class' => (
151 $options->{constructor_class} || 'Class::MOP::Method::Constructor'
153 'destructor_class' => $options->{destructor_class},
157 sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
158 sub update_package_cache_flag {
161 # we can manually update the cache number
162 # since we are actually adding the method
163 # to our cache as well. This avoids us
164 # having to regenerate the method_map.
166 $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
170 sub check_metaclass_compatibility {
171 Carp::cluck('The check_metaclass_compatibility method has been made private.'
172 . " The public version is deprecated and will be removed in a future release.\n");
173 shift->_check_metaclass_compatibility(@_);
176 sub _check_metaclass_compatibility {
179 # this is always okay ...
180 return if ref($self) eq 'Class::MOP::Class' &&
181 $self->instance_metaclass eq 'Class::MOP::Instance';
183 my @class_list = $self->linearized_isa;
184 shift @class_list; # shift off $self->name
186 foreach my $superclass_name (@class_list) {
187 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next;
190 # we need to deal with the possibility
191 # of class immutability here, and then
192 # get the name of the class appropriately
194 = $super_meta->is_immutable
195 ? $super_meta->get_mutable_metaclass_name()
198 ($self->isa($super_meta_type))
199 || confess "Class::MOP::class_of(" . $self->name . ") => ("
200 . (ref($self)) . ")" . " is not compatible with the " .
201 "Class::MOP::class_of(".$superclass_name . ") => ("
202 . ($super_meta_type) . ")";
204 # we also need to check that instance metaclasses
205 # are compatibile in the same the class.
206 ($self->instance_metaclass->isa($super_meta->instance_metaclass))
207 || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
208 " is not compatible with the " .
209 "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
217 # this should be sufficient, if you have a
218 # use case where it is not, write a test and
220 my $ANON_CLASS_SERIAL = 0;
223 # we need a sufficiently annoying prefix
224 # this should suffice for now, this is
225 # used in a couple of places below, so
226 # need to put it up here for now.
227 my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
231 no warnings 'uninitialized';
232 $self->name =~ /^$ANON_CLASS_PREFIX/;
235 sub create_anon_class {
236 my ($class, %options) = @_;
237 my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
238 return $class->create($package_name, %options);
242 # this will only get called for
243 # anon-classes, all other calls
244 # are assumed to occur during
245 # global destruction and so don't
246 # really need to be handled explicitly
250 return if Devel::GlobalDestruction::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
252 no warnings 'uninitialized';
253 return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
254 # Moose does a weird thing where it replaces the metaclass for
255 # class when fixing metaclass incompatibility. In that case,
256 # we don't want to clean out the namespace now. We can detect
257 # that because Moose will explicitly update the singleton
258 # cache in Class::MOP.
259 my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
260 return if $current_meta ne $self;
262 my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
264 foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
265 delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
267 delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
272 # creating classes with MOP ...
275 my ( $class, @args ) = @_;
277 unshift @args, 'package' if @args % 2 == 1;
279 my (%options) = @args;
280 my $package_name = $options{package};
282 (ref $options{superclasses} eq 'ARRAY')
283 || confess "You must pass an ARRAY ref of superclasses"
284 if exists $options{superclasses};
286 (ref $options{attributes} eq 'ARRAY')
287 || confess "You must pass an ARRAY ref of attributes"
288 if exists $options{attributes};
290 (ref $options{methods} eq 'HASH')
291 || confess "You must pass a HASH ref of methods"
292 if exists $options{methods};
294 my (%initialize_options) = @args;
295 delete @initialize_options{qw(
303 my $meta = $class->initialize( $package_name => %initialize_options );
305 $meta->_instantiate_module( $options{version}, $options{authority} );
308 $meta->add_method('meta' => sub {
309 $class->initialize(ref($_[0]) || $_[0]);
312 $meta->superclasses(@{$options{superclasses}})
313 if exists $options{superclasses};
315 # process attributes first, so that they can
316 # install accessors, but locally defined methods
317 # can then overwrite them. It is maybe a little odd, but
318 # I think this should be the order of things.
319 if (exists $options{attributes}) {
320 foreach my $attr (@{$options{attributes}}) {
321 $meta->add_attribute($attr);
324 if (exists $options{methods}) {
325 foreach my $method_name (keys %{$options{methods}}) {
326 $meta->add_method($method_name, $options{methods}->{$method_name});
335 # all these attribute readers will be bootstrapped
336 # away in the Class::MOP bootstrap section
338 sub get_attribute_map { $_[0]->{'attributes'} }
339 sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
340 sub method_metaclass { $_[0]->{'method_metaclass'} }
341 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
342 sub instance_metaclass { $_[0]->{'instance_metaclass'} }
343 sub immutable_trait { $_[0]->{'immutable_trait'} }
344 sub constructor_class { $_[0]->{'constructor_class'} }
345 sub constructor_name { $_[0]->{'constructor_name'} }
346 sub destructor_class { $_[0]->{'destructor_class'} }
348 # Instance Construction & Cloning
354 # we need to protect the integrity of the
355 # Class::MOP::Class singletons here, so we
356 # delegate this to &construct_class_instance
357 # which will deal with the singletons
358 return $class->_construct_class_instance(@_)
359 if $class->name->isa('Class::MOP::Class');
360 return $class->_construct_instance(@_);
363 sub construct_instance {
364 Carp::cluck('The construct_instance method has been made private.'
365 . " The public version is deprecated and will be removed in a future release.\n");
366 shift->_construct_instance(@_);
369 sub _construct_instance {
371 my $params = @_ == 1 ? $_[0] : {@_};
372 my $meta_instance = $class->get_meta_instance();
373 my $instance = $meta_instance->create_instance();
374 foreach my $attr ($class->get_all_attributes()) {
375 $attr->initialize_instance_slot($meta_instance, $instance, $params);
378 # this will only work for a HASH instance type
379 if ($class->is_anon_class) {
380 (Scalar::Util::reftype($instance) eq 'HASH')
381 || confess "Currently only HASH based instances are supported with instance of anon-classes";
383 # At some point we should make this official
384 # as a reserved slot name, but right now I am
385 # going to keep it here.
386 # my $RESERVED_MOP_SLOT = '__MOP__';
387 $instance->{'__MOP__'} = $class;
393 sub get_meta_instance {
395 $self->{'_meta_instance'} ||= $self->_create_meta_instance();
398 sub create_meta_instance {
399 Carp::cluck('The create_meta_instance method has been made private.'
400 . " The public version is deprecated and will be removed in a future release.\n");
401 shift->_create_meta_instance(@_);
404 sub _create_meta_instance {
407 my $instance = $self->instance_metaclass->new(
408 associated_metaclass => $self,
409 attributes => [ $self->get_all_attributes() ],
412 $self->add_meta_instance_dependencies()
413 if $instance->is_dependent_on_superclasses();
420 my $instance = shift;
421 (blessed($instance) && $instance->isa($class->name))
422 || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
425 # we need to protect the integrity of the
426 # Class::MOP::Class singletons here, they
427 # should not be cloned.
428 return $instance if $instance->isa('Class::MOP::Class');
429 $class->_clone_instance($instance, @_);
433 Carp::cluck('The clone_instance method has been made private.'
434 . " The public version is deprecated and will be removed in a future release.\n");
435 shift->_clone_instance(@_);
438 sub _clone_instance {
439 my ($class, $instance, %params) = @_;
441 || confess "You can only clone instances, ($instance) is not a blessed instance";
442 my $meta_instance = $class->get_meta_instance();
443 my $clone = $meta_instance->clone_instance($instance);
444 foreach my $attr ($class->get_all_attributes()) {
445 if ( defined( my $init_arg = $attr->init_arg ) ) {
446 if (exists $params{$init_arg}) {
447 $attr->set_value($clone, $params{$init_arg});
454 sub rebless_instance {
455 my ($self, $instance, %params) = @_;
457 my $old_metaclass = Class::MOP::class_of($instance);
459 my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
460 $self->name->isa($old_class)
461 || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
463 $old_metaclass->rebless_instance_away($instance, $self, %params)
466 my $meta_instance = $self->get_meta_instance();
469 # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
470 $meta_instance->rebless_instance_structure($_[1], $self);
472 foreach my $attr ( $self->get_all_attributes ) {
473 if ( $attr->has_value($instance) ) {
474 if ( defined( my $init_arg = $attr->init_arg ) ) {
475 $params{$init_arg} = $attr->get_value($instance)
476 unless exists $params{$init_arg};
479 $attr->set_value($instance, $attr->get_value($instance));
484 foreach my $attr ($self->get_all_attributes) {
485 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
491 sub rebless_instance_away {
492 # this intentionally does nothing, it is just a hook
499 my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
502 @{$self->get_package_symbol($var_spec)} = @supers;
505 # on 5.8 and below, we need to call
506 # a method to get Perl to detect
507 # a cycle in the class hierarchy
508 my $class = $self->name;
512 # we need to check the metaclass
513 # compatibility here so that we can
514 # be sure that the superclass is
515 # not potentially creating an issues
516 # we don't know about
518 $self->_check_metaclass_compatibility();
519 $self->update_meta_instance_dependencies();
521 @{$self->get_package_symbol($var_spec)};
526 my $super_class = $self->name;
528 return @{ $super_class->mro::get_isarev() };
533 return @{ mro::get_linear_isa( (shift)->name ) };
536 sub class_precedence_list {
538 my $name = $self->name;
540 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
542 # We need to check for circular inheritance here
543 # if we are are not on 5.10, cause 5.8 detects it
544 # late. This will do nothing if all is well, and
545 # blow up otherwise. Yes, it's an ugly hack, better
546 # suggestions are welcome.
548 ($name || return)->isa('This is a test for circular inheritance')
551 # if our mro is c3, we can
552 # just grab the linear_isa
553 if (mro::get_mro($name) eq 'c3') {
554 return @{ mro::get_linear_isa($name) }
558 # we can't grab the linear_isa for dfs
559 # since it has all the duplicates
564 $self->initialize($_)->class_precedence_list()
565 } $self->superclasses()
572 sub wrap_method_body {
573 my ( $self, %args ) = @_;
575 ('CODE' eq ref $args{body})
576 || confess "Your code block must be a CODE reference";
578 $self->method_metaclass->wrap(
579 package_name => $self->name,
585 my ($self, $method_name, $method) = @_;
586 (defined $method_name && $method_name)
587 || confess "You must define a method name";
590 if (blessed($method)) {
591 $body = $method->body;
592 if ($method->package_name ne $self->name) {
593 $method = $method->clone(
594 package_name => $self->name,
596 ) if $method->can('clone');
601 $method = $self->wrap_method_body( body => $body, name => $method_name );
604 $method->attach_to_class($self);
606 # This used to call get_method_map, which meant we would build all
607 # the method objects for the class just because we added one
608 # method. This is hackier, but quicker too.
609 $self->{methods}{$method_name} = $method;
611 my $full_method_name = ($self->name . '::' . $method_name);
612 $self->add_package_symbol(
613 { sigil => '&', type => 'CODE', name => $method_name },
614 Sub::Name::subname($full_method_name => $body)
619 my $fetch_and_prepare_method = sub {
620 my ($self, $method_name) = @_;
621 my $wrapped_metaclass = $self->wrapped_method_metaclass;
623 my $method = $self->get_method($method_name);
624 # if we dont have local ...
626 # try to find the next method
627 $method = $self->find_next_method_by_name($method_name);
628 # die if it does not exist
630 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
631 # and now make sure to wrap it
632 # even if it is already wrapped
633 # because we need a new sub ref
634 $method = $wrapped_metaclass->wrap($method);
637 # now make sure we wrap it properly
638 $method = $wrapped_metaclass->wrap($method)
639 unless $method->isa($wrapped_metaclass);
641 $self->add_method($method_name => $method);
645 sub add_before_method_modifier {
646 my ($self, $method_name, $method_modifier) = @_;
647 (defined $method_name && $method_name)
648 || confess "You must pass in a method name";
649 my $method = $fetch_and_prepare_method->($self, $method_name);
650 $method->add_before_modifier(
651 Sub::Name::subname(':before' => $method_modifier)
655 sub add_after_method_modifier {
656 my ($self, $method_name, $method_modifier) = @_;
657 (defined $method_name && $method_name)
658 || confess "You must pass in a method name";
659 my $method = $fetch_and_prepare_method->($self, $method_name);
660 $method->add_after_modifier(
661 Sub::Name::subname(':after' => $method_modifier)
665 sub add_around_method_modifier {
666 my ($self, $method_name, $method_modifier) = @_;
667 (defined $method_name && $method_name)
668 || confess "You must pass in a method name";
669 my $method = $fetch_and_prepare_method->($self, $method_name);
670 $method->add_around_modifier(
671 Sub::Name::subname(':around' => $method_modifier)
676 # the methods above used to be named like this:
677 # ${pkg}::${method}:(before|after|around)
678 # but this proved problematic when using one modifier
679 # to wrap multiple methods (something which is likely
680 # to happen pretty regularly IMO). So instead of naming
681 # it like this, I have chosen to just name them purely
682 # with their modifier names, like so:
683 # :(before|after|around)
684 # The fact is that in a stack trace, it will be fairly
685 # evident from the context what method they are attached
686 # to, and so don't need the fully qualified name.
690 Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
692 shift->add_method(@_);
696 my ($self, $method_name) = @_;
697 (defined $method_name && $method_name)
698 || confess "You must define a method name";
700 exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
704 my ($self, $method_name) = @_;
705 (defined $method_name && $method_name)
706 || confess "You must define a method name";
708 return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
712 my ($self, $method_name) = @_;
713 (defined $method_name && $method_name)
714 || confess "You must define a method name";
716 my $removed_method = delete $self->get_method_map->{$method_name};
718 $self->remove_package_symbol(
719 { sigil => '&', type => 'CODE', name => $method_name }
722 $removed_method->detach_from_class if $removed_method;
724 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
726 return $removed_method;
729 sub get_method_list {
731 keys %{$self->get_method_map};
734 sub find_method_by_name {
735 my ($self, $method_name) = @_;
736 (defined $method_name && $method_name)
737 || confess "You must define a method name to find";
738 foreach my $class ($self->linearized_isa) {
739 # fetch the meta-class ...
740 my $meta = $self->initialize($class);
741 return $meta->get_method($method_name)
742 if $meta->has_method($method_name);
747 sub get_all_methods {
749 my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa;
750 return values %methods;
753 sub compute_all_applicable_methods {
754 Carp::cluck('The compute_all_applicable_methods method is deprecated.'
755 . " Use get_all_methods instead.\n");
760 class => $_->package_name,
761 code => $_, # sigh, overloading
763 } shift->get_all_methods(@_);
766 sub get_all_method_names {
769 grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods;
772 sub find_all_methods_by_name {
773 my ($self, $method_name) = @_;
774 (defined $method_name && $method_name)
775 || confess "You must define a method name to find";
777 foreach my $class ($self->linearized_isa) {
778 # fetch the meta-class ...
779 my $meta = $self->initialize($class);
781 name => $method_name,
783 code => $meta->get_method($method_name)
784 } if $meta->has_method($method_name);
789 sub find_next_method_by_name {
790 my ($self, $method_name) = @_;
791 (defined $method_name && $method_name)
792 || confess "You must define a method name to find";
793 my @cpl = $self->linearized_isa;
794 shift @cpl; # discard ourselves
795 foreach my $class (@cpl) {
796 # fetch the meta-class ...
797 my $meta = $self->initialize($class);
798 return $meta->get_method($method_name)
799 if $meta->has_method($method_name);
808 # either we have an attribute object already
809 # or we need to create one from the args provided
810 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
811 # make sure it is derived from the correct type though
812 ($attribute->isa('Class::MOP::Attribute'))
813 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
815 # first we attach our new attribute
816 # because it might need certain information
817 # about the class which it is attached to
818 $attribute->attach_to_class($self);
820 # then we remove attributes of a conflicting
821 # name here so that we can properly detach
822 # the old attr object, and remove any
823 # accessors it would have generated
824 if ( $self->has_attribute($attribute->name) ) {
825 $self->remove_attribute($attribute->name);
827 $self->invalidate_meta_instances();
830 # then onto installing the new accessors
831 $self->get_attribute_map->{$attribute->name} = $attribute;
833 # invalidate package flag here
834 my $e = do { local $@; eval { $attribute->install_accessors() }; $@ };
836 $self->remove_attribute($attribute->name);
843 sub update_meta_instance_dependencies {
846 if ( $self->{meta_instance_dependencies} ) {
847 return $self->add_meta_instance_dependencies;
851 sub add_meta_instance_dependencies {
854 $self->remove_meta_instance_dependencies;
856 my @attrs = $self->get_all_attributes();
859 my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
861 foreach my $class ( @classes ) {
862 $class->add_dependent_meta_instance($self);
865 $self->{meta_instance_dependencies} = \@classes;
868 sub remove_meta_instance_dependencies {
871 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
872 foreach my $class ( @$classes ) {
873 $class->remove_dependent_meta_instance($self);
883 sub add_dependent_meta_instance {
884 my ( $self, $metaclass ) = @_;
885 push @{ $self->{dependent_meta_instances} }, $metaclass;
888 sub remove_dependent_meta_instance {
889 my ( $self, $metaclass ) = @_;
890 my $name = $metaclass->name;
891 @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances};
894 sub invalidate_meta_instances {
896 $_->invalidate_meta_instance() for $self, @{ $self->{dependent_meta_instances} };
899 sub invalidate_meta_instance {
901 undef $self->{_meta_instance};
905 my ($self, $attribute_name) = @_;
906 (defined $attribute_name && $attribute_name)
907 || confess "You must define an attribute name";
908 exists $self->get_attribute_map->{$attribute_name};
912 my ($self, $attribute_name) = @_;
913 (defined $attribute_name && $attribute_name)
914 || confess "You must define an attribute name";
915 return $self->get_attribute_map->{$attribute_name}
917 # this will return undef anyway, so no need ...
918 # if $self->has_attribute($attribute_name);
922 sub remove_attribute {
923 my ($self, $attribute_name) = @_;
924 (defined $attribute_name && $attribute_name)
925 || confess "You must define an attribute name";
926 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
927 return unless defined $removed_attribute;
928 delete $self->get_attribute_map->{$attribute_name};
929 $self->invalidate_meta_instances();
930 $removed_attribute->remove_accessors();
931 $removed_attribute->detach_from_class();
932 return $removed_attribute;
935 sub get_attribute_list {
937 keys %{$self->get_attribute_map};
940 sub get_all_attributes {
942 my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa;
943 return values %attrs;
946 sub compute_all_applicable_attributes {
947 Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
948 . " Use get_all_attributes instead.\n");
950 shift->get_all_attributes(@_);
953 sub find_attribute_by_name {
954 my ($self, $attr_name) = @_;
955 foreach my $class ($self->linearized_isa) {
956 # fetch the meta-class ...
957 my $meta = $self->initialize($class);
958 return $meta->get_attribute($attr_name)
959 if $meta->has_attribute($attr_name);
964 # check if we can reinitialize
968 # if any local attr is defined
969 return if $self->get_attribute_list;
971 # or any non-declared methods
972 if ( my @methods = values %{ $self->get_method_map } ) {
973 my $metaclass = $self->method_metaclass;
974 foreach my $method ( @methods ) {
975 return if $method->isa("Class::MOP::Method::Generated");
976 # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
986 sub is_immutable { 0 }
987 sub immutable_transformer { return }
989 sub _immutable_options {
990 my ( $self, @args ) = @_;
993 inline_accessors => 1,
994 inline_constructor => 1,
995 inline_destructor => 0,
997 immutable_trait => $self->immutable_trait,
998 constructor_name => $self->constructor_name,
999 constructor_class => $self->constructor_class,
1000 destructor_class => $self->destructor_class,
1005 sub make_immutable {
1006 my ( $self, @args ) = @_;
1008 if ( $self->is_mutable ) {
1009 $self->_initialize_immutable( $self->_immutable_options(@args) );
1010 $self->_rebless_as_immutable(@args);
1021 if ( $self->is_immutable ) {
1022 my @args = $self->immutable_options;
1023 $self->_rebless_as_mutable();
1024 $self->_remove_inlined_code(@args);
1025 delete $self->{__immutable};
1033 sub _rebless_as_immutable {
1034 my ( $self, @args ) = @_;
1036 $self->{__immutable}{original_class} = ref $self;
1038 bless $self => $self->_immutable_metaclass(@args);
1041 sub _immutable_metaclass {
1042 my ( $self, %args ) = @_;
1044 if ( my $class = $args{immutable_metaclass} ) {
1048 my $trait = $args{immutable_trait} = $self->immutable_trait
1049 || confess "no immutable trait specified for $self";
1051 my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
1055 if ( $meta_attr and $trait eq $meta_attr->default ) {
1057 # if the trait is the same as the default we try and pick a predictable
1058 # name for the immutable metaclass
1059 $class_name = "Class::MOP::Class::Immutable::" . ref($self);
1063 = join( "::", "Class::MOP::Class::Immutable::CustomTrait", $trait,
1064 "ForMetaClass", ref($self) );
1067 if ( Class::MOP::is_class_loaded($class_name) ) {
1068 if ( $class_name->isa($trait) ) {
1073 "$class_name is already defined but does not inherit $trait";
1077 my @super = ( $trait, ref($self) );
1079 my $meta = Class::MOP::Class->initialize($class_name);
1080 $meta->superclasses(@super);
1082 $meta->make_immutable;
1088 sub _remove_inlined_code {
1091 $self->remove_method( $_->name ) for $self->_inlined_methods;
1093 delete $self->{__immutable}{inlined_methods};
1096 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1098 sub _add_inlined_method {
1099 my ( $self, $method ) = @_;
1101 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1104 sub _initialize_immutable {
1105 my ( $self, %args ) = @_;
1107 $self->{__immutable}{options} = \%args;
1108 $self->_install_inlined_code(%args);
1111 sub _install_inlined_code {
1112 my ( $self, %args ) = @_;
1115 $self->_inline_accessors(%args) if $args{inline_accessors};
1116 $self->_inline_constructor(%args) if $args{inline_constructor};
1117 $self->_inline_destructor(%args) if $args{inline_destructor};
1120 sub _rebless_as_mutable {
1123 bless $self, $self->get_mutable_metaclass_name;
1128 sub _inline_accessors {
1131 foreach my $attr_name ( $self->get_attribute_list ) {
1132 $self->get_attribute($attr_name)->install_accessors(1);
1136 sub _inline_constructor {
1137 my ( $self, %args ) = @_;
1139 my $name = $args{constructor_name};
1141 #if ( my $existing = $self->name->can($args{constructor_name}) ) {
1142 # if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) {
1144 unless ( $args{replace_constructor}
1145 or !$self->has_method($name) ) {
1146 my $class = $self->name;
1147 warn "Not inlining a constructor for $class since it defines"
1148 . " its own constructor.\n"
1149 . "If you are certain you don't need to inline your"
1150 . " constructor, specify inline_constructor => 0 in your"
1151 . " call to $class->meta->make_immutable\n";
1155 my $constructor_class = $args{constructor_class};
1157 Class::MOP::load_class($constructor_class);
1159 my $constructor = $constructor_class->new(
1163 package_name => $self->name,
1167 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1168 $self->add_method( $name => $constructor );
1169 $self->_add_inlined_method($constructor);
1173 sub _inline_destructor {
1174 my ( $self, %args ) = @_;
1176 ( exists $args{destructor_class} )
1177 || confess "The 'inline_destructor' option is present, but "
1178 . "no destructor class was specified";
1180 my $destructor_class = $args{destructor_class};
1182 Class::MOP::load_class($destructor_class);
1184 return unless $destructor_class->is_needed($self);
1186 my $destructor = $destructor_class->new(
1189 package_name => $self->name,
1193 $self->add_method( 'DESTROY' => $destructor );
1195 $self->_add_inlined_method($destructor);
1206 Class::MOP::Class - Class Meta Object
1210 # assuming that class Foo
1211 # has been defined, you can
1213 # use this for introspection ...
1215 # add a method to Foo ...
1216 Foo->meta->add_method( 'bar' => sub {...} )
1218 # get a list of all the classes searched
1219 # the method dispatcher in the correct order
1220 Foo->meta->class_precedence_list()
1222 # remove a method from Foo
1223 Foo->meta->remove_method('bar');
1225 # or use this to actually create classes ...
1227 Class::MOP::Class->create(
1230 superclasses => ['Foo'],
1232 Class::MOP::Attribute->new('$bar'),
1233 Class::MOP::Attribute->new('$baz'),
1236 calculate_bar => sub {...},
1237 construct_baz => sub {...}
1244 The Class Protocol is the largest and most complex part of the
1245 Class::MOP meta-object protocol. It controls the introspection and
1246 manipulation of Perl 5 classes, and it can create them as well. The
1247 best way to understand what this module can do, is to read the
1248 documentation for each of its methods.
1252 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1256 =head2 Class construction
1258 These methods all create new C<Class::MOP::Class> objects. These
1259 objects can represent existing classes, or they can be used to create
1260 new classes from scratch.
1262 The metaclass object for a given class is a singleton. If you attempt
1263 to create a metaclass for the same class twice, you will just get the
1268 =item B<< Class::MOP::Class->create($package_name, %options) >>
1270 This method creates a new C<Class::MOP::Class> object with the given
1271 package name. It accepts a number of options.
1277 An optional version number for the newly created package.
1281 An optional authority for the newly created package.
1283 =item * superclasses
1285 An optional array reference of superclass names.
1289 An optional hash reference of methods for the class. The keys of the
1290 hash reference are method names, and values are subroutine references.
1294 An optional array reference of attributes.
1296 An attribute can be passed as an existing L<Class::MOP::Attribute>
1297 object, I<or> or as a hash reference of options which will be passed
1298 to the attribute metaclass's constructor.
1302 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1304 This method works just like C<< Class::MOP::Class->create >> but it
1305 creates an "anonymous" class. In fact, the class does have a name, but
1306 that name is a unique name generated internally by this module.
1308 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1309 parameters that C<create> accepts.
1311 Anonymous classes are destroyed once the metaclass they are attached
1312 to goes out of scope, and will be removed from Perl's internal symbol
1315 All instances of an anonymous class keep a special reference to the
1316 metaclass object, which prevents the metaclass from going out of scope
1317 while any instances exist.
1319 This only works if the instance if based on a hash reference, however.
1321 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1323 This method will initialize a C<Class::MOP::Class> object for the
1324 named package. Unlike C<create>, this method I<will not> create a new
1327 The purpose of this method is to retrieve a C<Class::MOP::Class>
1328 object for introspecting an existing class.
1330 If an existing C<Class::MOP::Class> object exists for the named
1331 package, it will be returned, and any options provided will be
1334 If the object does not yet exist, it will be created.
1336 The valid options that can be passed to this method are
1337 C<attribute_metaclass>, C<method_metaclass>,
1338 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1339 optional, and default to the appropriate class in the C<Class::MOP>
1344 =head2 Object instance construction and cloning
1346 These methods are all related to creating and/or cloning object
1351 =item B<< $metaclass->clone_object($instance, %params) >>
1353 This method clones an existing object instance. Any parameters you
1354 provide are will override existing attribute values in the object.
1356 This is a convenience method for cloning an object instance, then
1357 blessing it into the appropriate package.
1359 You could implement a clone method in your class, using this method:
1362 my ($self, %params) = @_;
1363 $self->meta->clone_object($self, %params);
1366 =item B<< $metaclass->rebless_instance($instance, %params) >>
1368 This method changes the class of C<$instance> to the metaclass's class.
1370 You can only rebless an instance into a subclass of its current
1371 class. If you pass any additional parameters, these will be treated
1372 like constructor parameters and used to initialize the object's
1373 attributes. Any existing attributes that are already set will be
1376 Before reblessing the instance, this method will call
1377 C<rebless_instance_away> on the instance's current metaclass. This method
1378 will be passed the instance, the new metaclass, and any parameters
1379 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1380 does nothing; it is merely a hook.
1382 =item B<< $metaclass->new_object(%params) >>
1384 This method is used to create a new object of the metaclass's
1385 class. Any parameters you provide are used to initialize the
1386 instance's attributes.
1388 =item B<< $metaclass->instance_metaclass >>
1390 Returns the class name of the instance metaclass, see
1391 L<Class::MOP::Instance> for more information on the instance
1394 =item B<< $metaclass->get_meta_instance >>
1396 Returns an instance of the C<instance_metaclass> to be used in the
1397 construction of a new instance of the class.
1401 =head2 Informational predicates
1403 These are a few predicate methods for asking information about the
1408 =item B<< $metaclass->is_anon_class >>
1410 This returns true if the class was created by calling C<<
1411 Class::MOP::Class->create_anon_class >>.
1413 =item B<< $metaclass->is_mutable >>
1415 This returns true if the class is still mutable.
1417 =item B<< $metaclass->is_immutable >>
1419 This returns true if the class has been made immutable.
1421 =item B<< $metaclass->is_pristine >>
1423 A class is I<not> pristine if it has non-inherited attributes or if it
1424 has any generated methods.
1428 =head2 Inheritance Relationships
1432 =item B<< $metaclass->superclasses(@superclasses) >>
1434 This is a read-write accessor which represents the superclass
1435 relationships of the metaclass's class.
1437 This is basically sugar around getting and setting C<@ISA>.
1439 =item B<< $metaclass->class_precedence_list >>
1441 This returns a list of all of the class's ancestor classes. The
1442 classes are returned in method dispatch order.
1444 =item B<< $metaclass->linearized_isa >>
1446 This returns a list based on C<class_precedence_list> but with all
1449 =item B<< $metaclass->subclasses >>
1451 This returns a list of subclasses for this class.
1455 =head2 Method introspection and creation
1457 These methods allow you to introspect a class's methods, as well as
1458 add, remove, or change methods.
1460 Determining what is truly a method in a Perl 5 class requires some
1461 heuristics (aka guessing).
1463 Methods defined outside the package with a fully qualified name (C<sub
1464 Package::name { ... }>) will be included. Similarly, methods named
1465 with a fully qualified name using L<Sub::Name> are also included.
1467 However, we attempt to ignore imported functions.
1469 Ultimately, we are using heuristics to determine what truly is a
1470 method in a class, and these heuristics may get the wrong answer in
1471 some edge cases. However, for most "normal" cases the heuristics work
1476 =item B<< $metaclass->get_method($method_name) >>
1478 This will return a L<Class::MOP::Method> for the specified
1479 C<$method_name>. If the class does not have the specified method, it
1482 =item B<< $metaclass->has_method($method_name) >>
1484 Returns a boolean indicating whether or not the class defines the
1485 named method. It does not include methods inherited from parent
1488 =item B<< $metaclass->get_method_map >>
1490 Returns a hash reference representing the methods defined in this
1491 class. The keys are method names and the values are
1492 L<Class::MOP::Method> objects.
1494 =item B<< $metaclass->get_method_list >>
1496 This will return a list of method I<names> for all methods defined in
1499 =item B<< $metaclass->get_all_methods >>
1501 This will traverse the inheritance hierarchy and return a list of all
1502 the L<Class::MOP::Method> objects for this class and its parents.
1504 =item B<< $metaclass->find_method_by_name($method_name) >>
1506 This will return a L<Class::MOP::Method> for the specified
1507 C<$method_name>. If the class does not have the specified method, it
1510 Unlike C<get_method>, this method I<will> look for the named method in
1513 =item B<< $metaclass->get_all_method_names >>
1515 This will return a list of method I<names> for all of this class's
1516 methods, including inherited methods.
1518 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1520 This method looks for the named method in the class and all of its
1521 parents. It returns every matching method it finds in the inheritance
1522 tree, so it returns a list of methods.
1524 Each method is returned as a hash reference with three keys. The keys
1525 are C<name>, C<class>, and C<code>. The C<code> key has a
1526 L<Class::MOP::Method> object as its value.
1528 The list of methods is distinct.
1530 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1532 This method returns the first method in any superclass matching the
1533 given name. It is effectively the method that C<SUPER::$method_name>
1536 =item B<< $metaclass->add_method($method_name, $method) >>
1538 This method takes a method name and a subroutine reference, and adds
1539 the method to the class.
1541 The subroutine reference can be a L<Class::MOP::Method>, and you are
1542 strongly encouraged to pass a meta method object instead of a code
1543 reference. If you do so, that object gets stored as part of the
1544 class's method map directly. If not, the meta information will have to
1545 be recreated later, and may be incorrect.
1547 If you provide a method object, this method will clone that object if
1548 the object's package name does not match the class name. This lets us
1549 track the original source of any methods added from other classes
1550 (notably Moose roles).
1552 =item B<< $metaclass->remove_method($method_name) >>
1554 Remove the named method from the class. This method returns the
1555 L<Class::MOP::Method> object for the method.
1557 =item B<< $metaclass->method_metaclass >>
1559 Returns the class name of the method metaclass, see
1560 L<Class::MOP::Method> for more information on the method metaclass.
1562 =item B<< $metaclass->wrapped_method_metaclass >>
1564 Returns the class name of the wrapped method metaclass, see
1565 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1570 =head2 Attribute introspection and creation
1572 Because Perl 5 does not have a core concept of attributes in classes,
1573 we can only return information about attributes which have been added
1574 via this class's methods. We cannot discover information about
1575 attributes which are defined in terms of "regular" Perl 5 methods.
1579 =item B<< $metaclass->get_attribute($attribute_name) >>
1581 This will return a L<Class::MOP::Attribute> for the specified
1582 C<$attribute_name>. If the class does not have the specified
1583 attribute, it returns C<undef>
1585 =item B<< $metaclass->has_attribute($attribute_name) >>
1587 Returns a boolean indicating whether or not the class defines the
1588 named attribute. It does not include attributes inherited from parent
1591 =item B<< $metaclass->get_attribute_map >>
1593 Returns a hash reference representing the attributes defined in this
1594 class. The keys are attribute names and the values are
1595 L<Class::MOP::Attribute> objects.
1597 =item B<< $metaclass->get_attribute_list >>
1599 This will return a list of attributes I<names> for all attributes
1600 defined in this class.
1602 =item B<< $metaclass->get_all_attributes >>
1604 This will traverse the inheritance hierarchy and return a list of all
1605 the L<Class::MOP::Attribute> objects for this class and its parents.
1607 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1609 This will return a L<Class::MOP::Attribute> for the specified
1610 C<$attribute_name>. If the class does not have the specified
1611 attribute, it returns C<undef>
1613 Unlike C<get_attribute>, this attribute I<will> look for the named
1614 attribute in superclasses.
1616 =item B<< $metaclass->add_attribute(...) >>
1618 This method accepts either an existing L<Class::MOP::Attribute>
1619 object, or parameters suitable for passing to that class's C<new>
1622 The attribute provided will be added to the class.
1624 Any accessor methods defined by the attribute will be added to the
1625 class when the attribute is added.
1627 If an attribute of the same name already exists, the old attribute
1628 will be removed first.
1630 =item B<< $metaclass->remove_attribute($attribute_name) >>
1632 This will remove the named attribute from the class, and
1633 L<Class::MOP::Attribute> object.
1635 Removing an attribute also removes any accessor methods defined by the
1638 However, note that removing an attribute will only affect I<future>
1639 object instances created for this class, not existing instances.
1641 =item B<< $metaclass->attribute_metaclass >>
1643 Returns the class name of the attribute metaclass for this class. By
1644 default, this is L<Class::MOP::Attribute>. for more information on
1648 =head2 Class Immutability
1650 Making a class immutable "freezes" the class definition. You can no
1651 longer call methods which alter the class, such as adding or removing
1652 methods or attributes.
1654 Making a class immutable lets us optimize the class by inlining some
1655 methods, and also allows us to optimize some methods on the metaclass
1658 The immutabilization system in L<Moose> takes much greater advantage
1659 of the inlining features than Class::MOP itself does.
1663 =item B<< $metaclass->make_immutable(%options) >>
1665 This method will create an immutable transformer and uses it to make
1666 the class and its metaclass object immutable.
1668 Details of how immutabilization works are in L<Class::MOP::Immutable>
1671 =item B<< $metaclass->make_mutable >>
1673 Calling this method reverse the immutabilization transformation.
1675 =item B<< $metaclass->immutable_transformer >>
1677 If the class has been made immutable previously, this returns the
1678 L<Class::MOP::Immutable> object that was created to do the
1681 If the class was never made immutable, this method will die.
1685 =head2 Method Modifiers
1687 Method modifiers are hooks which allow a method to be wrapped with
1688 I<before>, I<after> and I<around> method modifiers. Every time a
1689 method is called, it's modifiers are also called.
1691 A class can modify its own methods, as well as methods defined in
1694 =head3 How method modifiers work?
1696 Method modifiers work by wrapping the original method and then
1697 replacing it in the class's symbol table. The wrappers will handle
1698 calling all the modifiers in the appropriate order and preserving the
1699 calling context for the original method.
1701 The return values of C<before> and C<after> modifiers are
1702 ignored. This is because their purpose is B<not> to filter the input
1703 and output of the primary method (this is done with an I<around>
1706 This may seem like an odd restriction to some, but doing this allows
1707 for simple code to be added at the beginning or end of a method call
1708 without altering the function of the wrapped method or placing any
1709 extra responsibility on the code of the modifier.
1711 Of course if you have more complex needs, you can use the C<around>
1712 modifier which allows you to change both the parameters passed to the
1713 wrapped method, as well as its return value.
1715 Before and around modifiers are called in last-defined-first-called
1716 order, while after modifiers are called in first-defined-first-called
1717 order. So the call tree might looks something like this:
1729 =head3 What is the performance impact?
1731 Of course there is a performance cost associated with method
1732 modifiers, but we have made every effort to make that cost directly
1733 proportional to the number of modifier features you utilize.
1735 The wrapping method does it's best to B<only> do as much work as it
1736 absolutely needs to. In order to do this we have moved some of the
1737 performance costs to set-up time, where they are easier to amortize.
1739 All this said, our benchmarks have indicated the following:
1741 simple wrapper with no modifiers 100% slower
1742 simple wrapper with simple before modifier 400% slower
1743 simple wrapper with simple after modifier 450% slower
1744 simple wrapper with simple around modifier 500-550% slower
1745 simple wrapper with all 3 modifiers 1100% slower
1747 These numbers may seem daunting, but you must remember, every feature
1748 comes with some cost. To put things in perspective, just doing a
1749 simple C<AUTOLOAD> which does nothing but extract the name of the
1750 method called and return it costs about 400% over a normal method
1755 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
1757 This wraps the specified method with the supplied subroutine
1758 reference. The modifier will be called as a method itself, and will
1759 receive the same arguments as are passed to the method.
1761 When the modifier exits, the wrapped method will be called.
1763 The return value of the modifier will be ignored.
1765 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
1767 This wraps the specified method with the supplied subroutine
1768 reference. The modifier will be called as a method itself, and will
1769 receive the same arguments as are passed to the method.
1771 When the wrapped methods exits, the modifier will be called.
1773 The return value of the modifier will be ignored.
1775 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
1777 This wraps the specified method with the supplied subroutine
1780 The first argument passed to the modifier will be a subroutine
1781 reference to the wrapped method. The second argument is the object,
1782 and after that come any arguments passed when the method is called.
1784 The around modifier can choose to call the original method, as well as
1785 what arguments to pass if it does so.
1787 The return value of the modifier is what will be seen by the caller.
1791 =head2 Introspection
1795 =item B<< Class::MOP::Class->meta >>
1797 This will return a L<Class::MOP::Class> instance for this class.
1799 It should also be noted that L<Class::MOP> will actually bootstrap
1800 this module by installing a number of attribute meta-objects into its
1807 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1809 =head1 COPYRIGHT AND LICENSE
1811 Copyright 2006-2009 by Infinity Interactive, Inc.
1813 L<http://www.iinteractive.com>
1815 This library is free software; you can redistribute it and/or modify
1816 it under the same terms as Perl itself.