2 package Class::MOP::Class;
7 use Class::MOP::Instance;
8 use Class::MOP::Method::Wrapped;
11 use Scalar::Util 'blessed', 'reftype', 'weaken';
12 use Sub::Name 'subname';
13 use B 'svref_2object';
15 our $VERSION = '0.21';
16 our $AUTHORITY = 'cpan:STEVAN';
18 use base 'Class::MOP::Module';
22 sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
28 my $package_name = shift;
29 (defined $package_name && $package_name && !blessed($package_name))
30 || confess "You must pass a package name and it cannot be blessed";
31 $class->construct_class_instance(':package' => $package_name, @_);
36 my $package_name = shift;
37 (defined $package_name && $package_name && !blessed($package_name))
38 || confess "You must pass a package name and it cannot be blessed";
39 Class::MOP::remove_metaclass_by_name($package_name);
40 $class->construct_class_instance(':package' => $package_name, @_);
43 # NOTE: (meta-circularity)
44 # this is a special form of &construct_instance
45 # (see below), which is used to construct class
46 # meta-object instances for any Class::MOP::*
47 # class. All other classes will use the more
48 # normal &construct_instance.
49 sub construct_class_instance {
52 my $package_name = $options{':package'};
53 (defined $package_name && $package_name)
54 || confess "You must pass a package name";
56 # return the metaclass if we have it cached,
57 # and it is still defined (it has not been
58 # reaped by DESTROY yet, which can happen
59 # annoyingly enough during global destruction)
60 return Class::MOP::get_metaclass_by_name($package_name)
61 if Class::MOP::does_metaclass_exist($package_name);
64 # we need to deal with the possibility
65 # of class immutability here, and then
66 # get the name of the class appropriately
67 $class = (blessed($class)
68 ? ($class->is_immutable
69 ? $class->get_mutable_metaclass_name()
73 $class = blessed($class) || $class;
74 # now create the metaclass
76 if ($class =~ /^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
98 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
99 '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
100 '$:instance_metaclass' => $options{':instance_metaclass'} || 'Class::MOP::Instance',
105 # it is safe to use meta here because
106 # class will always be a subclass of
107 # Class::MOP::Class, which defines meta
108 $meta = $class->meta->construct_instance(%options)
111 # and check the metaclass compatibility
112 $meta->check_metaclass_compatability();
114 Class::MOP::store_metaclass_by_name($package_name, $meta);
117 # we need to weaken any anon classes
118 # so that they can call DESTROY properly
119 Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class;
124 sub check_metaclass_compatability {
127 # this is always okay ...
128 return if blessed($self) eq 'Class::MOP::Class' &&
129 $self->instance_metaclass eq 'Class::MOP::Instance';
131 my @class_list = $self->class_precedence_list;
132 shift @class_list; # shift off $self->name
134 foreach my $class_name (@class_list) {
135 my $meta = Class::MOP::get_metaclass_by_name($class_name) || next;
138 # we need to deal with the possibility
139 # of class immutability here, and then
140 # get the name of the class appropriately
141 my $meta_type = ($meta->is_immutable
142 ? $meta->get_mutable_metaclass_name()
145 ($self->isa($meta_type))
146 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
147 " is not compatible with the " .
148 $class_name . "->meta => (" . ($meta_type) . ")";
150 # we also need to check that instance metaclasses
151 # are compatabile in the same the class.
152 ($self->instance_metaclass->isa($meta->instance_metaclass))
153 || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" .
154 " is not compatible with the " .
155 $class_name . "->meta => (" . ($meta->instance_metaclass) . ")";
163 # this should be sufficient, if you have a
164 # use case where it is not, write a test and
166 my $ANON_CLASS_SERIAL = 0;
169 # we need a sufficiently annoying prefix
170 # this should suffice for now, this is
171 # used in a couple of places below, so
172 # need to put it up here for now.
173 my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
177 no warnings 'uninitialized';
178 $self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0;
181 sub create_anon_class {
182 my ($class, %options) = @_;
183 my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
184 return $class->create($package_name, %options);
188 # this will only get called for
189 # anon-classes, all other calls
190 # are assumed to occur during
191 # global destruction and so don't
192 # really need to be handled explicitly
195 no warnings 'uninitialized';
196 return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
197 my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
199 foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
200 delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
202 delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
207 # creating classes with MOP ...
211 my $package_name = shift;
213 (defined $package_name && $package_name)
214 || confess "You must pass a package name";
217 || confess "You much pass all parameters as name => value pairs " .
218 "(I found an uneven number of params in \@_)";
222 my $code = "package $package_name;";
223 $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
224 if exists $options{version};
225 $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
226 if exists $options{authority};
229 confess "creation of $package_name failed : $@" if $@;
231 my $meta = $class->initialize($package_name);
233 $meta->add_method('meta' => sub {
234 $class->initialize(blessed($_[0]) || $_[0]);
237 $meta->superclasses(@{$options{superclasses}})
238 if exists $options{superclasses};
240 # process attributes first, so that they can
241 # install accessors, but locally defined methods
242 # can then overwrite them. It is maybe a little odd, but
243 # I think this should be the order of things.
244 if (exists $options{attributes}) {
245 foreach my $attr (@{$options{attributes}}) {
246 $meta->add_attribute($attr);
249 if (exists $options{methods}) {
250 foreach my $method_name (keys %{$options{methods}}) {
251 $meta->add_method($method_name, $options{methods}->{$method_name});
260 # all these attribute readers will be bootstrapped
261 # away in the Class::MOP bootstrap section
263 sub get_attribute_map { $_[0]->{'%:attributes'} }
264 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
265 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
266 sub instance_metaclass { $_[0]->{'$:instance_metaclass'} }
269 # this is a prime canidate for conversion to XS
272 my $map = $self->{'%:methods'};
274 my $class_name = $self->name;
275 my $method_metaclass = $self->method_metaclass;
277 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
278 my $code = $self->get_package_symbol('&' . $symbol);
280 next if exists $map->{$symbol} &&
281 defined $map->{$symbol} &&
282 $map->{$symbol}->body == $code;
284 my $gv = svref_2object($code)->GV;
285 next if ($gv->STASH->NAME || '') ne $class_name &&
286 ($gv->NAME || '') ne '__ANON__';
288 $map->{$symbol} = $method_metaclass->wrap($code);
294 # Instance Construction & Cloning
299 # we need to protect the integrity of the
300 # Class::MOP::Class singletons here, so we
301 # delegate this to &construct_class_instance
302 # which will deal with the singletons
303 return $class->construct_class_instance(@_)
304 if $class->name->isa('Class::MOP::Class');
305 return $class->construct_instance(@_);
308 sub construct_instance {
309 my ($class, %params) = @_;
310 my $meta_instance = $class->get_meta_instance();
311 my $instance = $meta_instance->create_instance();
312 foreach my $attr ($class->compute_all_applicable_attributes()) {
313 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
318 sub get_meta_instance {
320 return $class->instance_metaclass->new(
322 $class->compute_all_applicable_attributes()
328 my $instance = shift;
329 (blessed($instance) && $instance->isa($class->name))
330 || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
332 # we need to protect the integrity of the
333 # Class::MOP::Class singletons here, they
334 # should not be cloned.
335 return $instance if $instance->isa('Class::MOP::Class');
336 $class->clone_instance($instance, @_);
340 my ($class, $instance, %params) = @_;
342 || confess "You can only clone instances, \$self is not a blessed instance";
343 my $meta_instance = $class->get_meta_instance();
344 my $clone = $meta_instance->clone_instance($instance);
345 foreach my $key (keys %params) {
346 next unless $meta_instance->is_valid_slot($key);
347 $meta_instance->set_slot_value($clone, $key, $params{$key});
358 @{$self->get_package_symbol('@ISA')} = @supers;
360 # we need to check the metaclass
361 # compatability here so that we can
362 # be sure that the superclass is
363 # not potentially creating an issues
364 # we don't know about
365 $self->check_metaclass_compatability();
367 @{$self->get_package_symbol('@ISA')};
370 sub class_precedence_list {
373 # We need to check for ciruclar inheirtance here.
374 # This will do nothing if all is well, and blow
375 # up otherwise. Yes, it's an ugly hack, better
376 # suggestions are welcome.
377 { ($self->name || return)->isa('This is a test for circular inheritance') }
378 # ... and now back to our regularly scheduled program
382 $self->initialize($_)->class_precedence_list()
383 } $self->superclasses()
390 my ($self, $method_name, $method) = @_;
391 (defined $method_name && $method_name)
392 || confess "You must define a method name";
395 if (blessed($method)) {
396 $body = $method->body;
400 ('CODE' eq (reftype($body) || ''))
401 || confess "Your code block must be a CODE reference";
402 $method = $self->method_metaclass->wrap($body);
404 $self->get_method_map->{$method_name} = $method;
406 my $full_method_name = ($self->name . '::' . $method_name);
407 $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body);
411 my $fetch_and_prepare_method = sub {
412 my ($self, $method_name) = @_;
414 my $method = $self->get_method($method_name);
415 # if we dont have local ...
417 # try to find the next method
418 $method = $self->find_next_method_by_name($method_name);
419 # die if it does not exist
421 || confess "The method '$method_name' is not found in the inherience hierarchy for class " . $self->name;
422 # and now make sure to wrap it
423 # even if it is already wrapped
424 # because we need a new sub ref
425 $method = Class::MOP::Method::Wrapped->wrap($method);
428 # now make sure we wrap it properly
429 $method = Class::MOP::Method::Wrapped->wrap($method)
430 unless $method->isa('Class::MOP::Method::Wrapped');
432 $self->add_method($method_name => $method);
436 sub add_before_method_modifier {
437 my ($self, $method_name, $method_modifier) = @_;
438 (defined $method_name && $method_name)
439 || confess "You must pass in a method name";
440 my $method = $fetch_and_prepare_method->($self, $method_name);
441 $method->add_before_modifier(subname ':before' => $method_modifier);
444 sub add_after_method_modifier {
445 my ($self, $method_name, $method_modifier) = @_;
446 (defined $method_name && $method_name)
447 || confess "You must pass in a method name";
448 my $method = $fetch_and_prepare_method->($self, $method_name);
449 $method->add_after_modifier(subname ':after' => $method_modifier);
452 sub add_around_method_modifier {
453 my ($self, $method_name, $method_modifier) = @_;
454 (defined $method_name && $method_name)
455 || confess "You must pass in a method name";
456 my $method = $fetch_and_prepare_method->($self, $method_name);
457 $method->add_around_modifier(subname ':around' => $method_modifier);
461 # the methods above used to be named like this:
462 # ${pkg}::${method}:(before|after|around)
463 # but this proved problematic when using one modifier
464 # to wrap multiple methods (something which is likely
465 # to happen pretty regularly IMO). So instead of naming
466 # it like this, I have chosen to just name them purely
467 # with their modifier names, like so:
468 # :(before|after|around)
469 # The fact is that in a stack trace, it will be fairly
470 # evident from the context what method they are attached
471 # to, and so don't need the fully qualified name.
475 my ($self, $method_name, $method) = @_;
476 (defined $method_name && $method_name)
477 || confess "You must define a method name";
479 my $body = (blessed($method) ? $method->body : $method);
480 ('CODE' eq (reftype($body) || ''))
481 || confess "Your code block must be a CODE reference";
483 $self->add_package_symbol("&${method_name}" => $body);
487 my ($self, $method_name) = @_;
488 (defined $method_name && $method_name)
489 || confess "You must define a method name";
491 return 0 unless exists $self->get_method_map->{$method_name};
496 my ($self, $method_name) = @_;
497 (defined $method_name && $method_name)
498 || confess "You must define a method name";
501 # I don't really need this here, because
502 # if the method_map is missing a key it
503 # will just return undef for me now
504 # return unless $self->has_method($method_name);
506 return $self->get_method_map->{$method_name};
510 my ($self, $method_name) = @_;
511 (defined $method_name && $method_name)
512 || confess "You must define a method name";
514 my $removed_method = $self->get_method($method_name);
517 $self->remove_package_symbol("&${method_name}");
518 delete $self->get_method_map->{$method_name};
519 } if defined $removed_method;
521 return $removed_method;
524 sub get_method_list {
526 keys %{$self->get_method_map};
529 sub find_method_by_name {
530 my ($self, $method_name) = @_;
531 (defined $method_name && $method_name)
532 || confess "You must define a method name to find";
533 # keep a record of what we have seen
534 # here, this will handle all the
535 # inheritence issues because we are
536 # using the &class_precedence_list
538 my @cpl = $self->class_precedence_list();
539 foreach my $class (@cpl) {
540 next if $seen_class{$class};
541 $seen_class{$class}++;
542 # fetch the meta-class ...
543 my $meta = $self->initialize($class);
544 return $meta->get_method($method_name)
545 if $meta->has_method($method_name);
550 sub compute_all_applicable_methods {
553 # keep a record of what we have seen
554 # here, this will handle all the
555 # inheritence issues because we are
556 # using the &class_precedence_list
557 my (%seen_class, %seen_method);
558 foreach my $class ($self->class_precedence_list()) {
559 next if $seen_class{$class};
560 $seen_class{$class}++;
561 # fetch the meta-class ...
562 my $meta = $self->initialize($class);
563 foreach my $method_name ($meta->get_method_list()) {
564 next if exists $seen_method{$method_name};
565 $seen_method{$method_name}++;
567 name => $method_name,
569 code => $meta->get_method($method_name)
576 sub find_all_methods_by_name {
577 my ($self, $method_name) = @_;
578 (defined $method_name && $method_name)
579 || confess "You must define a method name to find";
581 # keep a record of what we have seen
582 # here, this will handle all the
583 # inheritence issues because we are
584 # using the &class_precedence_list
586 foreach my $class ($self->class_precedence_list()) {
587 next if $seen_class{$class};
588 $seen_class{$class}++;
589 # fetch the meta-class ...
590 my $meta = $self->initialize($class);
592 name => $method_name,
594 code => $meta->get_method($method_name)
595 } if $meta->has_method($method_name);
600 sub find_next_method_by_name {
601 my ($self, $method_name) = @_;
602 (defined $method_name && $method_name)
603 || confess "You must define a method name to find";
604 # keep a record of what we have seen
605 # here, this will handle all the
606 # inheritence issues because we are
607 # using the &class_precedence_list
609 my @cpl = $self->class_precedence_list();
610 shift @cpl; # discard ourselves
611 foreach my $class (@cpl) {
612 next if $seen_class{$class};
613 $seen_class{$class}++;
614 # fetch the meta-class ...
615 my $meta = $self->initialize($class);
616 return $meta->get_method($method_name)
617 if $meta->has_method($method_name);
626 # either we have an attribute object already
627 # or we need to create one from the args provided
628 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
629 # make sure it is derived from the correct type though
630 ($attribute->isa('Class::MOP::Attribute'))
631 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
633 # first we attach our new attribute
634 # because it might need certain information
635 # about the class which it is attached to
636 $attribute->attach_to_class($self);
638 # then we remove attributes of a conflicting
639 # name here so that we can properly detach
640 # the old attr object, and remove any
641 # accessors it would have generated
642 $self->remove_attribute($attribute->name)
643 if $self->has_attribute($attribute->name);
645 # then onto installing the new accessors
646 $attribute->install_accessors();
647 $self->get_attribute_map->{$attribute->name} = $attribute;
651 my ($self, $attribute_name) = @_;
652 (defined $attribute_name && $attribute_name)
653 || confess "You must define an attribute name";
654 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
658 my ($self, $attribute_name) = @_;
659 (defined $attribute_name && $attribute_name)
660 || confess "You must define an attribute name";
661 return $self->get_attribute_map->{$attribute_name}
663 # this will return undef anyway, so no need ...
664 # if $self->has_attribute($attribute_name);
668 sub remove_attribute {
669 my ($self, $attribute_name) = @_;
670 (defined $attribute_name && $attribute_name)
671 || confess "You must define an attribute name";
672 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
673 return unless defined $removed_attribute;
674 delete $self->get_attribute_map->{$attribute_name};
675 $removed_attribute->remove_accessors();
676 $removed_attribute->detach_from_class();
677 return $removed_attribute;
680 sub get_attribute_list {
682 keys %{$self->get_attribute_map};
685 sub compute_all_applicable_attributes {
688 # keep a record of what we have seen
689 # here, this will handle all the
690 # inheritence issues because we are
691 # using the &class_precedence_list
692 my (%seen_class, %seen_attr);
693 foreach my $class ($self->class_precedence_list()) {
694 next if $seen_class{$class};
695 $seen_class{$class}++;
696 # fetch the meta-class ...
697 my $meta = $self->initialize($class);
698 foreach my $attr_name ($meta->get_attribute_list()) {
699 next if exists $seen_attr{$attr_name};
700 $seen_attr{$attr_name}++;
701 push @attrs => $meta->get_attribute($attr_name);
707 sub find_attribute_by_name {
708 my ($self, $attr_name) = @_;
709 # keep a record of what we have seen
710 # here, this will handle all the
711 # inheritence issues because we are
712 # using the &class_precedence_list
714 foreach my $class ($self->class_precedence_list()) {
715 next if $seen_class{$class};
716 $seen_class{$class}++;
717 # fetch the meta-class ...
718 my $meta = $self->initialize($class);
719 return $meta->get_attribute($attr_name)
720 if $meta->has_attribute($attr_name);
728 sub is_immutable { 0 }
731 return Class::MOP::Class::Immutable->make_metaclass_immutable(@_);
742 Class::MOP::Class - Class Meta Object
746 # assuming that class Foo
747 # has been defined, you can
749 # use this for introspection ...
751 # add a method to Foo ...
752 Foo->meta->add_method('bar' => sub { ... })
754 # get a list of all the classes searched
755 # the method dispatcher in the correct order
756 Foo->meta->class_precedence_list()
758 # remove a method from Foo
759 Foo->meta->remove_method('bar');
761 # or use this to actually create classes ...
763 Class::MOP::Class->create('Bar' => (
765 superclasses => [ 'Foo' ],
767 Class::MOP:::Attribute->new('$bar'),
768 Class::MOP:::Attribute->new('$baz'),
771 calculate_bar => sub { ... },
772 construct_baz => sub { ... }
778 This is the largest and currently most complex part of the Perl 5
779 meta-object protocol. It controls the introspection and
780 manipulation of Perl 5 classes (and it can create them too). The
781 best way to understand what this module can do, is to read the
782 documentation for each of it's methods.
786 =head2 Self Introspection
792 This will return a B<Class::MOP::Class> instance which is related
793 to this class. Thereby allowing B<Class::MOP::Class> to actually
796 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
797 bootstrap this module by installing a number of attribute meta-objects
798 into it's metaclass. This will allow this class to reap all the benifits
799 of the MOP when subclassing it.
803 =head2 Class construction
805 These methods will handle creating B<Class::MOP::Class> objects,
806 which can be used to both create new classes, and analyze
807 pre-existing classes.
809 This module will internally store references to all the instances
810 you create with these methods, so that they do not need to be
811 created any more than nessecary. Basically, they are singletons.
815 =item B<create ($package_name,
816 version =E<gt> ?$version,
817 authority =E<gt> ?$authority,
818 superclasses =E<gt> ?@superclasses,
819 methods =E<gt> ?%methods,
820 attributes =E<gt> ?%attributes)>
822 This returns a B<Class::MOP::Class> object, bringing the specified
823 C<$package_name> into existence and adding any of the C<$version>,
824 C<$authority>, C<@superclasses>, C<%methods> and C<%attributes> to
827 =item B<create_anon_class (superclasses =E<gt> ?@superclasses,
828 methods =E<gt> ?%methods,
829 attributes =E<gt> ?%attributes)>
831 This will create an anonymous class, it works much like C<create> but
832 it does not need a C<$package_name>. Instead it will create a suitably
833 unique package name for you to stash things into.
835 =item B<initialize ($package_name, %options)>
837 This initializes and returns returns a B<Class::MOP::Class> object
838 for a given a C<$package_name>.
840 =item B<reinitialize ($package_name, %options)>
842 This removes the old metaclass, and creates a new one in it's place.
843 Do B<not> use this unless you really know what you are doing, it could
844 very easily make a very large mess of your program.
846 =item B<construct_class_instance (%options)>
848 This will construct an instance of B<Class::MOP::Class>, it is
849 here so that we can actually "tie the knot" for B<Class::MOP::Class>
850 to use C<construct_instance> once all the bootstrapping is done. This
851 method is used internally by C<initialize> and should never be called
852 from outside of that method really.
854 =item B<check_metaclass_compatability>
856 This method is called as the very last thing in the
857 C<construct_class_instance> method. This will check that the
858 metaclass you are creating is compatible with the metaclasses of all
859 your ancestors. For more inforamtion about metaclass compatibility
860 see the C<About Metaclass compatibility> section in L<Class::MOP>.
864 =head2 Object instance construction and cloning
866 These methods are B<entirely optional>, it is up to you whether you want
871 =item B<instance_metaclass>
873 =item B<get_meta_instance>
875 =item B<new_object (%params)>
877 This is a convience method for creating a new object of the class, and
878 blessing it into the appropriate package as well. Ideally your class
879 would call a C<new> this method like so:
882 my ($class, %param) = @_;
883 $class->meta->new_object(%params);
886 Of course the ideal place for this would actually be in C<UNIVERSAL::>
887 but that is considered bad style, so we do not do that.
889 =item B<construct_instance (%params)>
891 This method is used to construct an instace structure suitable for
892 C<bless>-ing into your package of choice. It works in conjunction
893 with the Attribute protocol to collect all applicable attributes.
895 This will construct and instance using a HASH ref as storage
896 (currently only HASH references are supported). This will collect all
897 the applicable attributes and layout out the fields in the HASH ref,
898 it will then initialize them using either use the corresponding key
899 in C<%params> or any default value or initializer found in the
900 attribute meta-object.
902 =item B<clone_object ($instance, %params)>
904 This is a convience method for cloning an object instance, then
905 blessing it into the appropriate package. This method will call
906 C<clone_instance>, which performs a shallow copy of the object,
907 see that methods documentation for more details. Ideally your
908 class would call a C<clone> this method like so:
911 my ($self, %param) = @_;
912 $self->meta->clone_object($self, %params);
915 Of course the ideal place for this would actually be in C<UNIVERSAL::>
916 but that is considered bad style, so we do not do that.
918 =item B<clone_instance($instance, %params)>
920 This method is a compliment of C<construct_instance> (which means if
921 you override C<construct_instance>, you need to override this one too),
922 and clones the instance shallowly.
924 The cloned structure returned is (like with C<construct_instance>) an
925 unC<bless>ed HASH reference, it is your responsibility to then bless
926 this cloned structure into the right class (which C<clone_object> will
929 As of 0.11, this method will clone the C<$instance> structure shallowly,
930 as opposed to the deep cloning implemented in prior versions. After much
931 thought, research and discussion, I have decided that anything but basic
932 shallow cloning is outside the scope of the meta-object protocol. I
933 think Yuval "nothingmuch" Kogman put it best when he said that cloning
934 is too I<context-specific> to be part of the MOP.
940 These are a few predicate methods for asking information about the class.
944 =item B<is_anon_class>
948 =item B<is_immutable>
952 =head2 Inheritance Relationships
956 =item B<superclasses (?@superclasses)>
958 This is a read-write attribute which represents the superclass
959 relationships of the class the B<Class::MOP::Class> instance is
960 associated with. Basically, it can get and set the C<@ISA> for you.
963 Perl will occasionally perform some C<@ISA> and method caching, if
964 you decide to change your superclass relationship at runtime (which
965 is quite insane and very much not recommened), then you should be
966 aware of this and the fact that this module does not make any
967 attempt to address this issue.
969 =item B<class_precedence_list>
971 This computes the a list of all the class's ancestors in the same order
972 in which method dispatch will be done. This is similair to
973 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
981 =item B<get_method_map>
983 =item B<method_metaclass>
985 =item B<add_method ($method_name, $method)>
987 This will take a C<$method_name> and CODE reference to that
988 C<$method> and install it into the class's package.
991 This does absolutely nothing special to C<$method>
992 other than use B<Sub::Name> to make sure it is tagged with the
993 correct name, and therefore show up correctly in stack traces and
996 =item B<alias_method ($method_name, $method)>
998 This will take a C<$method_name> and CODE reference to that
999 C<$method> and alias the method into the class's package.
1002 Unlike C<add_method>, this will B<not> try to name the
1003 C<$method> using B<Sub::Name>, it only aliases the method in
1004 the class's package.
1006 =item B<has_method ($method_name)>
1008 This just provides a simple way to check if the class implements
1009 a specific C<$method_name>. It will I<not> however, attempt to check
1010 if the class inherits the method (use C<UNIVERSAL::can> for that).
1012 This will correctly handle functions defined outside of the package
1013 that use a fully qualified name (C<sub Package::name { ... }>).
1015 This will correctly handle functions renamed with B<Sub::Name> and
1016 installed using the symbol tables. However, if you are naming the
1017 subroutine outside of the package scope, you must use the fully
1018 qualified name, including the package name, for C<has_method> to
1019 correctly identify it.
1021 This will attempt to correctly ignore functions imported from other
1022 packages using B<Exporter>. It breaks down if the function imported
1023 is an C<__ANON__> sub (such as with C<use constant>), which very well
1024 may be a valid method being applied to the class.
1026 In short, this method cannot always be trusted to determine if the
1027 C<$method_name> is actually a method. However, it will DWIM about
1028 90% of the time, so it's a small trade off I think.
1030 =item B<get_method ($method_name)>
1032 This will return a Class::MOP::Method instance related to the specified
1033 C<$method_name>, or return undef if that method does not exist.
1035 The Class::MOP::Method is codifiable, so you can use it like a normal
1036 CODE reference, see L<Class::MOP::Method> for more information.
1038 =item B<find_method_by_name ($method_name>
1040 This will return a CODE reference of the specified C<$method_name>,
1041 or return undef if that method does not exist.
1043 Unlike C<get_method> this will also look in the superclasses.
1045 =item B<remove_method ($method_name)>
1047 This will attempt to remove a given C<$method_name> from the class.
1048 It will return the CODE reference that it has removed, and will
1049 attempt to use B<Sub::Name> to clear the methods associated name.
1051 =item B<get_method_list>
1053 This will return a list of method names for all I<locally> defined
1054 methods. It does B<not> provide a list of all applicable methods,
1055 including any inherited ones. If you want a list of all applicable
1056 methods, use the C<compute_all_applicable_methods> method.
1058 =item B<compute_all_applicable_methods>
1060 This will return a list of all the methods names this class will
1061 respond to, taking into account inheritance. The list will be a list of
1062 HASH references, each one containing the following information; method
1063 name, the name of the class in which the method lives and a CODE
1064 reference for the actual method.
1066 =item B<find_all_methods_by_name ($method_name)>
1068 This will traverse the inheritence hierarchy and locate all methods
1069 with a given C<$method_name>. Similar to
1070 C<compute_all_applicable_methods> it returns a list of HASH references
1071 with the following information; method name (which will always be the
1072 same as C<$method_name>), the name of the class in which the method
1073 lives and a CODE reference for the actual method.
1075 The list of methods produced is a distinct list, meaning there are no
1076 duplicates in it. This is especially useful for things like object
1077 initialization and destruction where you only want the method called
1078 once, and in the correct order.
1080 =item B<find_next_method_by_name ($method_name)>
1082 This will return the first method to match a given C<$method_name> in
1083 the superclasses, this is basically equivalent to calling
1084 C<SUPER::$method_name>, but it can be dispatched at runtime.
1088 =head2 Method Modifiers
1090 Method modifiers are a concept borrowed from CLOS, in which a method
1091 can be wrapped with I<before>, I<after> and I<around> method modifiers
1092 that will be called everytime the method is called.
1094 =head3 How method modifiers work?
1096 Method modifiers work by wrapping the original method and then replacing
1097 it in the classes symbol table. The wrappers will handle calling all the
1098 modifiers in the appropariate orders and preserving the calling context
1099 for the original method.
1101 Each method modifier serves a particular purpose, which may not be
1102 obvious to users of other method wrapping modules. To start with, the
1103 return values of I<before> and I<after> modifiers are ignored. This is
1104 because thier purpose is B<not> to filter the input and output of the
1105 primary method (this is done with an I<around> modifier). This may seem
1106 like an odd restriction to some, but doing this allows for simple code
1107 to be added at the begining or end of a method call without jeapordizing
1108 the normal functioning of the primary method or placing any extra
1109 responsibility on the code of the modifier. Of course if you have more
1110 complex needs, then use the I<around> modifier, which uses a variation
1111 of continutation passing style to allow for a high degree of flexibility.
1113 Before and around modifiers are called in last-defined-first-called order,
1114 while after modifiers are called in first-defined-first-called order. So
1115 the call tree might looks something like this:
1125 To see examples of using method modifiers, see the following examples
1126 included in the distribution; F<InstanceCountingClass>, F<Perl6Attribute>,
1127 F<AttributesWithHistory> and F<C3MethodDispatchOrder>. There is also a
1128 classic CLOS usage example in the test F<017_add_method_modifier.t>.
1130 =head3 What is the performance impact?
1132 Of course there is a performance cost associated with method modifiers,
1133 but we have made every effort to make that cost be directly proportional
1134 to the amount of modifier features you utilize.
1136 The wrapping method does it's best to B<only> do as much work as it
1137 absolutely needs to. In order to do this we have moved some of the
1138 performance costs to set-up time, where they are easier to amortize.
1140 All this said, my benchmarks have indicated the following:
1142 simple wrapper with no modifiers 100% slower
1143 simple wrapper with simple before modifier 400% slower
1144 simple wrapper with simple after modifier 450% slower
1145 simple wrapper with simple around modifier 500-550% slower
1146 simple wrapper with all 3 modifiers 1100% slower
1148 These numbers may seem daunting, but you must remember, every feature
1149 comes with some cost. To put things in perspective, just doing a simple
1150 C<AUTOLOAD> which does nothing but extract the name of the method called
1151 and return it costs about 400% over a normal method call.
1155 =item B<add_before_method_modifier ($method_name, $code)>
1157 This will wrap the method at C<$method_name> and the supplied C<$code>
1158 will be passed the C<@_> arguments, and called before the original
1159 method is called. As specified above, the return value of the I<before>
1160 method modifiers is ignored, and it's ability to modify C<@_> is
1161 fairly limited. If you need to do either of these things, use an
1162 C<around> method modifier.
1164 =item B<add_after_method_modifier ($method_name, $code)>
1166 This will wrap the method at C<$method_name> so that the original
1167 method will be called, it's return values stashed, and then the
1168 supplied C<$code> will be passed the C<@_> arguments, and called.
1169 As specified above, the return value of the I<after> method
1170 modifiers is ignored, and it cannot modify the return values of
1171 the original method. If you need to do either of these things, use an
1172 C<around> method modifier.
1174 =item B<add_around_method_modifier ($method_name, $code)>
1176 This will wrap the method at C<$method_name> so that C<$code>
1177 will be called and passed the original method as an extra argument
1178 at the begining of the C<@_> argument list. This is a variation of
1179 continuation passing style, where the function prepended to C<@_>
1180 can be considered a continuation. It is up to C<$code> if it calls
1181 the original method or not, there is no restriction on what the
1182 C<$code> can or cannot do.
1188 It should be noted that since there is no one consistent way to define
1189 the attributes of a class in Perl 5. These methods can only work with
1190 the information given, and can not easily discover information on
1191 their own. See L<Class::MOP::Attribute> for more details.
1195 =item B<attribute_metaclass>
1197 =item B<get_attribute_map>
1199 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
1201 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
1202 instance associated with the given class, and associates it with
1203 the C<$attribute_name>. Unlike methods, attributes within the MOP
1204 are stored as meta-information only. They will be used later to
1205 construct instances from (see C<construct_instance> above).
1206 More details about the attribute meta-objects can be found in the
1207 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
1210 It should be noted that any accessor, reader/writer or predicate
1211 methods which the C<$attribute_meta_object> has will be installed
1212 into the class at this time.
1215 If an attribute already exists for C<$attribute_name>, the old one
1216 will be removed (as well as removing all it's accessors), and then
1219 =item B<has_attribute ($attribute_name)>
1221 Checks to see if this class has an attribute by the name of
1222 C<$attribute_name> and returns a boolean.
1224 =item B<get_attribute ($attribute_name)>
1226 Returns the attribute meta-object associated with C<$attribute_name>,
1227 if none is found, it will return undef.
1229 =item B<remove_attribute ($attribute_name)>
1231 This will remove the attribute meta-object stored at
1232 C<$attribute_name>, then return the removed attribute meta-object.
1235 Removing an attribute will only affect future instances of
1236 the class, it will not make any attempt to remove the attribute from
1237 any existing instances of the class.
1239 It should be noted that any accessor, reader/writer or predicate
1240 methods which the attribute meta-object stored at C<$attribute_name>
1241 has will be removed from the class at this time. This B<will> make
1242 these attributes somewhat inaccessable in previously created
1243 instances. But if you are crazy enough to do this at runtime, then
1244 you are crazy enough to deal with something like this :).
1246 =item B<get_attribute_list>
1248 This returns a list of attribute names which are defined in the local
1249 class. If you want a list of all applicable attributes for a class,
1250 use the C<compute_all_applicable_attributes> method.
1252 =item B<compute_all_applicable_attributes>
1254 This will traverse the inheritance heirachy and return a list of all
1255 the applicable attributes for this class. It does not construct a
1256 HASH reference like C<compute_all_applicable_methods> because all
1257 that same information is discoverable through the attribute
1260 =item B<find_attribute_by_name ($attr_name)>
1262 This method will traverse the inheritance heirachy and find the
1263 first attribute whose name matches C<$attr_name>, then return it.
1264 It will return undef if nothing is found.
1268 =head2 Class closing
1272 =item B<make_immutable>
1278 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1280 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1282 =head1 COPYRIGHT AND LICENSE
1284 Copyright 2006 by Infinity Interactive, Inc.
1286 L<http://www.iinteractive.com>
1288 This library is free software; you can redistribute it and/or modify
1289 it under the same terms as Perl itself.