2 package Class::MOP::Class;
8 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
10 use B 'svref_2object';
12 our $VERSION = '0.03';
16 sub meta { Class::MOP::Class->initialize($_[0]) }
21 # Metaclasses are singletons, so we cache them here.
22 # there is no need to worry about destruction though
23 # because they should die only when the program dies.
24 # After all, do package definitions even get reaped?
29 my $package_name = shift;
30 (defined $package_name && $package_name)
31 || confess "You must pass a package name";
32 # make sure the package name is not blessed
33 $package_name = blessed($package_name) || $package_name;
34 $class->construct_class_instance(':package' => $package_name, @_);
37 # NOTE: (meta-circularity)
38 # this is a special form of &construct_instance
39 # (see below), which is used to construct class
40 # meta-object instances for any Class::MOP::*
41 # class. All other classes will use the more
42 # normal &construct_instance.
43 sub construct_class_instance {
46 my $package_name = $options{':package'};
47 (defined $package_name && $package_name)
48 || confess "You must pass a package name";
49 return $METAS{$package_name} if exists $METAS{$package_name};
50 $class = blessed($class) || $class;
51 if ($class =~ /^Class::MOP::/) {
52 $METAS{$package_name} = bless {
53 '$:package' => $package_name,
55 '$:attribute_metaclass' => 'Class::MOP::Attribute',
56 '$:method_metaclass' => 'Class::MOP::Method',
61 # it is safe to use meta here because
62 # class will always be a subclass of
63 # Class::MOP::Class, which defines meta
64 $METAS{$package_name} = bless $class->meta->construct_instance(%options) => $class
70 my ($class, $package_name, $package_version, %options) = @_;
71 (defined $package_name && $package_name)
72 || confess "You must pass a package name";
73 my $code = "package $package_name;";
74 $code .= "\$$package_name\:\:VERSION = '$package_version';"
75 if defined $package_version;
77 confess "creation of $package_name failed : $@" if $@;
78 my $meta = $class->initialize($package_name);
79 $meta->superclasses(@{$options{superclasses}})
80 if exists $options{superclasses};
82 # process attributes first, so that they can
83 # install accessors, but locally defined methods
84 # can then overwrite them. It is maybe a little odd, but
85 # I think this should be the order of things.
86 if (exists $options{attributes}) {
87 foreach my $attr (@{$options{attributes}}) {
88 $meta->add_attribute($attr);
91 if (exists $options{methods}) {
92 foreach my $method_name (keys %{$options{methods}}) {
93 $meta->add_method($method_name, $options{methods}->{$method_name});
102 # all these attribute readers will be bootstrapped
103 # away in the Class::MOP bootstrap section
105 sub name { $_[0]->{'$:package'} }
106 sub get_attribute_map { $_[0]->{'%:attributes'} }
107 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
108 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
110 # Instance Construction & Cloning
115 # we need to protect the integrity of the
116 # Class::MOP::Class singletons here, so we
117 # delegate this to &construct_class_instance
118 # which will deal with the singletons
119 return $class->construct_class_instance(@_)
120 if $class->name->isa('Class::MOP::Class');
121 bless $class->construct_instance(@_) => $class->name;
124 sub construct_instance {
125 my ($class, %params) = @_;
127 foreach my $attr ($class->compute_all_applicable_attributes()) {
128 my $init_arg = $attr->init_arg();
129 # try to fetch the init arg from the %params ...
131 $val = $params{$init_arg} if exists $params{$init_arg};
132 # if nothing was in the %params, we can use the
133 # attribute's default value (if it has one)
134 $val ||= $attr->default($instance) if $attr->has_default();
135 $instance->{$attr->name} = $val;
142 my $instance = shift;
143 (blessed($instance) && $instance->isa($class->name))
144 || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
146 # we need to protect the integrity of the
147 # Class::MOP::Class singletons here, they
148 # should not be cloned
149 return $instance if $instance->isa('Class::MOP::Class');
150 bless $class->clone_instance($instance, @_) => blessed($instance);
154 my ($class, $instance, %params) = @_;
156 || confess "You can only clone instances, \$self is not a blessed instance";
158 # this should actually do a deep clone
159 # instead of this cheap hack. I will
161 # (use the Class::Cloneable::Util code)
162 my $clone = { %{$instance} };
163 foreach my $attr ($class->compute_all_applicable_attributes()) {
164 my $init_arg = $attr->init_arg();
165 # try to fetch the init arg from the %params ...
166 $clone->{$attr->name} = $params{$init_arg}
167 if exists $params{$init_arg};
174 # &name should be here too, but it is above
175 # because it gets bootstrapped away
180 ${$self->name . '::VERSION'};
190 @{$self->name . '::ISA'} = @supers;
192 @{$self->name . '::ISA'};
195 sub class_precedence_list {
198 # We need to check for ciruclar inheirtance here.
199 # This will do nothing if all is well, and blow
200 # up otherwise. Yes, it's an ugly hack, better
201 # suggestions are welcome.
202 { $self->name->isa('This is a test for circular inheritance') }
203 # ... and no back to our regularly scheduled program
207 $self->initialize($_)->class_precedence_list()
208 } $self->superclasses()
215 my ($self, $method_name, $method) = @_;
216 (defined $method_name && $method_name)
217 || confess "You must define a method name";
218 # use reftype here to allow for blessed subs ...
219 (reftype($method) && reftype($method) eq 'CODE')
220 || confess "Your code block must be a CODE reference";
221 my $full_method_name = ($self->name . '::' . $method_name);
224 no warnings 'redefine';
225 *{$full_method_name} = subname $full_method_name => $method;
230 ## private utility functions for has_method
231 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
232 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
235 my ($self, $method_name) = @_;
236 (defined $method_name && $method_name)
237 || confess "You must define a method name";
239 my $sub_name = ($self->name . '::' . $method_name);
242 return 0 if !defined(&{$sub_name});
243 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
244 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
251 my ($self, $method_name) = @_;
252 (defined $method_name && $method_name)
253 || confess "You must define a method name";
256 return \&{$self->name . '::' . $method_name}
257 if $self->has_method($method_name);
258 return; # <- make sure to return undef
262 my ($self, $method_name) = @_;
263 (defined $method_name && $method_name)
264 || confess "You must define a method name";
266 my $removed_method = $self->get_method($method_name);
269 delete ${$self->name . '::'}{$method_name}
270 if defined $removed_method;
272 return $removed_method;
275 sub get_method_list {
278 grep { $self->has_method($_) } %{$self->name . '::'};
281 sub compute_all_applicable_methods {
284 # keep a record of what we have seen
285 # here, this will handle all the
286 # inheritence issues because we are
287 # using the &class_precedence_list
288 my (%seen_class, %seen_method);
289 foreach my $class ($self->class_precedence_list()) {
290 next if $seen_class{$class};
291 $seen_class{$class}++;
292 # fetch the meta-class ...
293 my $meta = $self->initialize($class);
294 foreach my $method_name ($meta->get_method_list()) {
295 next if exists $seen_method{$method_name};
296 $seen_method{$method_name}++;
298 name => $method_name,
300 code => $meta->get_method($method_name)
307 sub find_all_methods_by_name {
308 my ($self, $method_name) = @_;
309 (defined $method_name && $method_name)
310 || confess "You must define a method name to find";
312 # keep a record of what we have seen
313 # here, this will handle all the
314 # inheritence issues because we are
315 # using the &class_precedence_list
317 foreach my $class ($self->class_precedence_list()) {
318 next if $seen_class{$class};
319 $seen_class{$class}++;
320 # fetch the meta-class ...
321 my $meta = $self->initialize($class);
323 name => $method_name,
325 code => $meta->get_method($method_name)
326 } if $meta->has_method($method_name);
336 # either we have an attribute object already
337 # or we need to create one from the args provided
338 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
339 # make sure it is derived from the correct type though
340 ($attribute->isa('Class::MOP::Attribute'))
341 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
342 $attribute->attach_to_class($self);
343 $attribute->install_accessors();
344 $self->get_attribute_map->{$attribute->name} = $attribute;
348 my ($self, $attribute_name) = @_;
349 (defined $attribute_name && $attribute_name)
350 || confess "You must define an attribute name";
351 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
355 my ($self, $attribute_name) = @_;
356 (defined $attribute_name && $attribute_name)
357 || confess "You must define an attribute name";
358 return $self->get_attribute_map->{$attribute_name}
359 if $self->has_attribute($attribute_name);
362 sub remove_attribute {
363 my ($self, $attribute_name) = @_;
364 (defined $attribute_name && $attribute_name)
365 || confess "You must define an attribute name";
366 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
367 delete $self->get_attribute_map->{$attribute_name}
368 if defined $removed_attribute;
369 $removed_attribute->remove_accessors();
370 $removed_attribute->detach_from_class();
371 return $removed_attribute;
374 sub get_attribute_list {
376 keys %{$self->get_attribute_map};
379 sub compute_all_applicable_attributes {
382 # keep a record of what we have seen
383 # here, this will handle all the
384 # inheritence issues because we are
385 # using the &class_precedence_list
386 my (%seen_class, %seen_attr);
387 foreach my $class ($self->class_precedence_list()) {
388 next if $seen_class{$class};
389 $seen_class{$class}++;
390 # fetch the meta-class ...
391 my $meta = $self->initialize($class);
392 foreach my $attr_name ($meta->get_attribute_list()) {
393 next if exists $seen_attr{$attr_name};
394 $seen_attr{$attr_name}++;
395 push @attrs => $meta->get_attribute($attr_name);
403 sub add_package_variable {
404 my ($self, $variable, $initial_value) = @_;
405 (defined $variable && $variable =~ /^[\$\@\%]/)
406 || confess "variable name does not have a sigil";
408 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
409 if (defined $initial_value) {
411 *{$self->name . '::' . $name} = $initial_value;
414 eval $sigil . $self->name . '::' . $name;
415 confess "Could not create package variable ($variable) because : $@" if $@;
419 sub has_package_variable {
420 my ($self, $variable) = @_;
421 (defined $variable && $variable =~ /^[\$\@\%]/)
422 || confess "variable name does not have a sigil";
423 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
425 defined ${$self->name . '::'}{$name} ? 1 : 0;
428 sub get_package_variable {
429 my ($self, $variable) = @_;
430 (defined $variable && $variable =~ /^[\$\@\%]/)
431 || confess "variable name does not have a sigil";
432 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
434 # try to fetch it first,.. see what happens
435 eval '\\' . $sigil . $self->name . '::' . $name;
436 confess "Could not get the package variable ($variable) because : $@" if $@;
437 # if we didn't die, then we can return it
439 # this is not ideal, better suggestions are welcome
440 eval '\\' . $sigil . $self->name . '::' . $name;
443 sub remove_package_variable {
444 my ($self, $variable) = @_;
445 (defined $variable && $variable =~ /^[\$\@\%]/)
446 || confess "variable name does not have a sigil";
447 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
449 delete ${$self->name . '::'}{$name};
460 Class::MOP::Class - Class Meta Object
464 # use this for introspection ...
467 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
469 # elsewhere in the code ...
471 # add a method to Foo ...
472 Foo->meta->add_method('bar' => sub { ... })
474 # get a list of all the classes searched
475 # the method dispatcher in the correct order
476 Foo->meta->class_precedence_list()
478 # remove a method from Foo
479 Foo->meta->remove_method('bar');
481 # or use this to actually create classes ...
483 Class::MOP::Class->create('Bar' => '0.01' => (
484 superclasses => [ 'Foo' ],
486 Class::MOP:::Attribute->new('$bar'),
487 Class::MOP:::Attribute->new('$baz'),
490 calculate_bar => sub { ... },
491 construct_baz => sub { ... }
497 This is the largest and currently most complex part of the Perl 5
498 meta-object protocol. It controls the introspection and
499 manipulation of Perl 5 classes (and it can create them too). The
500 best way to understand what this module can do, is to read the
501 documentation for each of it's methods.
505 =head2 Self Introspection
511 This will return a B<Class::MOP::Class> instance which is related
512 to this class. Thereby allowing B<Class::MOP::Class> to actually
515 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
516 bootstrap this module by installing a number of attribute meta-objects
517 into it's metaclass. This will allow this class to reap all the benifits
518 of the MOP when subclassing it.
522 =head2 Class construction
524 These methods will handle creating B<Class::MOP::Class> objects,
525 which can be used to both create new classes, and analyze
526 pre-existing classes.
528 This module will internally store references to all the instances
529 you create with these methods, so that they do not need to be
530 created any more than nessecary. Basically, they are singletons.
534 =item B<create ($package_name, ?$package_version,
535 superclasses =E<gt> ?@superclasses,
536 methods =E<gt> ?%methods,
537 attributes =E<gt> ?%attributes)>
539 This returns a B<Class::MOP::Class> object, bringing the specified
540 C<$package_name> into existence and adding any of the
541 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
544 =item B<initialize ($package_name)>
546 This initializes and returns returns a B<Class::MOP::Class> object
547 for a given a C<$package_name>.
549 =item B<construct_class_instance (%options)>
551 This will construct an instance of B<Class::MOP::Class>, it is
552 here so that we can actually "tie the knot" for B<Class::MOP::Class>
553 to use C<construct_instance> once all the bootstrapping is done. This
554 method is used internally by C<initialize> and should never be called
555 from outside of that method really.
559 =head2 Object instance construction and cloning
561 These methods are B<entirely optional>, it is up to you whether you want
566 =item B<new_object (%params)>
568 This is a convience method for creating a new object of the class, and
569 blessing it into the appropriate package as well. Ideally your class
570 would call a C<new> this method like so:
573 my ($class, %param) = @_;
574 $class->meta->new_object(%params);
577 Of course the ideal place for this would actually be in C<UNIVERSAL::>
578 but that is considered bad style, so we do not do that.
580 =item B<construct_instance (%params)>
582 This method is used to construct an instace structure suitable for
583 C<bless>-ing into your package of choice. It works in conjunction
584 with the Attribute protocol to collect all applicable attributes.
586 This will construct and instance using a HASH ref as storage
587 (currently only HASH references are supported). This will collect all
588 the applicable attributes and layout out the fields in the HASH ref,
589 it will then initialize them using either use the corresponding key
590 in C<%params> or any default value or initializer found in the
591 attribute meta-object.
593 =item B<clone_object ($instance, %params)>
595 This is a convience method for cloning an object instance, then
596 blessing it into the appropriate package. Ideally your class
597 would call a C<clone> this method like so:
600 my ($self, %param) = @_;
601 $self->meta->clone_object($self, %params);
604 Of course the ideal place for this would actually be in C<UNIVERSAL::>
605 but that is considered bad style, so we do not do that.
607 =item B<clone_instance($instance, %params)>
609 This method is a compliment of C<construct_instance> (which means if
610 you override C<construct_instance>, you need to override this one too).
612 This method will clone the C<$instance> structure created by the
613 C<construct_instance> method, and apply any C<%params> passed to it
614 to change the attribute values. The structure returned is (like with
615 C<construct_instance>) an unC<bless>ed HASH reference, it is your
616 responsibility to then bless this cloned structure into the right
627 This is a read-only attribute which returns the package name for the
628 given B<Class::MOP::Class> instance.
632 This is a read-only attribute which returns the C<$VERSION> of the
633 package for the given B<Class::MOP::Class> instance.
637 =head2 Inheritance Relationships
641 =item B<superclasses (?@superclasses)>
643 This is a read-write attribute which represents the superclass
644 relationships of the class the B<Class::MOP::Class> instance is
645 associated with. Basically, it can get and set the C<@ISA> for you.
648 Perl will occasionally perform some C<@ISA> and method caching, if
649 you decide to change your superclass relationship at runtime (which
650 is quite insane and very much not recommened), then you should be
651 aware of this and the fact that this module does not make any
652 attempt to address this issue.
654 =item B<class_precedence_list>
656 This computes the a list of all the class's ancestors in the same order
657 in which method dispatch will be done. This is similair to
658 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
666 =item B<method_metaclass>
668 =item B<add_method ($method_name, $method)>
670 This will take a C<$method_name> and CODE reference to that
671 C<$method> and install it into the class's package.
674 This does absolutely nothing special to C<$method>
675 other than use B<Sub::Name> to make sure it is tagged with the
676 correct name, and therefore show up correctly in stack traces and
679 =item B<has_method ($method_name)>
681 This just provides a simple way to check if the class implements
682 a specific C<$method_name>. It will I<not> however, attempt to check
683 if the class inherits the method (use C<UNIVERSAL::can> for that).
685 This will correctly handle functions defined outside of the package
686 that use a fully qualified name (C<sub Package::name { ... }>).
688 This will correctly handle functions renamed with B<Sub::Name> and
689 installed using the symbol tables. However, if you are naming the
690 subroutine outside of the package scope, you must use the fully
691 qualified name, including the package name, for C<has_method> to
692 correctly identify it.
694 This will attempt to correctly ignore functions imported from other
695 packages using B<Exporter>. It breaks down if the function imported
696 is an C<__ANON__> sub (such as with C<use constant>), which very well
697 may be a valid method being applied to the class.
699 In short, this method cannot always be trusted to determine if the
700 C<$method_name> is actually a method. However, it will DWIM about
701 90% of the time, so it's a small trade off I think.
703 =item B<get_method ($method_name)>
705 This will return a CODE reference of the specified C<$method_name>,
706 or return undef if that method does not exist.
708 =item B<remove_method ($method_name)>
710 This will attempt to remove a given C<$method_name> from the class.
711 It will return the CODE reference that it has removed, and will
712 attempt to use B<Sub::Name> to clear the methods associated name.
714 =item B<get_method_list>
716 This will return a list of method names for all I<locally> defined
717 methods. It does B<not> provide a list of all applicable methods,
718 including any inherited ones. If you want a list of all applicable
719 methods, use the C<compute_all_applicable_methods> method.
721 =item B<compute_all_applicable_methods>
723 This will return a list of all the methods names this class will
724 respond to, taking into account inheritance. The list will be a list of
725 HASH references, each one containing the following information; method
726 name, the name of the class in which the method lives and a CODE
727 reference for the actual method.
729 =item B<find_all_methods_by_name ($method_name)>
731 This will traverse the inheritence hierarchy and locate all methods
732 with a given C<$method_name>. Similar to
733 C<compute_all_applicable_methods> it returns a list of HASH references
734 with the following information; method name (which will always be the
735 same as C<$method_name>), the name of the class in which the method
736 lives and a CODE reference for the actual method.
738 The list of methods produced is a distinct list, meaning there are no
739 duplicates in it. This is especially useful for things like object
740 initialization and destruction where you only want the method called
741 once, and in the correct order.
747 It should be noted that since there is no one consistent way to define
748 the attributes of a class in Perl 5. These methods can only work with
749 the information given, and can not easily discover information on
750 their own. See L<Class::MOP::Attribute> for more details.
754 =item B<attribute_metaclass>
756 =item B<get_attribute_map>
758 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
760 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
761 instance associated with the given class, and associates it with
762 the C<$attribute_name>. Unlike methods, attributes within the MOP
763 are stored as meta-information only. They will be used later to
764 construct instances from (see C<construct_instance> above).
765 More details about the attribute meta-objects can be found in the
766 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
769 It should be noted that any accessor, reader/writer or predicate
770 methods which the C<$attribute_meta_object> has will be installed
771 into the class at this time.
773 =item B<has_attribute ($attribute_name)>
775 Checks to see if this class has an attribute by the name of
776 C<$attribute_name> and returns a boolean.
778 =item B<get_attribute ($attribute_name)>
780 Returns the attribute meta-object associated with C<$attribute_name>,
781 if none is found, it will return undef.
783 =item B<remove_attribute ($attribute_name)>
785 This will remove the attribute meta-object stored at
786 C<$attribute_name>, then return the removed attribute meta-object.
789 Removing an attribute will only affect future instances of
790 the class, it will not make any attempt to remove the attribute from
791 any existing instances of the class.
793 It should be noted that any accessor, reader/writer or predicate
794 methods which the attribute meta-object stored at C<$attribute_name>
795 has will be removed from the class at this time. This B<will> make
796 these attributes somewhat inaccessable in previously created
797 instances. But if you are crazy enough to do this at runtime, then
798 you are crazy enough to deal with something like this :).
800 =item B<get_attribute_list>
802 This returns a list of attribute names which are defined in the local
803 class. If you want a list of all applicable attributes for a class,
804 use the C<compute_all_applicable_attributes> method.
806 =item B<compute_all_applicable_attributes>
808 This will traverse the inheritance heirachy and return a list of all
809 the applicable attributes for this class. It does not construct a
810 HASH reference like C<compute_all_applicable_methods> because all
811 that same information is discoverable through the attribute
816 =head2 Package Variables
818 Since Perl's classes are built atop the Perl package system, it is
819 fairly common to use package scoped variables for things like static
820 class variables. The following methods are convience methods for
821 the creation and inspection of package scoped variables.
825 =item B<add_package_variable ($variable_name, ?$initial_value)>
827 Given a C<$variable_name>, which must contain a leading sigil, this
828 method will create that variable within the package which houses the
829 class. It also takes an optional C<$initial_value>, which must be a
830 reference of the same type as the sigil of the C<$variable_name>
833 =item B<get_package_variable ($variable_name)>
835 This will return a reference to the package variable in
838 =item B<has_package_variable ($variable_name)>
840 Returns true (C<1>) if there is a package variable defined for
841 C<$variable_name>, and false (C<0>) otherwise.
843 =item B<remove_package_variable ($variable_name)>
845 This will attempt to remove the package variable at C<$variable_name>.
851 Stevan Little E<lt>stevan@iinteractive.comE<gt>
853 =head1 COPYRIGHT AND LICENSE
855 Copyright 2006 by Infinity Interactive, Inc.
857 L<http://www.iinteractive.com>
859 This library is free software; you can redistribute it and/or modify
860 it under the same terms as Perl itself.