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.03';
16 sub meta { Class::MOP::Class->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?
28 my $package_name = shift;
29 (defined $package_name && $package_name)
30 || confess "You must pass a package name";
31 return $METAS{$package_name} if exists $METAS{$package_name};
32 $METAS{$package_name} = $class->construct_class_instance($package_name, @_);
35 # NOTE: (meta-circularity)
36 # this is a special form of &construct_instance
37 # (see below), which is used to construct class
38 # meta-object instances for any Class::MOP::*
39 # class. All other classes will use the more
40 # normal &construct_instance.
41 sub construct_class_instance {
43 my $package_name = shift;
44 (defined $package_name && $package_name)
45 || confess "You must pass a package name";
46 $class = blessed($class) || $class;
47 if ($class =~ /^Class::MOP::/) {
49 '$:package' => $package_name,
51 '$:attribute_metaclass' => 'Class::MOP::Attribute',
52 '$:method_metaclass' => 'Class::MOP::Method',
56 bless $class->meta->construct_instance(':package' => $package_name, @_) => $class
62 my ($class, $package_name, $package_version, %options) = @_;
63 (defined $package_name && $package_name)
64 || confess "You must pass a package name";
65 my $code = "package $package_name;";
66 $code .= "\$$package_name\:\:VERSION = '$package_version';"
67 if defined $package_version;
69 confess "creation of $package_name failed : $@" if $@;
70 my $meta = $class->initialize($package_name);
71 $meta->superclasses(@{$options{superclasses}})
72 if exists $options{superclasses};
74 # process attributes first, so that they can
75 # install accessors, but locally defined methods
76 # can then overwrite them. It is maybe a little odd, but
77 # I think this should be the order of things.
78 if (exists $options{attributes}) {
79 foreach my $attr (@{$options{attributes}}) {
80 $meta->add_attribute($attr);
83 if (exists $options{methods}) {
84 foreach my $method_name (keys %{$options{methods}}) {
85 $meta->add_method($method_name, $options{methods}->{$method_name});
91 # Instance Construction
93 sub construct_instance {
94 my ($class, %params) = @_;
96 foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
97 # if the attr has an init_arg, use that, otherwise,
98 # use the attributes name itself as the init_arg
99 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
100 # try to fetch the init arg from the %params ...
102 $val = $params{$init_arg} if exists $params{$init_arg};
103 # if nothing was in the %params, we can use the
104 # attribute's default value (if it has one)
105 $val ||= $attr->default($instance) if $attr->has_default();
106 # now add this to the instance structure
107 $instance->{$attr->name} = $val;
114 sub name { $_[0]->{'$:package'} }
119 ${$self->name . '::VERSION'};
129 @{$self->name . '::ISA'} = @supers;
131 @{$self->name . '::ISA'};
134 sub class_precedence_list {
137 # We need to check for ciruclar inheirtance here.
138 # This will do nothing if all is well, and blow
139 # up otherwise. Yes, it's an ugly hack, better
140 # suggestions are welcome.
141 { $self->name->isa('This is a test for circular inheritance') }
142 # ... and no back to our regularly scheduled program
146 $self->initialize($_)->class_precedence_list()
147 } $self->superclasses()
153 # un-used right now ...
154 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
157 my ($self, $method_name, $method) = @_;
158 (defined $method_name && $method_name)
159 || confess "You must define a method name";
160 # use reftype here to allow for blessed subs ...
161 (reftype($method) && reftype($method) eq 'CODE')
162 || confess "Your code block must be a CODE reference";
163 my $full_method_name = ($self->name . '::' . $method_name);
166 no warnings 'redefine';
167 *{$full_method_name} = subname $full_method_name => $method;
172 ## private utility functions for has_method
173 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
174 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
177 my ($self, $method_name) = @_;
178 (defined $method_name && $method_name)
179 || confess "You must define a method name";
181 my $sub_name = ($self->name . '::' . $method_name);
184 return 0 if !defined(&{$sub_name});
185 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
186 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
193 my ($self, $method_name) = @_;
194 (defined $method_name && $method_name)
195 || confess "You must define a method name";
198 return \&{$self->name . '::' . $method_name}
199 if $self->has_method($method_name);
200 return; # <- make sure to return undef
204 my ($self, $method_name) = @_;
205 (defined $method_name && $method_name)
206 || confess "You must define a method name";
208 my $removed_method = $self->get_method($method_name);
211 delete ${$self->name . '::'}{$method_name}
212 if defined $removed_method;
214 return $removed_method;
217 sub get_method_list {
220 grep { $self->has_method($_) } %{$self->name . '::'};
223 sub compute_all_applicable_methods {
226 # keep a record of what we have seen
227 # here, this will handle all the
228 # inheritence issues because we are
229 # using the &class_precedence_list
230 my (%seen_class, %seen_method);
231 foreach my $class ($self->class_precedence_list()) {
232 next if $seen_class{$class};
233 $seen_class{$class}++;
234 # fetch the meta-class ...
235 my $meta = $self->initialize($class);
236 foreach my $method_name ($meta->get_method_list()) {
237 next if exists $seen_method{$method_name};
238 $seen_method{$method_name}++;
240 name => $method_name,
242 code => $meta->get_method($method_name)
249 sub find_all_methods_by_name {
250 my ($self, $method_name) = @_;
251 (defined $method_name && $method_name)
252 || confess "You must define a method name to find";
254 # keep a record of what we have seen
255 # here, this will handle all the
256 # inheritence issues because we are
257 # using the &class_precedence_list
259 foreach my $class ($self->class_precedence_list()) {
260 next if $seen_class{$class};
261 $seen_class{$class}++;
262 # fetch the meta-class ...
263 my $meta = $self->initialize($class);
265 name => $method_name,
267 code => $meta->get_method($method_name)
268 } if $meta->has_method($method_name);
276 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
280 # either we have an attribute object already
281 # or we need to create one from the args provided
282 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
283 # make sure it is derived from the correct type though
284 ($attribute->isa('Class::MOP::Attribute'))
285 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
286 $attribute->attach_to_class($self);
287 $attribute->install_accessors();
288 $self->{'%:attrs'}->{$attribute->name} = $attribute;
292 my ($self, $attribute_name) = @_;
293 (defined $attribute_name && $attribute_name)
294 || confess "You must define an attribute name";
295 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
299 my ($self, $attribute_name) = @_;
300 (defined $attribute_name && $attribute_name)
301 || confess "You must define an attribute name";
302 return $self->{'%:attrs'}->{$attribute_name}
303 if $self->has_attribute($attribute_name);
306 sub remove_attribute {
307 my ($self, $attribute_name) = @_;
308 (defined $attribute_name && $attribute_name)
309 || confess "You must define an attribute name";
310 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
311 delete $self->{'%:attrs'}->{$attribute_name}
312 if defined $removed_attribute;
313 $removed_attribute->remove_accessors();
314 $removed_attribute->detach_from_class();
315 return $removed_attribute;
318 sub get_attribute_list {
320 keys %{$self->{'%:attrs'}};
323 sub compute_all_applicable_attributes {
326 # keep a record of what we have seen
327 # here, this will handle all the
328 # inheritence issues because we are
329 # using the &class_precedence_list
330 my (%seen_class, %seen_attr);
331 foreach my $class ($self->class_precedence_list()) {
332 next if $seen_class{$class};
333 $seen_class{$class}++;
334 # fetch the meta-class ...
335 my $meta = $self->initialize($class);
336 foreach my $attr_name ($meta->get_attribute_list()) {
337 next if exists $seen_attr{$attr_name};
338 $seen_attr{$attr_name}++;
342 attribute => $meta->get_attribute($attr_name)
351 sub add_package_variable {
352 my ($self, $variable, $initial_value) = @_;
353 (defined $variable && $variable =~ /^[\$\@\%]/)
354 || confess "variable name does not have a sigil";
356 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
357 if (defined $initial_value) {
359 *{$self->name . '::' . $name} = $initial_value;
362 eval $sigil . $self->name . '::' . $name;
363 confess "Could not create package variable ($variable) because : $@" if $@;
367 sub has_package_variable {
368 my ($self, $variable) = @_;
369 (defined $variable && $variable =~ /^[\$\@\%]/)
370 || confess "variable name does not have a sigil";
371 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
373 defined ${$self->name . '::'}{$name} ? 1 : 0;
376 sub get_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 # try to fetch it first,.. see what happens
383 eval '\\' . $sigil . $self->name . '::' . $name;
384 confess "Could not get the package variable ($variable) because : $@" if $@;
385 # if we didn't die, then we can return it
387 # this is not ideal, better suggestions are welcome
388 eval '\\' . $sigil . $self->name . '::' . $name;
391 sub remove_package_variable {
392 my ($self, $variable) = @_;
393 (defined $variable && $variable =~ /^[\$\@\%]/)
394 || confess "variable name does not have a sigil";
395 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
397 delete ${$self->name . '::'}{$name};
408 Class::MOP::Class - Class Meta Object
412 # use this for introspection ...
415 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
417 # elsewhere in the code ...
419 # add a method to Foo ...
420 Foo->meta->add_method('bar' => sub { ... })
422 # get a list of all the classes searched
423 # the method dispatcher in the correct order
424 Foo->meta->class_precedence_list()
426 # remove a method from Foo
427 Foo->meta->remove_method('bar');
429 # or use this to actually create classes ...
431 Class::MOP::Class->create('Bar' => '0.01' => (
432 superclasses => [ 'Foo' ],
434 Class::MOP:::Attribute->new('$bar'),
435 Class::MOP:::Attribute->new('$baz'),
438 calculate_bar => sub { ... },
439 construct_baz => sub { ... }
445 This is the largest and currently most complex part of the Perl 5
446 meta-object protocol. It controls the introspection and
447 manipulation of Perl 5 classes (and it can create them too). The
448 best way to understand what this module can do, is to read the
449 documentation for each of it's methods.
453 =head2 Self Introspection
459 This will return a B<Class::MOP::Class> instance which is related
460 to this class. Thereby allowing B<Class::MOP::Class> to actually
463 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
464 bootstrap this module by installing a number of attribute meta-objects
465 into it's metaclass. This will allow this class to reap all the benifits
466 of the MOP when subclassing it.
470 =head2 Class construction
472 These methods will handle creating B<Class::MOP::Class> objects,
473 which can be used to both create new classes, and analyze
474 pre-existing classes.
476 This module will internally store references to all the instances
477 you create with these methods, so that they do not need to be
478 created any more than nessecary. Basically, they are singletons.
482 =item B<create ($package_name, ?$package_version,
483 superclasses =E<gt> ?@superclasses,
484 methods =E<gt> ?%methods,
485 attributes =E<gt> ?%attributes)>
487 This returns a B<Class::MOP::Class> object, bringing the specified
488 C<$package_name> into existence and adding any of the
489 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
492 =item B<initialize ($package_name)>
494 This initializes and returns returns a B<Class::MOP::Class> object
495 for a given a C<$package_name>.
497 =item B<construct_class_instance ($package_name)>
499 This will construct an instance of B<Class::MOP::Class>, it is
500 here so that we can actually "tie the knot" for B<Class::MOP::Class>
501 to use C<construct_instance> once all the bootstrapping is done. This
502 method is used internally by C<initialize> and should never be called
503 from outside of that method really.
507 =head2 Object instance construction
509 This method is used to construct an instace structure suitable for
510 C<bless>-ing into your package of choice. It works in conjunction
511 with the Attribute protocol to collect all applicable attributes.
513 This method is B<entirely optional>, it is up to you whether you want
518 =item B<construct_instance (%params)>
520 This will construct and instance using a HASH ref as storage
521 (currently only HASH references are supported). This will collect all
522 the applicable attributes and layout out the fields in the HASH ref,
523 it will then initialize them using either use the corresponding key
524 in C<%params> or any default value or initializer found in the
525 attribute meta-object.
535 This is a read-only attribute which returns the package name for the
536 given B<Class::MOP::Class> instance.
540 This is a read-only attribute which returns the C<$VERSION> of the
541 package for the given B<Class::MOP::Class> instance.
545 =head2 Inheritance Relationships
549 =item B<superclasses (?@superclasses)>
551 This is a read-write attribute which represents the superclass
552 relationships of the class the B<Class::MOP::Class> instance is
553 associated with. Basically, it can get and set the C<@ISA> for you.
556 Perl will occasionally perform some C<@ISA> and method caching, if
557 you decide to change your superclass relationship at runtime (which
558 is quite insane and very much not recommened), then you should be
559 aware of this and the fact that this module does not make any
560 attempt to address this issue.
562 =item B<class_precedence_list>
564 This computes the a list of all the class's ancestors in the same order
565 in which method dispatch will be done. This is similair to
566 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
574 =item B<method_metaclass>
576 =item B<add_method ($method_name, $method)>
578 This will take a C<$method_name> and CODE reference to that
579 C<$method> and install it into the class's package.
582 This does absolutely nothing special to C<$method>
583 other than use B<Sub::Name> to make sure it is tagged with the
584 correct name, and therefore show up correctly in stack traces and
587 =item B<has_method ($method_name)>
589 This just provides a simple way to check if the class implements
590 a specific C<$method_name>. It will I<not> however, attempt to check
591 if the class inherits the method (use C<UNIVERSAL::can> for that).
593 This will correctly handle functions defined outside of the package
594 that use a fully qualified name (C<sub Package::name { ... }>).
596 This will correctly handle functions renamed with B<Sub::Name> and
597 installed using the symbol tables. However, if you are naming the
598 subroutine outside of the package scope, you must use the fully
599 qualified name, including the package name, for C<has_method> to
600 correctly identify it.
602 This will attempt to correctly ignore functions imported from other
603 packages using B<Exporter>. It breaks down if the function imported
604 is an C<__ANON__> sub (such as with C<use constant>), which very well
605 may be a valid method being applied to the class.
607 In short, this method cannot always be trusted to determine if the
608 C<$method_name> is actually a method. However, it will DWIM about
609 90% of the time, so it's a small trade off I think.
611 =item B<get_method ($method_name)>
613 This will return a CODE reference of the specified C<$method_name>,
614 or return undef if that method does not exist.
616 =item B<remove_method ($method_name)>
618 This will attempt to remove a given C<$method_name> from the class.
619 It will return the CODE reference that it has removed, and will
620 attempt to use B<Sub::Name> to clear the methods associated name.
622 =item B<get_method_list>
624 This will return a list of method names for all I<locally> defined
625 methods. It does B<not> provide a list of all applicable methods,
626 including any inherited ones. If you want a list of all applicable
627 methods, use the C<compute_all_applicable_methods> method.
629 =item B<compute_all_applicable_methods>
631 This will return a list of all the methods names this class will
632 respond to, taking into account inheritance. The list will be a list of
633 HASH references, each one containing the following information; method
634 name, the name of the class in which the method lives and a CODE
635 reference for the actual method.
637 =item B<find_all_methods_by_name ($method_name)>
639 This will traverse the inheritence hierarchy and locate all methods
640 with a given C<$method_name>. Similar to
641 C<compute_all_applicable_methods> it returns a list of HASH references
642 with the following information; method name (which will always be the
643 same as C<$method_name>), the name of the class in which the method
644 lives and a CODE reference for the actual method.
646 The list of methods produced is a distinct list, meaning there are no
647 duplicates in it. This is especially useful for things like object
648 initialization and destruction where you only want the method called
649 once, and in the correct order.
655 It should be noted that since there is no one consistent way to define
656 the attributes of a class in Perl 5. These methods can only work with
657 the information given, and can not easily discover information on
658 their own. See L<Class::MOP::Attribute> for more details.
662 =item B<attribute_metaclass>
664 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
666 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
667 instance associated with the given class, and associates it with
668 the C<$attribute_name>. Unlike methods, attributes within the MOP
669 are stored as meta-information only. They will be used later to
670 construct instances from (see C<construct_instance> above).
671 More details about the attribute meta-objects can be found in the
672 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
675 It should be noted that any accessor, reader/writer or predicate
676 methods which the C<$attribute_meta_object> has will be installed
677 into the class at this time.
679 =item B<has_attribute ($attribute_name)>
681 Checks to see if this class has an attribute by the name of
682 C<$attribute_name> and returns a boolean.
684 =item B<get_attribute ($attribute_name)>
686 Returns the attribute meta-object associated with C<$attribute_name>,
687 if none is found, it will return undef.
689 =item B<remove_attribute ($attribute_name)>
691 This will remove the attribute meta-object stored at
692 C<$attribute_name>, then return the removed attribute meta-object.
695 Removing an attribute will only affect future instances of
696 the class, it will not make any attempt to remove the attribute from
697 any existing instances of the class.
699 It should be noted that any accessor, reader/writer or predicate
700 methods which the attribute meta-object stored at C<$attribute_name>
701 has will be removed from the class at this time. This B<will> make
702 these attributes somewhat inaccessable in previously created
703 instances. But if you are crazy enough to do this at runtime, then
704 you are crazy enough to deal with something like this :).
706 =item B<get_attribute_list>
708 This returns a list of attribute names which are defined in the local
709 class. If you want a list of all applicable attributes for a class,
710 use the C<compute_all_applicable_attributes> method.
712 =item B<compute_all_applicable_attributes>
714 This will traverse the inheritance heirachy and return a list of HASH
715 references for all the applicable attributes for this class. The HASH
716 references will contain the following information; the attribute name,
717 the class which the attribute is associated with and the actual
718 attribute meta-object.
722 =head2 Package Variables
724 Since Perl's classes are built atop the Perl package system, it is
725 fairly common to use package scoped variables for things like static
726 class variables. The following methods are convience methods for
727 the creation and inspection of package scoped variables.
731 =item B<add_package_variable ($variable_name, ?$initial_value)>
733 Given a C<$variable_name>, which must contain a leading sigil, this
734 method will create that variable within the package which houses the
735 class. It also takes an optional C<$initial_value>, which must be a
736 reference of the same type as the sigil of the C<$variable_name>
739 =item B<get_package_variable ($variable_name)>
741 This will return a reference to the package variable in
744 =item B<has_package_variable ($variable_name)>
746 Returns true (C<1>) if there is a package variable defined for
747 C<$variable_name>, and false (C<0>) otherwise.
749 =item B<remove_package_variable ($variable_name)>
751 This will attempt to remove the package variable at C<$variable_name>.
757 Stevan Little E<lt>stevan@iinteractive.comE<gt>
759 =head1 COPYRIGHT AND LICENSE
761 Copyright 2006 by Infinity Interactive, Inc.
763 L<http://www.iinteractive.com>
765 This library is free software; you can redistribute it and/or modify
766 it under the same terms as Perl itself.