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->attach_to_class($self);
274 $attribute->install_accessors();
275 $self->{'%:attrs'}->{$attribute->name} = $attribute;
279 my ($self, $attribute_name) = @_;
280 (defined $attribute_name && $attribute_name)
281 || confess "You must define an attribute name";
282 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
286 my ($self, $attribute_name) = @_;
287 (defined $attribute_name && $attribute_name)
288 || confess "You must define an attribute name";
289 return $self->{'%:attrs'}->{$attribute_name}
290 if $self->has_attribute($attribute_name);
293 sub remove_attribute {
294 my ($self, $attribute_name) = @_;
295 (defined $attribute_name && $attribute_name)
296 || confess "You must define an attribute name";
297 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
298 delete $self->{'%:attrs'}->{$attribute_name}
299 if defined $removed_attribute;
300 $removed_attribute->remove_accessors();
301 $removed_attribute->detach_from_class();
302 return $removed_attribute;
305 sub get_attribute_list {
307 keys %{$self->{'%:attrs'}};
310 sub compute_all_applicable_attributes {
313 # keep a record of what we have seen
314 # here, this will handle all the
315 # inheritence issues because we are
316 # using the &class_precedence_list
317 my (%seen_class, %seen_attr);
318 foreach my $class ($self->class_precedence_list()) {
319 next if $seen_class{$class};
320 $seen_class{$class}++;
321 # fetch the meta-class ...
322 my $meta = $self->initialize($class);
323 foreach my $attr_name ($meta->get_attribute_list()) {
324 next if exists $seen_attr{$attr_name};
325 $seen_attr{$attr_name}++;
329 attribute => $meta->get_attribute($attr_name)
338 sub add_package_variable {
339 my ($self, $variable, $initial_value) = @_;
340 (defined $variable && $variable =~ /^[\$\@\%]/)
341 || confess "variable name does not have a sigil";
343 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
344 if (defined $initial_value) {
346 *{$self->name . '::' . $name} = $initial_value;
349 eval $sigil . $self->name . '::' . $name;
350 confess "Could not create package variable ($variable) because : $@" if $@;
354 sub has_package_variable {
355 my ($self, $variable) = @_;
356 (defined $variable && $variable =~ /^[\$\@\%]/)
357 || confess "variable name does not have a sigil";
358 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
360 defined ${$self->name . '::'}{$name} ? 1 : 0;
363 sub get_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 # try to fetch it first,.. see what happens
370 eval '\\' . $sigil . $self->name . '::' . $name;
371 confess "Could not get the package variable ($variable) because : $@" if $@;
372 # if we didn't die, then we can return it
374 # this is not ideal, better suggestions are welcome
375 eval '\\' . $sigil . $self->name . '::' . $name;
378 sub remove_package_variable {
379 my ($self, $variable) = @_;
380 (defined $variable && $variable =~ /^[\$\@\%]/)
381 || confess "variable name does not have a sigil";
382 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
384 delete ${$self->name . '::'}{$name};
395 Class::MOP::Class - Class Meta Object
399 # use this for introspection ...
402 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
404 # elsewhere in the code ...
406 # add a method to Foo ...
407 Foo->meta->add_method('bar' => sub { ... })
409 # get a list of all the classes searched
410 # the method dispatcher in the correct order
411 Foo->meta->class_precedence_list()
413 # remove a method from Foo
414 Foo->meta->remove_method('bar');
416 # or use this to actually create classes ...
418 Class::MOP::Class->create('Bar' => '0.01' => (
419 superclasses => [ 'Foo' ],
421 Class::MOP:::Attribute->new('$bar'),
422 Class::MOP:::Attribute->new('$baz'),
425 calculate_bar => sub { ... },
426 construct_baz => sub { ... }
432 This is the largest and currently most complex part of the Perl 5
433 meta-object protocol. It controls the introspection and
434 manipulation of Perl 5 classes (and it can create them too). The
435 best way to understand what this module can do, is to read the
436 documentation for each of it's methods.
440 =head2 Self Introspection
446 This will return a B<Class::MOP::Class> instance which is related
447 to this class. Thereby allowing B<Class::MOP::Class> to actually
450 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
451 bootstrap this module by installing a number of attribute meta-objects
452 into it's metaclass. This will allow this class to reap all the benifits
453 of the MOP when subclassing it.
457 =head2 Class construction
459 These methods will handle creating B<Class::MOP::Class> objects,
460 which can be used to both create new classes, and analyze
461 pre-existing classes.
463 This module will internally store references to all the instances
464 you create with these methods, so that they do not need to be
465 created any more than nessecary. Basically, they are singletons.
469 =item B<create ($package_name, ?$package_version,
470 superclasses =E<gt> ?@superclasses,
471 methods =E<gt> ?%methods,
472 attributes =E<gt> ?%attributes)>
474 This returns a B<Class::MOP::Class> object, bringing the specified
475 C<$package_name> into existence and adding any of the
476 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
479 =item B<initialize ($package_name)>
481 This initializes and returns returns a B<Class::MOP::Class> object
482 for a given a C<$package_name>.
484 =item B<construct_class_instance ($package_name)>
486 This will construct an instance of B<Class::MOP::Class>, it is
487 here so that we can actually "tie the knot" for B<Class::MOP::Class>
488 to use C<construct_instance> once all the bootstrapping is done. This
489 method is used internally by C<initialize> and should never be called
490 from outside of that method really.
494 =head2 Object instance construction
496 This method is used to construct an instace structure suitable for
497 C<bless>-ing into your package of choice. It works in conjunction
498 with the Attribute protocol to collect all applicable attributes.
500 This method is B<entirely optional>, it is up to you whether you want
505 =item B<construct_instance (%params)>
507 This will construct and instance using a HASH ref as storage
508 (currently only HASH references are supported). This will collect all
509 the applicable attributes and layout out the fields in the HASH ref,
510 it will then initialize them using either use the corresponding key
511 in C<%params> or any default value or initializer found in the
512 attribute meta-object.
522 This is a read-only attribute which returns the package name for the
523 given B<Class::MOP::Class> instance.
527 This is a read-only attribute which returns the C<$VERSION> of the
528 package for the given B<Class::MOP::Class> instance.
532 =head2 Inheritance Relationships
536 =item B<superclasses (?@superclasses)>
538 This is a read-write attribute which represents the superclass
539 relationships of the class the B<Class::MOP::Class> instance is
540 associated with. Basically, it can get and set the C<@ISA> for you.
542 =item B<class_precedence_list>
544 This computes the a list of all the class's ancestors in the same order
545 in which method dispatch will be done. This is similair to
546 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
554 =item B<add_method ($method_name, $method)>
556 This will take a C<$method_name> and CODE reference to that
557 C<$method> and install it into the class's package.
560 This does absolutely nothing special to C<$method>
561 other than use B<Sub::Name> to make sure it is tagged with the
562 correct name, and therefore show up correctly in stack traces and
565 =item B<has_method ($method_name)>
567 This just provides a simple way to check if the class implements
568 a specific C<$method_name>. It will I<not> however, attempt to check
569 if the class inherits the method (use C<UNIVERSAL::can> for that).
571 This will correctly handle functions defined outside of the package
572 that use a fully qualified name (C<sub Package::name { ... }>).
574 This will correctly handle functions renamed with B<Sub::Name> and
575 installed using the symbol tables. However, if you are naming the
576 subroutine outside of the package scope, you must use the fully
577 qualified name, including the package name, for C<has_method> to
578 correctly identify it.
580 This will attempt to correctly ignore functions imported from other
581 packages using B<Exporter>. It breaks down if the function imported
582 is an C<__ANON__> sub (such as with C<use constant>), which very well
583 may be a valid method being applied to the class.
585 In short, this method cannot always be trusted to determine if the
586 C<$method_name> is actually a method. However, it will DWIM about
587 90% of the time, so it's a small trade off I think.
589 =item B<get_method ($method_name)>
591 This will return a CODE reference of the specified C<$method_name>,
592 or return undef if that method does not exist.
594 =item B<remove_method ($method_name)>
596 This will attempt to remove a given C<$method_name> from the class.
597 It will return the CODE reference that it has removed, and will
598 attempt to use B<Sub::Name> to clear the methods associated name.
600 =item B<get_method_list>
602 This will return a list of method names for all I<locally> defined
603 methods. It does B<not> provide a list of all applicable methods,
604 including any inherited ones. If you want a list of all applicable
605 methods, use the C<compute_all_applicable_methods> method.
607 =item B<compute_all_applicable_methods>
609 This will return a list of all the methods names this class will
610 respond to, taking into account inheritance. The list will be a list of
611 HASH references, each one containing the following information; method
612 name, the name of the class in which the method lives and a CODE
613 reference for the actual method.
615 =item B<find_all_methods_by_name ($method_name)>
617 This will traverse the inheritence hierarchy and locate all methods
618 with a given C<$method_name>. Similar to
619 C<compute_all_applicable_methods> it returns a list of HASH references
620 with the following information; method name (which will always be the
621 same as C<$method_name>), the name of the class in which the method
622 lives and a CODE reference for the actual method.
624 The list of methods produced is a distinct list, meaning there are no
625 duplicates in it. This is especially useful for things like object
626 initialization and destruction where you only want the method called
627 once, and in the correct order.
633 It should be noted that since there is no one consistent way to define
634 the attributes of a class in Perl 5. These methods can only work with
635 the information given, and can not easily discover information on
636 their own. See L<Class::MOP::Attribute> for more details.
640 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
642 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
643 instance associated with the given class, and associates it with
644 the C<$attribute_name>. Unlike methods, attributes within the MOP
645 are stored as meta-information only. They will be used later to
646 construct instances from (see C<construct_instance> above).
647 More details about the attribute meta-objects can be found in the
648 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
651 It should be noted that any accessor, reader/writer or predicate
652 methods which the C<$attribute_meta_object> has will be installed
653 into the class at this time.
655 =item B<has_attribute ($attribute_name)>
657 Checks to see if this class has an attribute by the name of
658 C<$attribute_name> and returns a boolean.
660 =item B<get_attribute ($attribute_name)>
662 Returns the attribute meta-object associated with C<$attribute_name>,
663 if none is found, it will return undef.
665 =item B<remove_attribute ($attribute_name)>
667 This will remove the attribute meta-object stored at
668 C<$attribute_name>, then return the removed attribute meta-object.
671 Removing an attribute will only affect future instances of
672 the class, it will not make any attempt to remove the attribute from
673 any existing instances of the class.
675 It should be noted that any accessor, reader/writer or predicate
676 methods which the attribute meta-object stored at C<$attribute_name>
677 has will be removed from the class at this time. This B<will> make
678 these attributes somewhat inaccessable in previously created
679 instances. But if you are crazy enough to do this at runtime, then
680 you are crazy enough to deal with something like this :).
682 =item B<get_attribute_list>
684 This returns a list of attribute names which are defined in the local
685 class. If you want a list of all applicable attributes for a class,
686 use the C<compute_all_applicable_attributes> method.
688 =item B<compute_all_applicable_attributes>
690 This will traverse the inheritance heirachy and return a list of HASH
691 references for all the applicable attributes for this class. The HASH
692 references will contain the following information; the attribute name,
693 the class which the attribute is associated with and the actual
694 attribute meta-object.
698 =head2 Package Variables
700 Since Perl's classes are built atop the Perl package system, it is
701 fairly common to use package scoped variables for things like static
702 class variables. The following methods are convience methods for
703 the creation and inspection of package scoped variables.
707 =item B<add_package_variable ($variable_name, ?$initial_value)>
709 Given a C<$variable_name>, which must contain a leading sigil, this
710 method will create that variable within the package which houses the
711 class. It also takes an optional C<$initial_value>, which must be a
712 reference of the same type as the sigil of the C<$variable_name>
715 =item B<get_package_variable ($variable_name)>
717 This will return a reference to the package variable in
720 =item B<has_package_variable ($variable_name)>
722 Returns true (C<1>) if there is a package variable defined for
723 C<$variable_name>, and false (C<0>) otherwise.
725 =item B<remove_package_variable ($variable_name)>
727 This will attempt to remove the package variable at C<$variable_name>.
733 Stevan Little E<lt>stevan@iinteractive.comE<gt>
735 =head1 COPYRIGHT AND LICENSE
737 Copyright 2006 by Infinity Interactive, Inc.
739 L<http://www.iinteractive.com>
741 This library is free software; you can redistribute it and/or modify
742 it under the same terms as Perl itself.