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.01';
16 sub meta { $_[0]->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?
27 my ($class, $package_name) = @_;
28 (defined $package_name && $package_name)
29 || confess "You must pass a package name";
30 return $METAS{$package_name} if exists $METAS{$package_name};
31 $METAS{$package_name} = $class->construct_class_instance($package_name);
34 # NOTE: (meta-circularity)
35 # this is a special form of &construct_instance
36 # (see below), which is used to construct class
37 # meta-object instances for any Class::MOP::*
38 # class. All other classes will use the more
39 # normal &construct_instance.
40 sub construct_class_instance {
41 my ($class, $package_name) = @_;
42 (defined $package_name && $package_name)
43 || confess "You must pass a package name";
44 $class = blessed($class) || $class;
45 if ($class =~ /^Class::MOP::/) {
47 '$:pkg' => $package_name,
52 bless $class->meta->construct_instance(':pkg' => $package_name) => $class
58 my ($class, $package_name, $package_version, %options) = @_;
59 (defined $package_name && $package_name)
60 || confess "You must pass a package name";
61 my $code = "package $package_name;";
62 $code .= "\$$package_name\:\:VERSION = '$package_version';"
63 if defined $package_version;
65 confess "creation of $package_name failed : $@" if $@;
66 my $meta = $class->initialize($package_name);
67 $meta->superclasses(@{$options{superclasses}})
68 if exists $options{superclasses};
70 # process attributes first, so that they can
71 # install accessors, but locally defined methods
72 # can then overwrite them. It is maybe a little odd, but
73 # I think this should be the order of things.
74 if (exists $options{attributes}) {
75 foreach my $attr (@{$options{attributes}}) {
76 $meta->add_attribute($attr);
79 if (exists $options{methods}) {
80 foreach my $method_name (keys %{$options{methods}}) {
81 $meta->add_method($method_name, $options{methods}->{$method_name});
87 # Instance Construction
89 sub construct_instance {
90 my ($class, %params) = @_;
92 foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
93 # if the attr has an init_arg, use that, otherwise,
94 # use the attributes name itself as the init_arg
95 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
96 # try to fetch the init arg from the %params ...
98 $val = $params{$init_arg} if exists $params{$init_arg};
99 # if nothing was in the %params, we can use the
100 # attribute's default value (if it has one)
101 $val ||= $attr->default($instance) if $attr->has_default();
102 # now add this to the instance structure
103 $instance->{$attr->name} = $val;
110 sub name { $_[0]->{'$:pkg'} }
115 ${$self->name . '::VERSION'};
125 @{$self->name . '::ISA'} = @supers;
127 @{$self->name . '::ISA'};
130 sub class_precedence_list {
133 # We need to check for ciruclar inheirtance here.
134 # This will do nothing if all is well, and blow
135 # up otherwise. Yes, it's an ugly hack, better
136 # suggestions are welcome.
137 { $self->name->isa('This is a test for circular inheritance') }
138 # ... and no back to our regularly scheduled program
142 $self->initialize($_)->class_precedence_list()
143 } $self->superclasses()
150 my ($self, $method_name, $method) = @_;
151 (defined $method_name && $method_name)
152 || confess "You must define a method name";
153 # use reftype here to allow for blessed subs ...
154 (reftype($method) && reftype($method) eq 'CODE')
155 || confess "Your code block must be a CODE reference";
156 my $full_method_name = ($self->name . '::' . $method_name);
159 no warnings 'redefine';
160 *{$full_method_name} = subname $full_method_name => $method;
165 ## private utility functions for has_method
166 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
167 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
170 my ($self, $method_name) = @_;
171 (defined $method_name && $method_name)
172 || confess "You must define a method name";
174 my $sub_name = ($self->name . '::' . $method_name);
177 return 0 if !defined(&{$sub_name});
178 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
179 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
186 my ($self, $method_name) = @_;
187 (defined $method_name && $method_name)
188 || confess "You must define a method name";
191 return \&{$self->name . '::' . $method_name}
192 if $self->has_method($method_name);
193 return; # <- make sure to return undef
197 my ($self, $method_name) = @_;
198 (defined $method_name && $method_name)
199 || confess "You must define a method name";
201 my $removed_method = $self->get_method($method_name);
204 delete ${$self->name . '::'}{$method_name}
205 if defined $removed_method;
207 return $removed_method;
210 sub get_method_list {
213 grep { $self->has_method($_) } %{$self->name . '::'};
216 sub compute_all_applicable_methods {
219 # keep a record of what we have seen
220 # here, this will handle all the
221 # inheritence issues because we are
222 # using the &class_precedence_list
223 my (%seen_class, %seen_method);
224 foreach my $class ($self->class_precedence_list()) {
225 next if $seen_class{$class};
226 $seen_class{$class}++;
227 # fetch the meta-class ...
228 my $meta = $self->initialize($class);
229 foreach my $method_name ($meta->get_method_list()) {
230 next if exists $seen_method{$method_name};
231 $seen_method{$method_name}++;
233 name => $method_name,
235 code => $meta->get_method($method_name)
242 sub find_all_methods_by_name {
243 my ($self, $method_name) = @_;
244 (defined $method_name && $method_name)
245 || confess "You must define a method name to find";
247 # keep a record of what we have seen
248 # here, this will handle all the
249 # inheritence issues because we are
250 # using the &class_precedence_list
252 foreach my $class ($self->class_precedence_list()) {
253 next if $seen_class{$class};
254 $seen_class{$class}++;
255 # fetch the meta-class ...
256 my $meta = $self->initialize($class);
258 name => $method_name,
260 code => $meta->get_method($method_name)
261 } if $meta->has_method($method_name);
270 my ($self,$attribute) = @_;
271 (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
272 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
273 $attribute->install_accessors($self);
274 $self->{'%:attrs'}->{$attribute->name} = $attribute;
278 my ($self, $attribute_name) = @_;
279 (defined $attribute_name && $attribute_name)
280 || confess "You must define an attribute name";
281 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
285 my ($self, $attribute_name) = @_;
286 (defined $attribute_name && $attribute_name)
287 || confess "You must define an attribute name";
288 return $self->{'%:attrs'}->{$attribute_name}
289 if $self->has_attribute($attribute_name);
292 sub remove_attribute {
293 my ($self, $attribute_name) = @_;
294 (defined $attribute_name && $attribute_name)
295 || confess "You must define an attribute name";
296 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
297 delete $self->{'%:attrs'}->{$attribute_name}
298 if defined $removed_attribute;
299 $removed_attribute->remove_accessors($self);
300 return $removed_attribute;
303 sub get_attribute_list {
305 keys %{$self->{'%:attrs'}};
308 sub compute_all_applicable_attributes {
311 # keep a record of what we have seen
312 # here, this will handle all the
313 # inheritence issues because we are
314 # using the &class_precedence_list
315 my (%seen_class, %seen_attr);
316 foreach my $class ($self->class_precedence_list()) {
317 next if $seen_class{$class};
318 $seen_class{$class}++;
319 # fetch the meta-class ...
320 my $meta = $self->initialize($class);
321 foreach my $attr_name ($meta->get_attribute_list()) {
322 next if exists $seen_attr{$attr_name};
323 $seen_attr{$attr_name}++;
327 attribute => $meta->get_attribute($attr_name)
336 sub add_package_variable {
337 my ($self, $variable, $initial_value) = @_;
338 (defined $variable && $variable =~ /^[\$\@\%]/)
339 || confess "variable name does not have a sigil";
341 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
342 if (defined $initial_value) {
344 *{$self->name . '::' . $name} = $initial_value;
347 eval $sigil . $self->name . '::' . $name;
348 confess "Could not create package variable ($variable) because : $@" if $@;
352 sub has_package_variable {
353 my ($self, $variable) = @_;
354 (defined $variable && $variable =~ /^[\$\@\%]/)
355 || confess "variable name does not have a sigil";
356 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
358 defined ${$self->name . '::'}{$name} ? 1 : 0;
361 sub get_package_variable {
362 my ($self, $variable) = @_;
363 (defined $variable && $variable =~ /^[\$\@\%]/)
364 || confess "variable name does not have a sigil";
365 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
367 # try to fetch it first,.. see what happens
368 eval '\\' . $sigil . $self->name . '::' . $name;
369 confess "Could not get the package variable ($variable) because : $@" if $@;
370 # if we didn't die, then we can return it
372 # this is not ideal, better suggestions are welcome
373 eval '\\' . $sigil . $self->name . '::' . $name;
376 sub remove_package_variable {
377 my ($self, $variable) = @_;
378 (defined $variable && $variable =~ /^[\$\@\%]/)
379 || confess "variable name does not have a sigil";
380 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
382 delete ${$self->name . '::'}{$name};
393 Class::MOP::Class - Class Meta Object
397 # use this for introspection ...
400 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
402 # elsewhere in the code ...
404 # add a method to Foo ...
405 Foo->meta->add_method('bar' => sub { ... })
407 # get a list of all the classes searched
408 # the method dispatcher in the correct order
409 Foo->meta->class_precedence_list()
411 # remove a method from Foo
412 Foo->meta->remove_method('bar');
414 # or use this to actually create classes ...
416 Class::MOP::Class->create('Bar' => '0.01' => (
417 superclasses => [ 'Foo' ],
419 Class::MOP:::Attribute->new('$bar'),
420 Class::MOP:::Attribute->new('$baz'),
423 calculate_bar => sub { ... },
424 construct_baz => sub { ... }
430 This is the largest and currently most complex part of the Perl 5
431 meta-object protocol. It controls the introspection and
432 manipulation of Perl 5 classes (and it can create them too). The
433 best way to understand what this module can do, is to read the
434 documentation for each of it's methods.
438 =head2 Self Introspection
444 This will return a B<Class::MOP::Class> instance which is related
445 to this class. Thereby allowing B<Class::MOP::Class> to actually
448 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
449 bootstrap this module by installing a number of attribute meta-objects
450 into it's metaclass. This will allow this class to reap all the benifits
451 of the MOP when subclassing it.
455 =head2 Class construction
457 These methods will handle creating B<Class::MOP::Class> objects,
458 which can be used to both create new classes, and analyze
459 pre-existing classes.
461 This module will internally store references to all the instances
462 you create with these methods, so that they do not need to be
463 created any more than nessecary. Basically, they are singletons.
467 =item B<create ($package_name, ?$package_version,
468 superclasses =E<gt> ?@superclasses,
469 methods =E<gt> ?%methods,
470 attributes =E<gt> ?%attributes)>
472 This returns a B<Class::MOP::Class> object, bringing the specified
473 C<$package_name> into existence and adding any of the
474 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
477 =item B<initialize ($package_name)>
479 This initializes and returns returns a B<Class::MOP::Class> object
480 for a given a C<$package_name>.
482 =item B<construct_class_instance ($package_name)>
484 This will construct an instance of B<Class::MOP::Class>, it is
485 here so that we can actually "tie the knot" for B<Class::MOP::Class>
486 to use C<construct_instance> once all the bootstrapping is done. This
487 method is used internally by C<initialize> and should never be called
488 from outside of that method really.
492 =head2 Object instance construction
494 This method is used to construct an instace structure suitable for
495 C<bless>-ing into your package of choice. It works in conjunction
496 with the Attribute protocol to collect all applicable attributes.
498 This method is B<entirely optional>, it is up to you whether you want
503 =item B<construct_instance (%params)>
505 This will construct and instance using a HASH ref as storage
506 (currently only HASH references are supported). This will collect all
507 the applicable attributes and layout out the fields in the HASH ref,
508 it will then initialize them using either use the corresponding key
509 in C<%params> or any default value or initializer found in the
510 attribute meta-object.
520 This is a read-only attribute which returns the package name for the
521 given B<Class::MOP::Class> instance.
525 This is a read-only attribute which returns the C<$VERSION> of the
526 package for the given B<Class::MOP::Class> instance.
530 =head2 Inheritance Relationships
534 =item B<superclasses (?@superclasses)>
536 This is a read-write attribute which represents the superclass
537 relationships of the class the B<Class::MOP::Class> instance is
538 associated with. Basically, it can get and set the C<@ISA> for you.
540 =item B<class_precedence_list>
542 This computes the a list of all the class's ancestors in the same order
543 in which method dispatch will be done. This is similair to
544 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
552 =item B<add_method ($method_name, $method)>
554 This will take a C<$method_name> and CODE reference to that
555 C<$method> and install it into the class's package.
558 This does absolutely nothing special to C<$method>
559 other than use B<Sub::Name> to make sure it is tagged with the
560 correct name, and therefore show up correctly in stack traces and
563 =item B<has_method ($method_name)>
565 This just provides a simple way to check if the class implements
566 a specific C<$method_name>. It will I<not> however, attempt to check
567 if the class inherits the method (use C<UNIVERSAL::can> for that).
569 This will correctly handle functions defined outside of the package
570 that use a fully qualified name (C<sub Package::name { ... }>).
572 This will correctly handle functions renamed with B<Sub::Name> and
573 installed using the symbol tables. However, if you are naming the
574 subroutine outside of the package scope, you must use the fully
575 qualified name, including the package name, for C<has_method> to
576 correctly identify it.
578 This will attempt to correctly ignore functions imported from other
579 packages using B<Exporter>. It breaks down if the function imported
580 is an C<__ANON__> sub (such as with C<use constant>), which very well
581 may be a valid method being applied to the class.
583 In short, this method cannot always be trusted to determine if the
584 C<$method_name> is actually a method. However, it will DWIM about
585 90% of the time, so it's a small trade off I think.
587 =item B<get_method ($method_name)>
589 This will return a CODE reference of the specified C<$method_name>,
590 or return undef if that method does not exist.
592 =item B<remove_method ($method_name)>
594 This will attempt to remove a given C<$method_name> from the class.
595 It will return the CODE reference that it has removed, and will
596 attempt to use B<Sub::Name> to clear the methods associated name.
598 =item B<get_method_list>
600 This will return a list of method names for all I<locally> defined
601 methods. It does B<not> provide a list of all applicable methods,
602 including any inherited ones. If you want a list of all applicable
603 methods, use the C<compute_all_applicable_methods> method.
605 =item B<compute_all_applicable_methods>
607 This will return a list of all the methods names this class will
608 respond to, taking into account inheritance. The list will be a list of
609 HASH references, each one containing the following information; method
610 name, the name of the class in which the method lives and a CODE
611 reference for the actual method.
613 =item B<find_all_methods_by_name ($method_name)>
615 This will traverse the inheritence hierarchy and locate all methods
616 with a given C<$method_name>. Similar to
617 C<compute_all_applicable_methods> it returns a list of HASH references
618 with the following information; method name (which will always be the
619 same as C<$method_name>), the name of the class in which the method
620 lives and a CODE reference for the actual method.
622 The list of methods produced is a distinct list, meaning there are no
623 duplicates in it. This is especially useful for things like object
624 initialization and destruction where you only want the method called
625 once, and in the correct order.
631 It should be noted that since there is no one consistent way to define
632 the attributes of a class in Perl 5. These methods can only work with
633 the information given, and can not easily discover information on
634 their own. See L<Class::MOP::Attribute> for more details.
638 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
640 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
641 instance associated with the given class, and associates it with
642 the C<$attribute_name>. Unlike methods, attributes within the MOP
643 are stored as meta-information only. They will be used later to
644 construct instances from (see C<construct_instance> above).
645 More details about the attribute meta-objects can be found in the
646 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
649 It should be noted that any accessor, reader/writer or predicate
650 methods which the C<$attribute_meta_object> has will be installed
651 into the class at this time.
653 =item B<has_attribute ($attribute_name)>
655 Checks to see if this class has an attribute by the name of
656 C<$attribute_name> and returns a boolean.
658 =item B<get_attribute ($attribute_name)>
660 Returns the attribute meta-object associated with C<$attribute_name>,
661 if none is found, it will return undef.
663 =item B<remove_attribute ($attribute_name)>
665 This will remove the attribute meta-object stored at
666 C<$attribute_name>, then return the removed attribute meta-object.
669 Removing an attribute will only affect future instances of
670 the class, it will not make any attempt to remove the attribute from
671 any existing instances of the class.
673 It should be noted that any accessor, reader/writer or predicate
674 methods which the attribute meta-object stored at C<$attribute_name>
675 has will be removed from the class at this time. This B<will> make
676 these attributes somewhat inaccessable in previously created
677 instances. But if you are crazy enough to do this at runtime, then
678 you are crazy enough to deal with something like this :).
680 =item B<get_attribute_list>
682 This returns a list of attribute names which are defined in the local
683 class. If you want a list of all applicable attributes for a class,
684 use the C<compute_all_applicable_attributes> method.
686 =item B<compute_all_applicable_attributes>
688 This will traverse the inheritance heirachy and return a list of HASH
689 references for all the applicable attributes for this class. The HASH
690 references will contain the following information; the attribute name,
691 the class which the attribute is associated with and the actual
692 attribute meta-object.
696 =head2 Package Variables
698 Since Perl's classes are built atop the Perl package system, it is
699 fairly common to use package scoped variables for things like static
700 class variables. The following methods are convience methods for
701 the creation and inspection of package scoped variables.
705 =item B<add_package_variable ($variable_name, ?$initial_value)>
707 Given a C<$variable_name>, which must contain a leading sigil, this
708 method will create that variable within the package which houses the
709 class. It also takes an optional C<$initial_value>, which must be a
710 reference of the same type as the sigil of the C<$variable_name>
713 =item B<get_package_variable ($variable_name)>
715 This will return a reference to the package variable in
718 =item B<has_package_variable ($variable_name)>
720 Returns true (C<1>) if there is a package variable defined for
721 C<$variable_name>, and false (C<0>) otherwise.
723 =item B<remove_package_variable ($variable_name)>
725 This will attempt to remove the package variable at C<$variable_name>.
731 Stevan Little E<lt>stevan@iinteractive.comE<gt>
733 =head1 COPYRIGHT AND LICENSE
735 Copyright 2006 by Infinity Interactive, Inc.
737 L<http://www.iinteractive.com>
739 This library is free software; you can redistribute it and/or modify
740 it under the same terms as Perl itself.