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.02';
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()
149 # un-used right now ...
150 sub method_metaclass { 'Class::MOP::Method' }
153 my ($self, $method_name, $method) = @_;
154 (defined $method_name && $method_name)
155 || confess "You must define a method name";
156 # use reftype here to allow for blessed subs ...
157 (reftype($method) && reftype($method) eq 'CODE')
158 || confess "Your code block must be a CODE reference";
159 my $full_method_name = ($self->name . '::' . $method_name);
162 no warnings 'redefine';
163 *{$full_method_name} = subname $full_method_name => $method;
168 ## private utility functions for has_method
169 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
170 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
173 my ($self, $method_name) = @_;
174 (defined $method_name && $method_name)
175 || confess "You must define a method name";
177 my $sub_name = ($self->name . '::' . $method_name);
180 return 0 if !defined(&{$sub_name});
181 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
182 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
189 my ($self, $method_name) = @_;
190 (defined $method_name && $method_name)
191 || confess "You must define a method name";
194 return \&{$self->name . '::' . $method_name}
195 if $self->has_method($method_name);
196 return; # <- make sure to return undef
200 my ($self, $method_name) = @_;
201 (defined $method_name && $method_name)
202 || confess "You must define a method name";
204 my $removed_method = $self->get_method($method_name);
207 delete ${$self->name . '::'}{$method_name}
208 if defined $removed_method;
210 return $removed_method;
213 sub get_method_list {
216 grep { $self->has_method($_) } %{$self->name . '::'};
219 sub compute_all_applicable_methods {
222 # keep a record of what we have seen
223 # here, this will handle all the
224 # inheritence issues because we are
225 # using the &class_precedence_list
226 my (%seen_class, %seen_method);
227 foreach my $class ($self->class_precedence_list()) {
228 next if $seen_class{$class};
229 $seen_class{$class}++;
230 # fetch the meta-class ...
231 my $meta = $self->initialize($class);
232 foreach my $method_name ($meta->get_method_list()) {
233 next if exists $seen_method{$method_name};
234 $seen_method{$method_name}++;
236 name => $method_name,
238 code => $meta->get_method($method_name)
245 sub find_all_methods_by_name {
246 my ($self, $method_name) = @_;
247 (defined $method_name && $method_name)
248 || confess "You must define a method name to find";
250 # keep a record of what we have seen
251 # here, this will handle all the
252 # inheritence issues because we are
253 # using the &class_precedence_list
255 foreach my $class ($self->class_precedence_list()) {
256 next if $seen_class{$class};
257 $seen_class{$class}++;
258 # fetch the meta-class ...
259 my $meta = $self->initialize($class);
261 name => $method_name,
263 code => $meta->get_method($method_name)
264 } if $meta->has_method($method_name);
272 sub attribute_metaclass { 'Class::MOP::Attribute' }
276 # either we have an attribute object already
277 # or we need to create one from the args provided
278 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
279 # make sure it is derived from the correct type though
280 ($attribute->isa('Class::MOP::Attribute'))
281 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
282 $attribute->attach_to_class($self);
283 $attribute->install_accessors();
284 $self->{'%:attrs'}->{$attribute->name} = $attribute;
288 my ($self, $attribute_name) = @_;
289 (defined $attribute_name && $attribute_name)
290 || confess "You must define an attribute name";
291 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
295 my ($self, $attribute_name) = @_;
296 (defined $attribute_name && $attribute_name)
297 || confess "You must define an attribute name";
298 return $self->{'%:attrs'}->{$attribute_name}
299 if $self->has_attribute($attribute_name);
302 sub remove_attribute {
303 my ($self, $attribute_name) = @_;
304 (defined $attribute_name && $attribute_name)
305 || confess "You must define an attribute name";
306 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
307 delete $self->{'%:attrs'}->{$attribute_name}
308 if defined $removed_attribute;
309 $removed_attribute->remove_accessors();
310 $removed_attribute->detach_from_class();
311 return $removed_attribute;
314 sub get_attribute_list {
316 keys %{$self->{'%:attrs'}};
319 sub compute_all_applicable_attributes {
322 # keep a record of what we have seen
323 # here, this will handle all the
324 # inheritence issues because we are
325 # using the &class_precedence_list
326 my (%seen_class, %seen_attr);
327 foreach my $class ($self->class_precedence_list()) {
328 next if $seen_class{$class};
329 $seen_class{$class}++;
330 # fetch the meta-class ...
331 my $meta = $self->initialize($class);
332 foreach my $attr_name ($meta->get_attribute_list()) {
333 next if exists $seen_attr{$attr_name};
334 $seen_attr{$attr_name}++;
338 attribute => $meta->get_attribute($attr_name)
347 sub add_package_variable {
348 my ($self, $variable, $initial_value) = @_;
349 (defined $variable && $variable =~ /^[\$\@\%]/)
350 || confess "variable name does not have a sigil";
352 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
353 if (defined $initial_value) {
355 *{$self->name . '::' . $name} = $initial_value;
358 eval $sigil . $self->name . '::' . $name;
359 confess "Could not create package variable ($variable) because : $@" if $@;
363 sub has_package_variable {
364 my ($self, $variable) = @_;
365 (defined $variable && $variable =~ /^[\$\@\%]/)
366 || confess "variable name does not have a sigil";
367 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
369 defined ${$self->name . '::'}{$name} ? 1 : 0;
372 sub get_package_variable {
373 my ($self, $variable) = @_;
374 (defined $variable && $variable =~ /^[\$\@\%]/)
375 || confess "variable name does not have a sigil";
376 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
378 # try to fetch it first,.. see what happens
379 eval '\\' . $sigil . $self->name . '::' . $name;
380 confess "Could not get the package variable ($variable) because : $@" if $@;
381 # if we didn't die, then we can return it
383 # this is not ideal, better suggestions are welcome
384 eval '\\' . $sigil . $self->name . '::' . $name;
387 sub remove_package_variable {
388 my ($self, $variable) = @_;
389 (defined $variable && $variable =~ /^[\$\@\%]/)
390 || confess "variable name does not have a sigil";
391 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
393 delete ${$self->name . '::'}{$name};
404 Class::MOP::Class - Class Meta Object
408 # use this for introspection ...
411 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
413 # elsewhere in the code ...
415 # add a method to Foo ...
416 Foo->meta->add_method('bar' => sub { ... })
418 # get a list of all the classes searched
419 # the method dispatcher in the correct order
420 Foo->meta->class_precedence_list()
422 # remove a method from Foo
423 Foo->meta->remove_method('bar');
425 # or use this to actually create classes ...
427 Class::MOP::Class->create('Bar' => '0.01' => (
428 superclasses => [ 'Foo' ],
430 Class::MOP:::Attribute->new('$bar'),
431 Class::MOP:::Attribute->new('$baz'),
434 calculate_bar => sub { ... },
435 construct_baz => sub { ... }
441 This is the largest and currently most complex part of the Perl 5
442 meta-object protocol. It controls the introspection and
443 manipulation of Perl 5 classes (and it can create them too). The
444 best way to understand what this module can do, is to read the
445 documentation for each of it's methods.
449 =head2 Self Introspection
455 This will return a B<Class::MOP::Class> instance which is related
456 to this class. Thereby allowing B<Class::MOP::Class> to actually
459 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
460 bootstrap this module by installing a number of attribute meta-objects
461 into it's metaclass. This will allow this class to reap all the benifits
462 of the MOP when subclassing it.
466 =head2 Class construction
468 These methods will handle creating B<Class::MOP::Class> objects,
469 which can be used to both create new classes, and analyze
470 pre-existing classes.
472 This module will internally store references to all the instances
473 you create with these methods, so that they do not need to be
474 created any more than nessecary. Basically, they are singletons.
478 =item B<create ($package_name, ?$package_version,
479 superclasses =E<gt> ?@superclasses,
480 methods =E<gt> ?%methods,
481 attributes =E<gt> ?%attributes)>
483 This returns a B<Class::MOP::Class> object, bringing the specified
484 C<$package_name> into existence and adding any of the
485 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
488 =item B<initialize ($package_name)>
490 This initializes and returns returns a B<Class::MOP::Class> object
491 for a given a C<$package_name>.
493 =item B<construct_class_instance ($package_name)>
495 This will construct an instance of B<Class::MOP::Class>, it is
496 here so that we can actually "tie the knot" for B<Class::MOP::Class>
497 to use C<construct_instance> once all the bootstrapping is done. This
498 method is used internally by C<initialize> and should never be called
499 from outside of that method really.
503 =head2 Object instance construction
505 This method is used to construct an instace structure suitable for
506 C<bless>-ing into your package of choice. It works in conjunction
507 with the Attribute protocol to collect all applicable attributes.
509 This method is B<entirely optional>, it is up to you whether you want
514 =item B<construct_instance (%params)>
516 This will construct and instance using a HASH ref as storage
517 (currently only HASH references are supported). This will collect all
518 the applicable attributes and layout out the fields in the HASH ref,
519 it will then initialize them using either use the corresponding key
520 in C<%params> or any default value or initializer found in the
521 attribute meta-object.
531 This is a read-only attribute which returns the package name for the
532 given B<Class::MOP::Class> instance.
536 This is a read-only attribute which returns the C<$VERSION> of the
537 package for the given B<Class::MOP::Class> instance.
541 =head2 Inheritance Relationships
545 =item B<superclasses (?@superclasses)>
547 This is a read-write attribute which represents the superclass
548 relationships of the class the B<Class::MOP::Class> instance is
549 associated with. Basically, it can get and set the C<@ISA> for you.
552 Perl will occasionally perform some C<@ISA> and method caching, if
553 you decide to change your superclass relationship at runtime (which
554 is quite insane and very much not recommened), then you should be
555 aware of this and the fact that this module does not make any
556 attempt to address this issue.
558 =item B<class_precedence_list>
560 This computes the a list of all the class's ancestors in the same order
561 in which method dispatch will be done. This is similair to
562 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
570 =item B<method_metaclass>
572 =item B<add_method ($method_name, $method)>
574 This will take a C<$method_name> and CODE reference to that
575 C<$method> and install it into the class's package.
578 This does absolutely nothing special to C<$method>
579 other than use B<Sub::Name> to make sure it is tagged with the
580 correct name, and therefore show up correctly in stack traces and
583 =item B<has_method ($method_name)>
585 This just provides a simple way to check if the class implements
586 a specific C<$method_name>. It will I<not> however, attempt to check
587 if the class inherits the method (use C<UNIVERSAL::can> for that).
589 This will correctly handle functions defined outside of the package
590 that use a fully qualified name (C<sub Package::name { ... }>).
592 This will correctly handle functions renamed with B<Sub::Name> and
593 installed using the symbol tables. However, if you are naming the
594 subroutine outside of the package scope, you must use the fully
595 qualified name, including the package name, for C<has_method> to
596 correctly identify it.
598 This will attempt to correctly ignore functions imported from other
599 packages using B<Exporter>. It breaks down if the function imported
600 is an C<__ANON__> sub (such as with C<use constant>), which very well
601 may be a valid method being applied to the class.
603 In short, this method cannot always be trusted to determine if the
604 C<$method_name> is actually a method. However, it will DWIM about
605 90% of the time, so it's a small trade off I think.
607 =item B<get_method ($method_name)>
609 This will return a CODE reference of the specified C<$method_name>,
610 or return undef if that method does not exist.
612 =item B<remove_method ($method_name)>
614 This will attempt to remove a given C<$method_name> from the class.
615 It will return the CODE reference that it has removed, and will
616 attempt to use B<Sub::Name> to clear the methods associated name.
618 =item B<get_method_list>
620 This will return a list of method names for all I<locally> defined
621 methods. It does B<not> provide a list of all applicable methods,
622 including any inherited ones. If you want a list of all applicable
623 methods, use the C<compute_all_applicable_methods> method.
625 =item B<compute_all_applicable_methods>
627 This will return a list of all the methods names this class will
628 respond to, taking into account inheritance. The list will be a list of
629 HASH references, each one containing the following information; method
630 name, the name of the class in which the method lives and a CODE
631 reference for the actual method.
633 =item B<find_all_methods_by_name ($method_name)>
635 This will traverse the inheritence hierarchy and locate all methods
636 with a given C<$method_name>. Similar to
637 C<compute_all_applicable_methods> it returns a list of HASH references
638 with the following information; method name (which will always be the
639 same as C<$method_name>), the name of the class in which the method
640 lives and a CODE reference for the actual method.
642 The list of methods produced is a distinct list, meaning there are no
643 duplicates in it. This is especially useful for things like object
644 initialization and destruction where you only want the method called
645 once, and in the correct order.
651 It should be noted that since there is no one consistent way to define
652 the attributes of a class in Perl 5. These methods can only work with
653 the information given, and can not easily discover information on
654 their own. See L<Class::MOP::Attribute> for more details.
658 =item B<attribute_metaclass>
660 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
662 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
663 instance associated with the given class, and associates it with
664 the C<$attribute_name>. Unlike methods, attributes within the MOP
665 are stored as meta-information only. They will be used later to
666 construct instances from (see C<construct_instance> above).
667 More details about the attribute meta-objects can be found in the
668 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
671 It should be noted that any accessor, reader/writer or predicate
672 methods which the C<$attribute_meta_object> has will be installed
673 into the class at this time.
675 =item B<has_attribute ($attribute_name)>
677 Checks to see if this class has an attribute by the name of
678 C<$attribute_name> and returns a boolean.
680 =item B<get_attribute ($attribute_name)>
682 Returns the attribute meta-object associated with C<$attribute_name>,
683 if none is found, it will return undef.
685 =item B<remove_attribute ($attribute_name)>
687 This will remove the attribute meta-object stored at
688 C<$attribute_name>, then return the removed attribute meta-object.
691 Removing an attribute will only affect future instances of
692 the class, it will not make any attempt to remove the attribute from
693 any existing instances of the class.
695 It should be noted that any accessor, reader/writer or predicate
696 methods which the attribute meta-object stored at C<$attribute_name>
697 has will be removed from the class at this time. This B<will> make
698 these attributes somewhat inaccessable in previously created
699 instances. But if you are crazy enough to do this at runtime, then
700 you are crazy enough to deal with something like this :).
702 =item B<get_attribute_list>
704 This returns a list of attribute names which are defined in the local
705 class. If you want a list of all applicable attributes for a class,
706 use the C<compute_all_applicable_attributes> method.
708 =item B<compute_all_applicable_attributes>
710 This will traverse the inheritance heirachy and return a list of HASH
711 references for all the applicable attributes for this class. The HASH
712 references will contain the following information; the attribute name,
713 the class which the attribute is associated with and the actual
714 attribute meta-object.
718 =head2 Package Variables
720 Since Perl's classes are built atop the Perl package system, it is
721 fairly common to use package scoped variables for things like static
722 class variables. The following methods are convience methods for
723 the creation and inspection of package scoped variables.
727 =item B<add_package_variable ($variable_name, ?$initial_value)>
729 Given a C<$variable_name>, which must contain a leading sigil, this
730 method will create that variable within the package which houses the
731 class. It also takes an optional C<$initial_value>, which must be a
732 reference of the same type as the sigil of the C<$variable_name>
735 =item B<get_package_variable ($variable_name)>
737 This will return a reference to the package variable in
740 =item B<has_package_variable ($variable_name)>
742 Returns true (C<1>) if there is a package variable defined for
743 C<$variable_name>, and false (C<0>) otherwise.
745 =item B<remove_package_variable ($variable_name)>
747 This will attempt to remove the package variable at C<$variable_name>.
753 Stevan Little E<lt>stevan@iinteractive.comE<gt>
755 =head1 COPYRIGHT AND LICENSE
757 Copyright 2006 by Infinity Interactive, Inc.
759 L<http://www.iinteractive.com>
761 This library is free software; you can redistribute it and/or modify
762 it under the same terms as Perl itself.