2 package Class::MOP::Class;
8 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
10 use B 'svref_2object';
13 our $VERSION = '0.03';
17 sub meta { Class::MOP::Class->initialize($_[0]) }
22 # Metaclasses are singletons, so we cache them here.
23 # there is no need to worry about destruction though
24 # because they should die only when the program dies.
25 # After all, do package definitions even get reaped?
30 my $package_name = shift;
31 (defined $package_name && $package_name)
32 || confess "You must pass a package name";
33 # make sure the package name is not blessed
34 $package_name = blessed($package_name) || $package_name;
35 $class->construct_class_instance(':package' => $package_name, @_);
38 # NOTE: (meta-circularity)
39 # this is a special form of &construct_instance
40 # (see below), which is used to construct class
41 # meta-object instances for any Class::MOP::*
42 # class. All other classes will use the more
43 # normal &construct_instance.
44 sub construct_class_instance {
47 my $package_name = $options{':package'};
48 (defined $package_name && $package_name)
49 || confess "You must pass a package name";
50 return $METAS{$package_name} if exists $METAS{$package_name};
51 $class = blessed($class) || $class;
52 # now create the metaclass
54 if ($class =~ /^Class::MOP::/) {
56 '$:package' => $package_name,
58 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
59 '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
64 # it is safe to use meta here because
65 # class will always be a subclass of
66 # Class::MOP::Class, which defines meta
67 $meta = bless $class->meta->construct_instance(%options) => $class
69 # and check the metaclass compatibility
70 $meta->check_metaclass_compatability();
71 $METAS{$package_name} = $meta;
74 sub check_metaclass_compatability {
77 # this is always okay ...
78 return if blessed($self) eq 'Class::MOP::Class';
80 my @class_list = $self->class_precedence_list;
81 shift @class_list; # shift off $self->name
83 foreach my $class_name (@class_list) {
84 next unless $METAS{$class_name};
85 my $meta = $METAS{$class_name};
86 ($self->isa(blessed($meta)))
87 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
88 " is not compatible with the " .
89 $class_name . "->meta => (" . (blessed($meta)) . ")";
95 my ($class, $package_name, $package_version, %options) = @_;
96 (defined $package_name && $package_name)
97 || confess "You must pass a package name";
98 my $code = "package $package_name;";
99 $code .= "\$$package_name\:\:VERSION = '$package_version';"
100 if defined $package_version;
102 confess "creation of $package_name failed : $@" if $@;
103 my $meta = $class->initialize($package_name);
104 $meta->superclasses(@{$options{superclasses}})
105 if exists $options{superclasses};
107 # process attributes first, so that they can
108 # install accessors, but locally defined methods
109 # can then overwrite them. It is maybe a little odd, but
110 # I think this should be the order of things.
111 if (exists $options{attributes}) {
112 foreach my $attr (@{$options{attributes}}) {
113 $meta->add_attribute($attr);
116 if (exists $options{methods}) {
117 foreach my $method_name (keys %{$options{methods}}) {
118 $meta->add_method($method_name, $options{methods}->{$method_name});
127 # all these attribute readers will be bootstrapped
128 # away in the Class::MOP bootstrap section
130 sub name { $_[0]->{'$:package'} }
131 sub get_attribute_map { $_[0]->{'%:attributes'} }
132 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
133 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
135 # Instance Construction & Cloning
140 # we need to protect the integrity of the
141 # Class::MOP::Class singletons here, so we
142 # delegate this to &construct_class_instance
143 # which will deal with the singletons
144 return $class->construct_class_instance(@_)
145 if $class->name->isa('Class::MOP::Class');
146 bless $class->construct_instance(@_) => $class->name;
149 sub construct_instance {
150 my ($class, %params) = @_;
152 foreach my $attr ($class->compute_all_applicable_attributes()) {
153 my $init_arg = $attr->init_arg();
154 # try to fetch the init arg from the %params ...
156 $val = $params{$init_arg} if exists $params{$init_arg};
157 # if nothing was in the %params, we can use the
158 # attribute's default value (if it has one)
159 $val ||= $attr->default($instance) if $attr->has_default();
160 $instance->{$attr->name} = $val;
167 my $instance = shift;
168 (blessed($instance) && $instance->isa($class->name))
169 || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
171 # we need to protect the integrity of the
172 # Class::MOP::Class singletons here, they
173 # should not be cloned.
174 return $instance if $instance->isa('Class::MOP::Class');
175 bless $class->clone_instance($instance, @_) => blessed($instance);
179 my ($class, $instance, %params) = @_;
181 || confess "You can only clone instances, \$self is not a blessed instance";
183 # This will deep clone, which might
184 # not be what you always want. So
185 # the best thing is to write a more
186 # controled &clone method locally
187 # in the class (see Class::MOP)
188 my $clone = Clone::clone($instance);
189 foreach my $attr ($class->compute_all_applicable_attributes()) {
190 my $init_arg = $attr->init_arg();
191 # try to fetch the init arg from the %params ...
192 $clone->{$attr->name} = $params{$init_arg}
193 if exists $params{$init_arg};
200 # &name should be here too, but it is above
201 # because it gets bootstrapped away
206 ${$self->name . '::VERSION'};
216 @{$self->name . '::ISA'} = @supers;
218 @{$self->name . '::ISA'};
221 sub class_precedence_list {
224 # We need to check for ciruclar inheirtance here.
225 # This will do nothing if all is well, and blow
226 # up otherwise. Yes, it's an ugly hack, better
227 # suggestions are welcome.
228 { $self->name->isa('This is a test for circular inheritance') }
229 # ... and no back to our regularly scheduled program
233 $self->initialize($_)->class_precedence_list()
234 } $self->superclasses()
241 my ($self, $method_name, $method) = @_;
242 (defined $method_name && $method_name)
243 || confess "You must define a method name";
244 # use reftype here to allow for blessed subs ...
245 (reftype($method) && reftype($method) eq 'CODE')
246 || confess "Your code block must be a CODE reference";
247 my $full_method_name = ($self->name . '::' . $method_name);
250 no warnings 'redefine';
251 *{$full_method_name} = subname $full_method_name => $method;
256 ## private utility functions for has_method
257 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
258 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
261 my ($self, $method_name) = @_;
262 (defined $method_name && $method_name)
263 || confess "You must define a method name";
265 my $sub_name = ($self->name . '::' . $method_name);
268 return 0 if !defined(&{$sub_name});
269 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
270 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
277 my ($self, $method_name) = @_;
278 (defined $method_name && $method_name)
279 || confess "You must define a method name";
282 return \&{$self->name . '::' . $method_name}
283 if $self->has_method($method_name);
284 return; # <- make sure to return undef
288 my ($self, $method_name) = @_;
289 (defined $method_name && $method_name)
290 || confess "You must define a method name";
292 my $removed_method = $self->get_method($method_name);
295 delete ${$self->name . '::'}{$method_name}
296 if defined $removed_method;
298 return $removed_method;
301 sub get_method_list {
304 grep { $self->has_method($_) } %{$self->name . '::'};
307 sub compute_all_applicable_methods {
310 # keep a record of what we have seen
311 # here, this will handle all the
312 # inheritence issues because we are
313 # using the &class_precedence_list
314 my (%seen_class, %seen_method);
315 foreach my $class ($self->class_precedence_list()) {
316 next if $seen_class{$class};
317 $seen_class{$class}++;
318 # fetch the meta-class ...
319 my $meta = $self->initialize($class);
320 foreach my $method_name ($meta->get_method_list()) {
321 next if exists $seen_method{$method_name};
322 $seen_method{$method_name}++;
324 name => $method_name,
326 code => $meta->get_method($method_name)
333 sub find_all_methods_by_name {
334 my ($self, $method_name) = @_;
335 (defined $method_name && $method_name)
336 || confess "You must define a method name to find";
338 # keep a record of what we have seen
339 # here, this will handle all the
340 # inheritence issues because we are
341 # using the &class_precedence_list
343 foreach my $class ($self->class_precedence_list()) {
344 next if $seen_class{$class};
345 $seen_class{$class}++;
346 # fetch the meta-class ...
347 my $meta = $self->initialize($class);
349 name => $method_name,
351 code => $meta->get_method($method_name)
352 } if $meta->has_method($method_name);
362 # either we have an attribute object already
363 # or we need to create one from the args provided
364 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
365 # make sure it is derived from the correct type though
366 ($attribute->isa('Class::MOP::Attribute'))
367 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
368 $attribute->attach_to_class($self);
369 $attribute->install_accessors();
370 $self->get_attribute_map->{$attribute->name} = $attribute;
374 my ($self, $attribute_name) = @_;
375 (defined $attribute_name && $attribute_name)
376 || confess "You must define an attribute name";
377 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
381 my ($self, $attribute_name) = @_;
382 (defined $attribute_name && $attribute_name)
383 || confess "You must define an attribute name";
384 return $self->get_attribute_map->{$attribute_name}
385 if $self->has_attribute($attribute_name);
388 sub remove_attribute {
389 my ($self, $attribute_name) = @_;
390 (defined $attribute_name && $attribute_name)
391 || confess "You must define an attribute name";
392 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
393 delete $self->get_attribute_map->{$attribute_name}
394 if defined $removed_attribute;
395 $removed_attribute->remove_accessors();
396 $removed_attribute->detach_from_class();
397 return $removed_attribute;
400 sub get_attribute_list {
402 keys %{$self->get_attribute_map};
405 sub compute_all_applicable_attributes {
408 # keep a record of what we have seen
409 # here, this will handle all the
410 # inheritence issues because we are
411 # using the &class_precedence_list
412 my (%seen_class, %seen_attr);
413 foreach my $class ($self->class_precedence_list()) {
414 next if $seen_class{$class};
415 $seen_class{$class}++;
416 # fetch the meta-class ...
417 my $meta = $self->initialize($class);
418 foreach my $attr_name ($meta->get_attribute_list()) {
419 next if exists $seen_attr{$attr_name};
420 $seen_attr{$attr_name}++;
421 push @attrs => $meta->get_attribute($attr_name);
429 sub add_package_variable {
430 my ($self, $variable, $initial_value) = @_;
431 (defined $variable && $variable =~ /^[\$\@\%]/)
432 || confess "variable name does not have a sigil";
434 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
435 if (defined $initial_value) {
437 *{$self->name . '::' . $name} = $initial_value;
440 eval $sigil . $self->name . '::' . $name;
441 confess "Could not create package variable ($variable) because : $@" if $@;
445 sub has_package_variable {
446 my ($self, $variable) = @_;
447 (defined $variable && $variable =~ /^[\$\@\%]/)
448 || confess "variable name does not have a sigil";
449 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
451 defined ${$self->name . '::'}{$name} ? 1 : 0;
454 sub get_package_variable {
455 my ($self, $variable) = @_;
456 (defined $variable && $variable =~ /^[\$\@\%]/)
457 || confess "variable name does not have a sigil";
458 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
460 # try to fetch it first,.. see what happens
461 eval '\\' . $sigil . $self->name . '::' . $name;
462 confess "Could not get the package variable ($variable) because : $@" if $@;
463 # if we didn't die, then we can return it
465 # this is not ideal, better suggestions are welcome
466 eval '\\' . $sigil . $self->name . '::' . $name;
469 sub remove_package_variable {
470 my ($self, $variable) = @_;
471 (defined $variable && $variable =~ /^[\$\@\%]/)
472 || confess "variable name does not have a sigil";
473 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
475 delete ${$self->name . '::'}{$name};
486 Class::MOP::Class - Class Meta Object
490 # use this for introspection ...
493 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
495 # elsewhere in the code ...
497 # add a method to Foo ...
498 Foo->meta->add_method('bar' => sub { ... })
500 # get a list of all the classes searched
501 # the method dispatcher in the correct order
502 Foo->meta->class_precedence_list()
504 # remove a method from Foo
505 Foo->meta->remove_method('bar');
507 # or use this to actually create classes ...
509 Class::MOP::Class->create('Bar' => '0.01' => (
510 superclasses => [ 'Foo' ],
512 Class::MOP:::Attribute->new('$bar'),
513 Class::MOP:::Attribute->new('$baz'),
516 calculate_bar => sub { ... },
517 construct_baz => sub { ... }
523 This is the largest and currently most complex part of the Perl 5
524 meta-object protocol. It controls the introspection and
525 manipulation of Perl 5 classes (and it can create them too). The
526 best way to understand what this module can do, is to read the
527 documentation for each of it's methods.
531 =head2 Self Introspection
537 This will return a B<Class::MOP::Class> instance which is related
538 to this class. Thereby allowing B<Class::MOP::Class> to actually
541 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
542 bootstrap this module by installing a number of attribute meta-objects
543 into it's metaclass. This will allow this class to reap all the benifits
544 of the MOP when subclassing it.
548 =head2 Class construction
550 These methods will handle creating B<Class::MOP::Class> objects,
551 which can be used to both create new classes, and analyze
552 pre-existing classes.
554 This module will internally store references to all the instances
555 you create with these methods, so that they do not need to be
556 created any more than nessecary. Basically, they are singletons.
560 =item B<create ($package_name, ?$package_version,
561 superclasses =E<gt> ?@superclasses,
562 methods =E<gt> ?%methods,
563 attributes =E<gt> ?%attributes)>
565 This returns a B<Class::MOP::Class> object, bringing the specified
566 C<$package_name> into existence and adding any of the
567 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
570 =item B<initialize ($package_name)>
572 This initializes and returns returns a B<Class::MOP::Class> object
573 for a given a C<$package_name>.
575 =item B<construct_class_instance (%options)>
577 This will construct an instance of B<Class::MOP::Class>, it is
578 here so that we can actually "tie the knot" for B<Class::MOP::Class>
579 to use C<construct_instance> once all the bootstrapping is done. This
580 method is used internally by C<initialize> and should never be called
581 from outside of that method really.
583 =item B<check_metaclass_compatability>
585 This method is called as the very last thing in the
586 C<construct_class_instance> method. This will check that the
587 metaclass you are creating is compatible with the metaclasses of all
588 your ancestors. For more inforamtion about metaclass compatibility
589 see the C<About Metaclass compatibility> section in L<Class::MOP>.
593 =head2 Object instance construction and cloning
595 These methods are B<entirely optional>, it is up to you whether you want
600 =item B<new_object (%params)>
602 This is a convience method for creating a new object of the class, and
603 blessing it into the appropriate package as well. Ideally your class
604 would call a C<new> this method like so:
607 my ($class, %param) = @_;
608 $class->meta->new_object(%params);
611 Of course the ideal place for this would actually be in C<UNIVERSAL::>
612 but that is considered bad style, so we do not do that.
614 =item B<construct_instance (%params)>
616 This method is used to construct an instace structure suitable for
617 C<bless>-ing into your package of choice. It works in conjunction
618 with the Attribute protocol to collect all applicable attributes.
620 This will construct and instance using a HASH ref as storage
621 (currently only HASH references are supported). This will collect all
622 the applicable attributes and layout out the fields in the HASH ref,
623 it will then initialize them using either use the corresponding key
624 in C<%params> or any default value or initializer found in the
625 attribute meta-object.
627 =item B<clone_object ($instance, %params)>
629 This is a convience method for cloning an object instance, then
630 blessing it into the appropriate package. Ideally your class
631 would call a C<clone> this method like so:
634 my ($self, %param) = @_;
635 $self->meta->clone_object($self, %params);
638 Of course the ideal place for this would actually be in C<UNIVERSAL::>
639 but that is considered bad style, so we do not do that.
641 =item B<clone_instance($instance, %params)>
643 This method is a compliment of C<construct_instance> (which means if
644 you override C<construct_instance>, you need to override this one too).
646 This method will clone the C<$instance> structure created by the
647 C<construct_instance> method, and apply any C<%params> passed to it
648 to change the attribute values. The structure returned is (like with
649 C<construct_instance>) an unC<bless>ed HASH reference, it is your
650 responsibility to then bless this cloned structure into the right
661 This is a read-only attribute which returns the package name for the
662 given B<Class::MOP::Class> instance.
666 This is a read-only attribute which returns the C<$VERSION> of the
667 package for the given B<Class::MOP::Class> instance.
671 =head2 Inheritance Relationships
675 =item B<superclasses (?@superclasses)>
677 This is a read-write attribute which represents the superclass
678 relationships of the class the B<Class::MOP::Class> instance is
679 associated with. Basically, it can get and set the C<@ISA> for you.
682 Perl will occasionally perform some C<@ISA> and method caching, if
683 you decide to change your superclass relationship at runtime (which
684 is quite insane and very much not recommened), then you should be
685 aware of this and the fact that this module does not make any
686 attempt to address this issue.
688 =item B<class_precedence_list>
690 This computes the a list of all the class's ancestors in the same order
691 in which method dispatch will be done. This is similair to
692 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
700 =item B<method_metaclass>
702 =item B<add_method ($method_name, $method)>
704 This will take a C<$method_name> and CODE reference to that
705 C<$method> and install it into the class's package.
708 This does absolutely nothing special to C<$method>
709 other than use B<Sub::Name> to make sure it is tagged with the
710 correct name, and therefore show up correctly in stack traces and
713 =item B<has_method ($method_name)>
715 This just provides a simple way to check if the class implements
716 a specific C<$method_name>. It will I<not> however, attempt to check
717 if the class inherits the method (use C<UNIVERSAL::can> for that).
719 This will correctly handle functions defined outside of the package
720 that use a fully qualified name (C<sub Package::name { ... }>).
722 This will correctly handle functions renamed with B<Sub::Name> and
723 installed using the symbol tables. However, if you are naming the
724 subroutine outside of the package scope, you must use the fully
725 qualified name, including the package name, for C<has_method> to
726 correctly identify it.
728 This will attempt to correctly ignore functions imported from other
729 packages using B<Exporter>. It breaks down if the function imported
730 is an C<__ANON__> sub (such as with C<use constant>), which very well
731 may be a valid method being applied to the class.
733 In short, this method cannot always be trusted to determine if the
734 C<$method_name> is actually a method. However, it will DWIM about
735 90% of the time, so it's a small trade off I think.
737 =item B<get_method ($method_name)>
739 This will return a CODE reference of the specified C<$method_name>,
740 or return undef if that method does not exist.
742 =item B<remove_method ($method_name)>
744 This will attempt to remove a given C<$method_name> from the class.
745 It will return the CODE reference that it has removed, and will
746 attempt to use B<Sub::Name> to clear the methods associated name.
748 =item B<get_method_list>
750 This will return a list of method names for all I<locally> defined
751 methods. It does B<not> provide a list of all applicable methods,
752 including any inherited ones. If you want a list of all applicable
753 methods, use the C<compute_all_applicable_methods> method.
755 =item B<compute_all_applicable_methods>
757 This will return a list of all the methods names this class will
758 respond to, taking into account inheritance. The list will be a list of
759 HASH references, each one containing the following information; method
760 name, the name of the class in which the method lives and a CODE
761 reference for the actual method.
763 =item B<find_all_methods_by_name ($method_name)>
765 This will traverse the inheritence hierarchy and locate all methods
766 with a given C<$method_name>. Similar to
767 C<compute_all_applicable_methods> it returns a list of HASH references
768 with the following information; method name (which will always be the
769 same as C<$method_name>), the name of the class in which the method
770 lives and a CODE reference for the actual method.
772 The list of methods produced is a distinct list, meaning there are no
773 duplicates in it. This is especially useful for things like object
774 initialization and destruction where you only want the method called
775 once, and in the correct order.
781 It should be noted that since there is no one consistent way to define
782 the attributes of a class in Perl 5. These methods can only work with
783 the information given, and can not easily discover information on
784 their own. See L<Class::MOP::Attribute> for more details.
788 =item B<attribute_metaclass>
790 =item B<get_attribute_map>
792 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
794 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
795 instance associated with the given class, and associates it with
796 the C<$attribute_name>. Unlike methods, attributes within the MOP
797 are stored as meta-information only. They will be used later to
798 construct instances from (see C<construct_instance> above).
799 More details about the attribute meta-objects can be found in the
800 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
803 It should be noted that any accessor, reader/writer or predicate
804 methods which the C<$attribute_meta_object> has will be installed
805 into the class at this time.
807 =item B<has_attribute ($attribute_name)>
809 Checks to see if this class has an attribute by the name of
810 C<$attribute_name> and returns a boolean.
812 =item B<get_attribute ($attribute_name)>
814 Returns the attribute meta-object associated with C<$attribute_name>,
815 if none is found, it will return undef.
817 =item B<remove_attribute ($attribute_name)>
819 This will remove the attribute meta-object stored at
820 C<$attribute_name>, then return the removed attribute meta-object.
823 Removing an attribute will only affect future instances of
824 the class, it will not make any attempt to remove the attribute from
825 any existing instances of the class.
827 It should be noted that any accessor, reader/writer or predicate
828 methods which the attribute meta-object stored at C<$attribute_name>
829 has will be removed from the class at this time. This B<will> make
830 these attributes somewhat inaccessable in previously created
831 instances. But if you are crazy enough to do this at runtime, then
832 you are crazy enough to deal with something like this :).
834 =item B<get_attribute_list>
836 This returns a list of attribute names which are defined in the local
837 class. If you want a list of all applicable attributes for a class,
838 use the C<compute_all_applicable_attributes> method.
840 =item B<compute_all_applicable_attributes>
842 This will traverse the inheritance heirachy and return a list of all
843 the applicable attributes for this class. It does not construct a
844 HASH reference like C<compute_all_applicable_methods> because all
845 that same information is discoverable through the attribute
850 =head2 Package Variables
852 Since Perl's classes are built atop the Perl package system, it is
853 fairly common to use package scoped variables for things like static
854 class variables. The following methods are convience methods for
855 the creation and inspection of package scoped variables.
859 =item B<add_package_variable ($variable_name, ?$initial_value)>
861 Given a C<$variable_name>, which must contain a leading sigil, this
862 method will create that variable within the package which houses the
863 class. It also takes an optional C<$initial_value>, which must be a
864 reference of the same type as the sigil of the C<$variable_name>
867 =item B<get_package_variable ($variable_name)>
869 This will return a reference to the package variable in
872 =item B<has_package_variable ($variable_name)>
874 Returns true (C<1>) if there is a package variable defined for
875 C<$variable_name>, and false (C<0>) otherwise.
877 =item B<remove_package_variable ($variable_name)>
879 This will attempt to remove the package variable at C<$variable_name>.
885 Stevan Little E<lt>stevan@iinteractive.comE<gt>
887 =head1 COPYRIGHT AND LICENSE
889 Copyright 2006 by Infinity Interactive, Inc.
891 L<http://www.iinteractive.com>
893 This library is free software; you can redistribute it and/or modify
894 it under the same terms as Perl itself.