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?
28 my $package_name = shift;
29 (defined $package_name && $package_name)
30 || confess "You must pass a package name";
31 # make sure the package name is not blessed
32 $package_name = blessed($package_name) || $package_name;
33 return $METAS{$package_name} if exists $METAS{$package_name};
34 $METAS{$package_name} = $class->construct_class_instance($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 {
45 my $package_name = shift;
46 (defined $package_name && $package_name)
47 || confess "You must pass a package name";
48 $class = blessed($class) || $class;
49 if ($class =~ /^Class::MOP::/) {
51 '$:package' => $package_name,
53 '$:attribute_metaclass' => 'Class::MOP::Attribute',
54 '$:method_metaclass' => 'Class::MOP::Method',
58 bless $class->meta->construct_instance(':package' => $package_name, @_) => $class
64 my ($class, $package_name, $package_version, %options) = @_;
65 (defined $package_name && $package_name)
66 || confess "You must pass a package name";
67 my $code = "package $package_name;";
68 $code .= "\$$package_name\:\:VERSION = '$package_version';"
69 if defined $package_version;
71 confess "creation of $package_name failed : $@" if $@;
72 my $meta = $class->initialize($package_name);
73 $meta->superclasses(@{$options{superclasses}})
74 if exists $options{superclasses};
76 # process attributes first, so that they can
77 # install accessors, but locally defined methods
78 # can then overwrite them. It is maybe a little odd, but
79 # I think this should be the order of things.
80 if (exists $options{attributes}) {
81 foreach my $attr (@{$options{attributes}}) {
82 $meta->add_attribute($attr);
85 if (exists $options{methods}) {
86 foreach my $method_name (keys %{$options{methods}}) {
87 $meta->add_method($method_name, $options{methods}->{$method_name});
93 # Instance Construction & Cloning
96 sub construct_instance {
97 my ($class, %params) = @_;
99 foreach my $attr ($class->compute_all_applicable_attributes()) {
100 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
101 # try to fetch the init arg from the %params ...
103 $val = $params{$init_arg} if exists $params{$init_arg};
104 # if nothing was in the %params, we can use the
105 # attribute's default value (if it has one)
106 $val ||= $attr->default($instance) if $attr->has_default();
107 $instance->{$attr->name} = $val;
113 my ($class, $self, %params) = @_;
115 || confess "You can only clone instances, \$self is not a blessed instance";
117 # this should actually do a deep clone
118 # instead of this cheap hack. I will
120 # (use the Class::Cloneable::Util code)
121 my $clone = { %{$self} };
122 foreach my $attr ($class->compute_all_applicable_attributes()) {
123 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
124 # try to fetch the init arg from the %params ...
125 $clone->{$attr->name} = $params{$init_arg}
126 if exists $params{$init_arg};
133 sub name { $_[0]->{'$:package'} }
138 ${$self->name . '::VERSION'};
148 @{$self->name . '::ISA'} = @supers;
150 @{$self->name . '::ISA'};
153 sub class_precedence_list {
156 # We need to check for ciruclar inheirtance here.
157 # This will do nothing if all is well, and blow
158 # up otherwise. Yes, it's an ugly hack, better
159 # suggestions are welcome.
160 { $self->name->isa('This is a test for circular inheritance') }
161 # ... and no back to our regularly scheduled program
165 $self->initialize($_)->class_precedence_list()
166 } $self->superclasses()
172 # un-used right now ...
173 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
176 my ($self, $method_name, $method) = @_;
177 (defined $method_name && $method_name)
178 || confess "You must define a method name";
179 # use reftype here to allow for blessed subs ...
180 (reftype($method) && reftype($method) eq 'CODE')
181 || confess "Your code block must be a CODE reference";
182 my $full_method_name = ($self->name . '::' . $method_name);
185 no warnings 'redefine';
186 *{$full_method_name} = subname $full_method_name => $method;
191 ## private utility functions for has_method
192 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
193 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
196 my ($self, $method_name) = @_;
197 (defined $method_name && $method_name)
198 || confess "You must define a method name";
200 my $sub_name = ($self->name . '::' . $method_name);
203 return 0 if !defined(&{$sub_name});
204 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
205 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
212 my ($self, $method_name) = @_;
213 (defined $method_name && $method_name)
214 || confess "You must define a method name";
217 return \&{$self->name . '::' . $method_name}
218 if $self->has_method($method_name);
219 return; # <- make sure to return undef
223 my ($self, $method_name) = @_;
224 (defined $method_name && $method_name)
225 || confess "You must define a method name";
227 my $removed_method = $self->get_method($method_name);
230 delete ${$self->name . '::'}{$method_name}
231 if defined $removed_method;
233 return $removed_method;
236 sub get_method_list {
239 grep { $self->has_method($_) } %{$self->name . '::'};
242 sub compute_all_applicable_methods {
245 # keep a record of what we have seen
246 # here, this will handle all the
247 # inheritence issues because we are
248 # using the &class_precedence_list
249 my (%seen_class, %seen_method);
250 foreach my $class ($self->class_precedence_list()) {
251 next if $seen_class{$class};
252 $seen_class{$class}++;
253 # fetch the meta-class ...
254 my $meta = $self->initialize($class);
255 foreach my $method_name ($meta->get_method_list()) {
256 next if exists $seen_method{$method_name};
257 $seen_method{$method_name}++;
259 name => $method_name,
261 code => $meta->get_method($method_name)
268 sub find_all_methods_by_name {
269 my ($self, $method_name) = @_;
270 (defined $method_name && $method_name)
271 || confess "You must define a method name to find";
273 # keep a record of what we have seen
274 # here, this will handle all the
275 # inheritence issues because we are
276 # using the &class_precedence_list
278 foreach my $class ($self->class_precedence_list()) {
279 next if $seen_class{$class};
280 $seen_class{$class}++;
281 # fetch the meta-class ...
282 my $meta = $self->initialize($class);
284 name => $method_name,
286 code => $meta->get_method($method_name)
287 } if $meta->has_method($method_name);
295 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
299 # either we have an attribute object already
300 # or we need to create one from the args provided
301 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
302 # make sure it is derived from the correct type though
303 ($attribute->isa('Class::MOP::Attribute'))
304 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
305 $attribute->attach_to_class($self);
306 $attribute->install_accessors();
307 $self->{'%:attrs'}->{$attribute->name} = $attribute;
311 my ($self, $attribute_name) = @_;
312 (defined $attribute_name && $attribute_name)
313 || confess "You must define an attribute name";
314 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
318 my ($self, $attribute_name) = @_;
319 (defined $attribute_name && $attribute_name)
320 || confess "You must define an attribute name";
321 return $self->{'%:attrs'}->{$attribute_name}
322 if $self->has_attribute($attribute_name);
325 sub remove_attribute {
326 my ($self, $attribute_name) = @_;
327 (defined $attribute_name && $attribute_name)
328 || confess "You must define an attribute name";
329 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
330 delete $self->{'%:attrs'}->{$attribute_name}
331 if defined $removed_attribute;
332 $removed_attribute->remove_accessors();
333 $removed_attribute->detach_from_class();
334 return $removed_attribute;
337 sub get_attribute_list {
339 keys %{$self->{'%:attrs'}};
342 sub compute_all_applicable_attributes {
345 # keep a record of what we have seen
346 # here, this will handle all the
347 # inheritence issues because we are
348 # using the &class_precedence_list
349 my (%seen_class, %seen_attr);
350 foreach my $class ($self->class_precedence_list()) {
351 next if $seen_class{$class};
352 $seen_class{$class}++;
353 # fetch the meta-class ...
354 my $meta = $self->initialize($class);
355 foreach my $attr_name ($meta->get_attribute_list()) {
356 next if exists $seen_attr{$attr_name};
357 $seen_attr{$attr_name}++;
358 push @attrs => $meta->get_attribute($attr_name);
366 sub add_package_variable {
367 my ($self, $variable, $initial_value) = @_;
368 (defined $variable && $variable =~ /^[\$\@\%]/)
369 || confess "variable name does not have a sigil";
371 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
372 if (defined $initial_value) {
374 *{$self->name . '::' . $name} = $initial_value;
377 eval $sigil . $self->name . '::' . $name;
378 confess "Could not create package variable ($variable) because : $@" if $@;
382 sub has_package_variable {
383 my ($self, $variable) = @_;
384 (defined $variable && $variable =~ /^[\$\@\%]/)
385 || confess "variable name does not have a sigil";
386 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
388 defined ${$self->name . '::'}{$name} ? 1 : 0;
391 sub get_package_variable {
392 my ($self, $variable) = @_;
393 (defined $variable && $variable =~ /^[\$\@\%]/)
394 || confess "variable name does not have a sigil";
395 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
397 # try to fetch it first,.. see what happens
398 eval '\\' . $sigil . $self->name . '::' . $name;
399 confess "Could not get the package variable ($variable) because : $@" if $@;
400 # if we didn't die, then we can return it
402 # this is not ideal, better suggestions are welcome
403 eval '\\' . $sigil . $self->name . '::' . $name;
406 sub remove_package_variable {
407 my ($self, $variable) = @_;
408 (defined $variable && $variable =~ /^[\$\@\%]/)
409 || confess "variable name does not have a sigil";
410 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
412 delete ${$self->name . '::'}{$name};
423 Class::MOP::Class - Class Meta Object
427 # use this for introspection ...
430 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
432 # elsewhere in the code ...
434 # add a method to Foo ...
435 Foo->meta->add_method('bar' => sub { ... })
437 # get a list of all the classes searched
438 # the method dispatcher in the correct order
439 Foo->meta->class_precedence_list()
441 # remove a method from Foo
442 Foo->meta->remove_method('bar');
444 # or use this to actually create classes ...
446 Class::MOP::Class->create('Bar' => '0.01' => (
447 superclasses => [ 'Foo' ],
449 Class::MOP:::Attribute->new('$bar'),
450 Class::MOP:::Attribute->new('$baz'),
453 calculate_bar => sub { ... },
454 construct_baz => sub { ... }
460 This is the largest and currently most complex part of the Perl 5
461 meta-object protocol. It controls the introspection and
462 manipulation of Perl 5 classes (and it can create them too). The
463 best way to understand what this module can do, is to read the
464 documentation for each of it's methods.
468 =head2 Self Introspection
474 This will return a B<Class::MOP::Class> instance which is related
475 to this class. Thereby allowing B<Class::MOP::Class> to actually
478 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
479 bootstrap this module by installing a number of attribute meta-objects
480 into it's metaclass. This will allow this class to reap all the benifits
481 of the MOP when subclassing it.
485 =head2 Class construction
487 These methods will handle creating B<Class::MOP::Class> objects,
488 which can be used to both create new classes, and analyze
489 pre-existing classes.
491 This module will internally store references to all the instances
492 you create with these methods, so that they do not need to be
493 created any more than nessecary. Basically, they are singletons.
497 =item B<create ($package_name, ?$package_version,
498 superclasses =E<gt> ?@superclasses,
499 methods =E<gt> ?%methods,
500 attributes =E<gt> ?%attributes)>
502 This returns a B<Class::MOP::Class> object, bringing the specified
503 C<$package_name> into existence and adding any of the
504 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
507 =item B<initialize ($package_name)>
509 This initializes and returns returns a B<Class::MOP::Class> object
510 for a given a C<$package_name>.
512 =item B<construct_class_instance ($package_name)>
514 This will construct an instance of B<Class::MOP::Class>, it is
515 here so that we can actually "tie the knot" for B<Class::MOP::Class>
516 to use C<construct_instance> once all the bootstrapping is done. This
517 method is used internally by C<initialize> and should never be called
518 from outside of that method really.
522 =head2 Object instance construction and cloning
524 These methods are B<entirely optional>, it is up to you whether you want
529 =item B<construct_instance (%params)>
531 This method is used to construct an instace structure suitable for
532 C<bless>-ing into your package of choice. It works in conjunction
533 with the Attribute protocol to collect all applicable attributes.
535 This will construct and instance using a HASH ref as storage
536 (currently only HASH references are supported). This will collect all
537 the applicable attributes and layout out the fields in the HASH ref,
538 it will then initialize them using either use the corresponding key
539 in C<%params> or any default value or initializer found in the
540 attribute meta-object.
542 =item B<clone_instance($instance, %params)>
544 This method is a compliment of C<construct_instance> (which means if
545 you override C<construct_instance>, you need to override this one too).
547 This method will clone the C<$instance> structure created by the
548 C<construct_instance> method, and apply any C<%params> passed to it
549 to change the attribute values. The structure returned is (like with
550 C<construct_instance>) an unC<bless>ed HASH reference, it is your
551 responsibility to then bless this cloned structure into the right
562 This is a read-only attribute which returns the package name for the
563 given B<Class::MOP::Class> instance.
567 This is a read-only attribute which returns the C<$VERSION> of the
568 package for the given B<Class::MOP::Class> instance.
572 =head2 Inheritance Relationships
576 =item B<superclasses (?@superclasses)>
578 This is a read-write attribute which represents the superclass
579 relationships of the class the B<Class::MOP::Class> instance is
580 associated with. Basically, it can get and set the C<@ISA> for you.
583 Perl will occasionally perform some C<@ISA> and method caching, if
584 you decide to change your superclass relationship at runtime (which
585 is quite insane and very much not recommened), then you should be
586 aware of this and the fact that this module does not make any
587 attempt to address this issue.
589 =item B<class_precedence_list>
591 This computes the a list of all the class's ancestors in the same order
592 in which method dispatch will be done. This is similair to
593 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
601 =item B<method_metaclass>
603 =item B<add_method ($method_name, $method)>
605 This will take a C<$method_name> and CODE reference to that
606 C<$method> and install it into the class's package.
609 This does absolutely nothing special to C<$method>
610 other than use B<Sub::Name> to make sure it is tagged with the
611 correct name, and therefore show up correctly in stack traces and
614 =item B<has_method ($method_name)>
616 This just provides a simple way to check if the class implements
617 a specific C<$method_name>. It will I<not> however, attempt to check
618 if the class inherits the method (use C<UNIVERSAL::can> for that).
620 This will correctly handle functions defined outside of the package
621 that use a fully qualified name (C<sub Package::name { ... }>).
623 This will correctly handle functions renamed with B<Sub::Name> and
624 installed using the symbol tables. However, if you are naming the
625 subroutine outside of the package scope, you must use the fully
626 qualified name, including the package name, for C<has_method> to
627 correctly identify it.
629 This will attempt to correctly ignore functions imported from other
630 packages using B<Exporter>. It breaks down if the function imported
631 is an C<__ANON__> sub (such as with C<use constant>), which very well
632 may be a valid method being applied to the class.
634 In short, this method cannot always be trusted to determine if the
635 C<$method_name> is actually a method. However, it will DWIM about
636 90% of the time, so it's a small trade off I think.
638 =item B<get_method ($method_name)>
640 This will return a CODE reference of the specified C<$method_name>,
641 or return undef if that method does not exist.
643 =item B<remove_method ($method_name)>
645 This will attempt to remove a given C<$method_name> from the class.
646 It will return the CODE reference that it has removed, and will
647 attempt to use B<Sub::Name> to clear the methods associated name.
649 =item B<get_method_list>
651 This will return a list of method names for all I<locally> defined
652 methods. It does B<not> provide a list of all applicable methods,
653 including any inherited ones. If you want a list of all applicable
654 methods, use the C<compute_all_applicable_methods> method.
656 =item B<compute_all_applicable_methods>
658 This will return a list of all the methods names this class will
659 respond to, taking into account inheritance. The list will be a list of
660 HASH references, each one containing the following information; method
661 name, the name of the class in which the method lives and a CODE
662 reference for the actual method.
664 =item B<find_all_methods_by_name ($method_name)>
666 This will traverse the inheritence hierarchy and locate all methods
667 with a given C<$method_name>. Similar to
668 C<compute_all_applicable_methods> it returns a list of HASH references
669 with the following information; method name (which will always be the
670 same as C<$method_name>), the name of the class in which the method
671 lives and a CODE reference for the actual method.
673 The list of methods produced is a distinct list, meaning there are no
674 duplicates in it. This is especially useful for things like object
675 initialization and destruction where you only want the method called
676 once, and in the correct order.
682 It should be noted that since there is no one consistent way to define
683 the attributes of a class in Perl 5. These methods can only work with
684 the information given, and can not easily discover information on
685 their own. See L<Class::MOP::Attribute> for more details.
689 =item B<attribute_metaclass>
691 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
693 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
694 instance associated with the given class, and associates it with
695 the C<$attribute_name>. Unlike methods, attributes within the MOP
696 are stored as meta-information only. They will be used later to
697 construct instances from (see C<construct_instance> above).
698 More details about the attribute meta-objects can be found in the
699 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
702 It should be noted that any accessor, reader/writer or predicate
703 methods which the C<$attribute_meta_object> has will be installed
704 into the class at this time.
706 =item B<has_attribute ($attribute_name)>
708 Checks to see if this class has an attribute by the name of
709 C<$attribute_name> and returns a boolean.
711 =item B<get_attribute ($attribute_name)>
713 Returns the attribute meta-object associated with C<$attribute_name>,
714 if none is found, it will return undef.
716 =item B<remove_attribute ($attribute_name)>
718 This will remove the attribute meta-object stored at
719 C<$attribute_name>, then return the removed attribute meta-object.
722 Removing an attribute will only affect future instances of
723 the class, it will not make any attempt to remove the attribute from
724 any existing instances of the class.
726 It should be noted that any accessor, reader/writer or predicate
727 methods which the attribute meta-object stored at C<$attribute_name>
728 has will be removed from the class at this time. This B<will> make
729 these attributes somewhat inaccessable in previously created
730 instances. But if you are crazy enough to do this at runtime, then
731 you are crazy enough to deal with something like this :).
733 =item B<get_attribute_list>
735 This returns a list of attribute names which are defined in the local
736 class. If you want a list of all applicable attributes for a class,
737 use the C<compute_all_applicable_attributes> method.
739 =item B<compute_all_applicable_attributes>
741 This will traverse the inheritance heirachy and return a list of all
742 the applicable attributes for this class. It does not construct a
743 HASH reference like C<compute_all_applicable_methods> because all
744 that same information is discoverable through the attribute
749 =head2 Package Variables
751 Since Perl's classes are built atop the Perl package system, it is
752 fairly common to use package scoped variables for things like static
753 class variables. The following methods are convience methods for
754 the creation and inspection of package scoped variables.
758 =item B<add_package_variable ($variable_name, ?$initial_value)>
760 Given a C<$variable_name>, which must contain a leading sigil, this
761 method will create that variable within the package which houses the
762 class. It also takes an optional C<$initial_value>, which must be a
763 reference of the same type as the sigil of the C<$variable_name>
766 =item B<get_package_variable ($variable_name)>
768 This will return a reference to the package variable in
771 =item B<has_package_variable ($variable_name)>
773 Returns true (C<1>) if there is a package variable defined for
774 C<$variable_name>, and false (C<0>) otherwise.
776 =item B<remove_package_variable ($variable_name)>
778 This will attempt to remove the package variable at C<$variable_name>.
784 Stevan Little E<lt>stevan@iinteractive.comE<gt>
786 =head1 COPYRIGHT AND LICENSE
788 Copyright 2006 by Infinity Interactive, Inc.
790 L<http://www.iinteractive.com>
792 This library is free software; you can redistribute it and/or modify
793 it under the same terms as Perl itself.