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.
543 Perl will occasionally perform some C<@ISA> and method caching, if
544 you decide to change your superclass relationship at runtime (which
545 is quite insane and very much not recommened), then you should be
546 aware of this and the fact that this module does not make any
547 attempt to address this issue.
549 =item B<class_precedence_list>
551 This computes the a list of all the class's ancestors in the same order
552 in which method dispatch will be done. This is similair to
553 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
561 =item B<add_method ($method_name, $method)>
563 This will take a C<$method_name> and CODE reference to that
564 C<$method> and install it into the class's package.
567 This does absolutely nothing special to C<$method>
568 other than use B<Sub::Name> to make sure it is tagged with the
569 correct name, and therefore show up correctly in stack traces and
572 =item B<has_method ($method_name)>
574 This just provides a simple way to check if the class implements
575 a specific C<$method_name>. It will I<not> however, attempt to check
576 if the class inherits the method (use C<UNIVERSAL::can> for that).
578 This will correctly handle functions defined outside of the package
579 that use a fully qualified name (C<sub Package::name { ... }>).
581 This will correctly handle functions renamed with B<Sub::Name> and
582 installed using the symbol tables. However, if you are naming the
583 subroutine outside of the package scope, you must use the fully
584 qualified name, including the package name, for C<has_method> to
585 correctly identify it.
587 This will attempt to correctly ignore functions imported from other
588 packages using B<Exporter>. It breaks down if the function imported
589 is an C<__ANON__> sub (such as with C<use constant>), which very well
590 may be a valid method being applied to the class.
592 In short, this method cannot always be trusted to determine if the
593 C<$method_name> is actually a method. However, it will DWIM about
594 90% of the time, so it's a small trade off I think.
596 =item B<get_method ($method_name)>
598 This will return a CODE reference of the specified C<$method_name>,
599 or return undef if that method does not exist.
601 =item B<remove_method ($method_name)>
603 This will attempt to remove a given C<$method_name> from the class.
604 It will return the CODE reference that it has removed, and will
605 attempt to use B<Sub::Name> to clear the methods associated name.
607 =item B<get_method_list>
609 This will return a list of method names for all I<locally> defined
610 methods. It does B<not> provide a list of all applicable methods,
611 including any inherited ones. If you want a list of all applicable
612 methods, use the C<compute_all_applicable_methods> method.
614 =item B<compute_all_applicable_methods>
616 This will return a list of all the methods names this class will
617 respond to, taking into account inheritance. The list will be a list of
618 HASH references, each one containing the following information; method
619 name, the name of the class in which the method lives and a CODE
620 reference for the actual method.
622 =item B<find_all_methods_by_name ($method_name)>
624 This will traverse the inheritence hierarchy and locate all methods
625 with a given C<$method_name>. Similar to
626 C<compute_all_applicable_methods> it returns a list of HASH references
627 with the following information; method name (which will always be the
628 same as C<$method_name>), the name of the class in which the method
629 lives and a CODE reference for the actual method.
631 The list of methods produced is a distinct list, meaning there are no
632 duplicates in it. This is especially useful for things like object
633 initialization and destruction where you only want the method called
634 once, and in the correct order.
640 It should be noted that since there is no one consistent way to define
641 the attributes of a class in Perl 5. These methods can only work with
642 the information given, and can not easily discover information on
643 their own. See L<Class::MOP::Attribute> for more details.
647 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
649 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
650 instance associated with the given class, and associates it with
651 the C<$attribute_name>. Unlike methods, attributes within the MOP
652 are stored as meta-information only. They will be used later to
653 construct instances from (see C<construct_instance> above).
654 More details about the attribute meta-objects can be found in the
655 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
658 It should be noted that any accessor, reader/writer or predicate
659 methods which the C<$attribute_meta_object> has will be installed
660 into the class at this time.
662 =item B<has_attribute ($attribute_name)>
664 Checks to see if this class has an attribute by the name of
665 C<$attribute_name> and returns a boolean.
667 =item B<get_attribute ($attribute_name)>
669 Returns the attribute meta-object associated with C<$attribute_name>,
670 if none is found, it will return undef.
672 =item B<remove_attribute ($attribute_name)>
674 This will remove the attribute meta-object stored at
675 C<$attribute_name>, then return the removed attribute meta-object.
678 Removing an attribute will only affect future instances of
679 the class, it will not make any attempt to remove the attribute from
680 any existing instances of the class.
682 It should be noted that any accessor, reader/writer or predicate
683 methods which the attribute meta-object stored at C<$attribute_name>
684 has will be removed from the class at this time. This B<will> make
685 these attributes somewhat inaccessable in previously created
686 instances. But if you are crazy enough to do this at runtime, then
687 you are crazy enough to deal with something like this :).
689 =item B<get_attribute_list>
691 This returns a list of attribute names which are defined in the local
692 class. If you want a list of all applicable attributes for a class,
693 use the C<compute_all_applicable_attributes> method.
695 =item B<compute_all_applicable_attributes>
697 This will traverse the inheritance heirachy and return a list of HASH
698 references for all the applicable attributes for this class. The HASH
699 references will contain the following information; the attribute name,
700 the class which the attribute is associated with and the actual
701 attribute meta-object.
705 =head2 Package Variables
707 Since Perl's classes are built atop the Perl package system, it is
708 fairly common to use package scoped variables for things like static
709 class variables. The following methods are convience methods for
710 the creation and inspection of package scoped variables.
714 =item B<add_package_variable ($variable_name, ?$initial_value)>
716 Given a C<$variable_name>, which must contain a leading sigil, this
717 method will create that variable within the package which houses the
718 class. It also takes an optional C<$initial_value>, which must be a
719 reference of the same type as the sigil of the C<$variable_name>
722 =item B<get_package_variable ($variable_name)>
724 This will return a reference to the package variable in
727 =item B<has_package_variable ($variable_name)>
729 Returns true (C<1>) if there is a package variable defined for
730 C<$variable_name>, and false (C<0>) otherwise.
732 =item B<remove_package_variable ($variable_name)>
734 This will attempt to remove the package variable at C<$variable_name>.
740 Stevan Little E<lt>stevan@iinteractive.comE<gt>
742 =head1 COPYRIGHT AND LICENSE
744 Copyright 2006 by Infinity Interactive, Inc.
746 L<http://www.iinteractive.com>
748 This library is free software; you can redistribute it and/or modify
749 it under the same terms as Perl itself.