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 handle creating Class objects, which can be used to
458 both create new classes, and analyze pre-existing ones.
460 This module will internally store references to all the instances
461 you create with these methods, so that they do not need to be
462 created any more than nessecary. Basically, they are singletons.
466 =item B<create ($package_name, ?$package_version,
467 superclasses => ?@superclasses,
468 methods => ?%methods,
469 attributes => ?%attributes)>
471 This returns the basic Class object, bringing the specified
472 C<$package_name> into existence and adding any of the
473 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
476 =item B<initialize ($package_name)>
478 This initializes a Class object for a given a C<$package_name>.
482 =head2 Instance construction
486 =item B<construct_instance (%params)>
488 This will construct and instance using a HASH ref as storage
489 (currently only HASH references are supported). This will collect all
490 the applicable attribute meta-objects and layout out the fields in the
491 HASH ref, it will then initialize them using either use the
492 corresponding key in C<%params> or any default value or initializer
493 found in the attribute meta-object.
495 =item B<construct_class_instance ($package_name)>
497 This will construct an instance of B<Class::MOP::Class>, it is
498 here so that we can actually "tie the knot" for B<Class::MOP::Class>
499 to use C<construct_instance> once all the bootstrapping is done. This
500 method is used internally by C<initialize> and should never be called
501 from outside of that method really.
511 This is a read-only attribute which returns the package name that
512 the Class is stored in.
516 This is a read-only attribute which returns the C<$VERSION> of the
517 package the Class is stored in.
521 =head2 Inheritance Relationships
525 =item B<superclasses (?@superclasses)>
527 This is a read-write attribute which represents the superclass
528 relationships of this Class. Basically, it can get and set the
531 =item B<class_precedence_list>
533 This computes the a list of the Class's ancestors in the same order
534 in which method dispatch will be done.
542 =item B<add_method ($method_name, $method)>
544 This will take a C<$method_name> and CODE reference to that
545 C<$method> and install it into the Class.
547 B<NOTE> : This does absolutely nothing special to C<$method>
548 other than use B<Sub::Name> to make sure it is tagged with the
549 correct name, and therefore show up correctly in stack traces and
552 =item B<has_method ($method_name)>
554 This just provides a simple way to check if the Class implements
555 a specific C<$method_name>. It will I<not> however, attempt to check
556 if the class inherits the method.
558 This will correctly handle functions defined outside of the package
559 that use a fully qualified name (C<sub Package::name { ... }>).
561 This will correctly handle functions renamed with B<Sub::Name> and
562 installed using the symbol tables. However, if you are naming the
563 subroutine outside of the package scope, you must use the fully
564 qualified name, including the package name, for C<has_method> to
565 correctly identify it.
567 This will attempt to correctly ignore functions imported from other
568 packages using B<Exporter>. It breaks down if the function imported
569 is an C<__ANON__> sub (such as with C<use constant>), which very well
570 may be a valid method being applied to the class.
572 In short, this method cannot always be trusted to determine if the
573 C<$method_name> is actually a method. However, it will DWIM about
574 90% of the time, so it's a small trade off IMO.
576 =item B<get_method ($method_name)>
578 This will return a CODE reference of the specified C<$method_name>,
579 or return undef if that method does not exist.
581 =item B<remove_method ($method_name)>
583 This will attempt to remove a given C<$method_name> from the Class.
584 It will return the CODE reference that it has removed, and will
585 attempt to use B<Sub::Name> to clear the methods associated name.
587 =item B<get_method_list>
589 This will return a list of method names for all I<locally> defined
590 methods. It does B<not> provide a list of all applicable methods,
591 including any inherited ones. If you want a list of all applicable
592 methods, use the C<compute_all_applicable_methods> method.
594 =item B<compute_all_applicable_methods>
596 This will return a list of all the methods names this Class will
597 support, taking into account inheritance. The list will be a list of
598 HASH references, each one containing the following information; method
599 name, the name of the class in which the method lives and a CODE
600 reference for the actual method.
602 =item B<find_all_methods_by_name ($method_name)>
604 This will traverse the inheritence hierarchy and locate all methods
605 with a given C<$method_name>. Similar to
606 C<compute_all_applicable_methods> it returns a list of HASH references
607 with the following information; method name (which will always be the
608 same as C<$method_name>), the name of the class in which the method
609 lives and a CODE reference for the actual method.
611 The list of methods produced is a distinct list, meaning there are no
612 duplicates in it. This is especially useful for things like object
613 initialization and destruction where you only want the method called
614 once, and in the correct order.
620 It should be noted that since there is no one consistent way to define
621 the attributes of a class in Perl 5. These methods can only work with
622 the information given, and can not easily discover information on
627 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
629 This stores a C<$attribute_meta_object> in the Class object and
630 associates it with the C<$attribute_name>. Unlike methods, attributes
631 within the MOP are stored as meta-information only. They will be used
632 later to construct instances from (see C<construct_instance> above).
633 More details about the attribute meta-objects can be found in the
634 L<The Attribute protocol> section of this document.
636 =item B<has_attribute ($attribute_name)>
638 Checks to see if this Class has an attribute by the name of
639 C<$attribute_name> and returns a boolean.
641 =item B<get_attribute ($attribute_name)>
643 Returns the attribute meta-object associated with C<$attribute_name>,
644 if none is found, it will return undef.
646 =item B<remove_attribute ($attribute_name)>
648 This will remove the attribute meta-object stored at
649 C<$attribute_name>, then return the removed attribute meta-object.
651 B<NOTE:> Removing an attribute will only affect future instances of
652 the class, it will not make any attempt to remove the attribute from
653 any existing instances of the class.
655 =item B<get_attribute_list>
657 This returns a list of attribute names which are defined in the local
658 class. If you want a list of all applicable attributes for a class,
659 use the C<compute_all_applicable_attributes> method.
661 =item B<compute_all_applicable_attributes>
663 This will traverse the inheritance heirachy and return a list of HASH
664 references for all the applicable attributes for this class. The HASH
665 references will contain the following information; the attribute name,
666 the class which the attribute is associated with and the actual
667 attribute meta-object.
671 =head2 Package Variables
673 Since Perl's classes are built atop the Perl package system, it is
674 fairly common to use package scoped variables for things like static
675 class variables. The following methods are convience methods for
676 the creation and inspection of package scoped variables.
680 =item B<add_package_variable ($variable_name, ?$initial_value)>
682 Given a C<$variable_name>, which must contain a leading sigil, this
683 method will create that variable within the package which houses the
684 class. It also takes an optional C<$initial_value>, which must be a
685 reference of the same type as the sigil of the C<$variable_name>
688 =item B<get_package_variable ($variable_name)>
690 This will return a reference to the package variable in
693 =item B<has_package_variable ($variable_name)>
695 Returns true (C<1>) if there is a package variable defined for
696 C<$variable_name>, and false (C<0>) otherwise.
698 =item B<remove_package_variable ($variable_name)>
700 This will attempt to remove the package variable at C<$variable_name>.
706 Stevan Little E<gt>stevan@iinteractive.comE<lt>
708 =head1 COPYRIGHT AND LICENSE
710 Copyright 2006 by Infinity Interactive, Inc.
712 L<http://www.iinteractive.com>
714 This library is free software; you can redistribute it and/or modify
715 it under the same terms as Perl itself.