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 # make sure the package name is not blessed
32 $package_name = blessed($package_name) || $package_name;
33 return $METAS{$package_name} if exists $METAS{$package_name};
34 $METAS{$package_name} = $class->construct_class_instance($package_name, @_);
37 # NOTE: (meta-circularity)
38 # this is a special form of &construct_instance
39 # (see below), which is used to construct class
40 # meta-object instances for any Class::MOP::*
41 # class. All other classes will use the more
42 # normal &construct_instance.
43 sub construct_class_instance {
45 my $package_name = shift;
46 (defined $package_name && $package_name)
47 || confess "You must pass a package name";
48 $class = blessed($class) || $class;
49 if ($class =~ /^Class::MOP::/) {
51 '$:package' => $package_name,
53 '$:attribute_metaclass' => 'Class::MOP::Attribute',
54 '$:method_metaclass' => 'Class::MOP::Method',
59 # it is safe to use meta here because
60 # class will always be a subclass of
61 # Class::MOP::Class, which defines meta
62 bless $class->meta->construct_instance(':package' => $package_name, @_) => $class
68 my ($class, $package_name, $package_version, %options) = @_;
69 (defined $package_name && $package_name)
70 || confess "You must pass a package name";
71 my $code = "package $package_name;";
72 $code .= "\$$package_name\:\:VERSION = '$package_version';"
73 if defined $package_version;
75 confess "creation of $package_name failed : $@" if $@;
76 my $meta = $class->initialize($package_name);
77 $meta->superclasses(@{$options{superclasses}})
78 if exists $options{superclasses};
80 # process attributes first, so that they can
81 # install accessors, but locally defined methods
82 # can then overwrite them. It is maybe a little odd, but
83 # I think this should be the order of things.
84 if (exists $options{attributes}) {
85 foreach my $attr (@{$options{attributes}}) {
86 $meta->add_attribute($attr);
89 if (exists $options{methods}) {
90 foreach my $method_name (keys %{$options{methods}}) {
91 $meta->add_method($method_name, $options{methods}->{$method_name});
100 # all these attribute readers will be bootstrapped
101 # away in the Class::MOP bootstrap section
103 sub name { $_[0]->{'$:package'} }
104 sub get_attribute_map { $_[0]->{'%:attributes'} }
105 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
106 sub method_metaclass { $_[0]->{'$:method_metaclass'} }
108 # Instance Construction & Cloning
112 bless $class->construct_instance(@_) => $class->name;
115 sub construct_instance {
116 my ($class, %params) = @_;
118 foreach my $attr ($class->compute_all_applicable_attributes()) {
119 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
120 # try to fetch the init arg from the %params ...
122 $val = $params{$init_arg} if exists $params{$init_arg};
123 # if nothing was in the %params, we can use the
124 # attribute's default value (if it has one)
125 $val ||= $attr->default($instance) if $attr->has_default();
126 $instance->{$attr->name} = $val;
133 my $instance = shift;
134 bless $class->clone_instance($instance, @_) => $class->name;
138 my ($class, $self, %params) = @_;
140 || confess "You can only clone instances, \$self is not a blessed instance";
142 # this should actually do a deep clone
143 # instead of this cheap hack. I will
145 # (use the Class::Cloneable::Util code)
146 my $clone = { %{$self} };
147 foreach my $attr ($class->compute_all_applicable_attributes()) {
148 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
149 # try to fetch the init arg from the %params ...
150 $clone->{$attr->name} = $params{$init_arg}
151 if exists $params{$init_arg};
158 # &name should be here too, but it is above
159 # because it gets bootstrapped away
164 ${$self->name . '::VERSION'};
174 @{$self->name . '::ISA'} = @supers;
176 @{$self->name . '::ISA'};
179 sub class_precedence_list {
182 # We need to check for ciruclar inheirtance here.
183 # This will do nothing if all is well, and blow
184 # up otherwise. Yes, it's an ugly hack, better
185 # suggestions are welcome.
186 { $self->name->isa('This is a test for circular inheritance') }
187 # ... and no back to our regularly scheduled program
191 $self->initialize($_)->class_precedence_list()
192 } $self->superclasses()
199 my ($self, $method_name, $method) = @_;
200 (defined $method_name && $method_name)
201 || confess "You must define a method name";
202 # use reftype here to allow for blessed subs ...
203 (reftype($method) && reftype($method) eq 'CODE')
204 || confess "Your code block must be a CODE reference";
205 my $full_method_name = ($self->name . '::' . $method_name);
208 no warnings 'redefine';
209 *{$full_method_name} = subname $full_method_name => $method;
214 ## private utility functions for has_method
215 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
216 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
219 my ($self, $method_name) = @_;
220 (defined $method_name && $method_name)
221 || confess "You must define a method name";
223 my $sub_name = ($self->name . '::' . $method_name);
226 return 0 if !defined(&{$sub_name});
227 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
228 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
235 my ($self, $method_name) = @_;
236 (defined $method_name && $method_name)
237 || confess "You must define a method name";
240 return \&{$self->name . '::' . $method_name}
241 if $self->has_method($method_name);
242 return; # <- make sure to return undef
246 my ($self, $method_name) = @_;
247 (defined $method_name && $method_name)
248 || confess "You must define a method name";
250 my $removed_method = $self->get_method($method_name);
253 delete ${$self->name . '::'}{$method_name}
254 if defined $removed_method;
256 return $removed_method;
259 sub get_method_list {
262 grep { $self->has_method($_) } %{$self->name . '::'};
265 sub compute_all_applicable_methods {
268 # keep a record of what we have seen
269 # here, this will handle all the
270 # inheritence issues because we are
271 # using the &class_precedence_list
272 my (%seen_class, %seen_method);
273 foreach my $class ($self->class_precedence_list()) {
274 next if $seen_class{$class};
275 $seen_class{$class}++;
276 # fetch the meta-class ...
277 my $meta = $self->initialize($class);
278 foreach my $method_name ($meta->get_method_list()) {
279 next if exists $seen_method{$method_name};
280 $seen_method{$method_name}++;
282 name => $method_name,
284 code => $meta->get_method($method_name)
291 sub find_all_methods_by_name {
292 my ($self, $method_name) = @_;
293 (defined $method_name && $method_name)
294 || confess "You must define a method name to find";
296 # keep a record of what we have seen
297 # here, this will handle all the
298 # inheritence issues because we are
299 # using the &class_precedence_list
301 foreach my $class ($self->class_precedence_list()) {
302 next if $seen_class{$class};
303 $seen_class{$class}++;
304 # fetch the meta-class ...
305 my $meta = $self->initialize($class);
307 name => $method_name,
309 code => $meta->get_method($method_name)
310 } if $meta->has_method($method_name);
320 # either we have an attribute object already
321 # or we need to create one from the args provided
322 my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
323 # make sure it is derived from the correct type though
324 ($attribute->isa('Class::MOP::Attribute'))
325 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
326 $attribute->attach_to_class($self);
327 $attribute->install_accessors();
328 $self->get_attribute_map->{$attribute->name} = $attribute;
332 my ($self, $attribute_name) = @_;
333 (defined $attribute_name && $attribute_name)
334 || confess "You must define an attribute name";
335 exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
339 my ($self, $attribute_name) = @_;
340 (defined $attribute_name && $attribute_name)
341 || confess "You must define an attribute name";
342 return $self->get_attribute_map->{$attribute_name}
343 if $self->has_attribute($attribute_name);
346 sub remove_attribute {
347 my ($self, $attribute_name) = @_;
348 (defined $attribute_name && $attribute_name)
349 || confess "You must define an attribute name";
350 my $removed_attribute = $self->get_attribute_map->{$attribute_name};
351 delete $self->get_attribute_map->{$attribute_name}
352 if defined $removed_attribute;
353 $removed_attribute->remove_accessors();
354 $removed_attribute->detach_from_class();
355 return $removed_attribute;
358 sub get_attribute_list {
360 keys %{$self->get_attribute_map};
363 sub compute_all_applicable_attributes {
366 # keep a record of what we have seen
367 # here, this will handle all the
368 # inheritence issues because we are
369 # using the &class_precedence_list
370 my (%seen_class, %seen_attr);
371 foreach my $class ($self->class_precedence_list()) {
372 next if $seen_class{$class};
373 $seen_class{$class}++;
374 # fetch the meta-class ...
375 my $meta = $self->initialize($class);
376 foreach my $attr_name ($meta->get_attribute_list()) {
377 next if exists $seen_attr{$attr_name};
378 $seen_attr{$attr_name}++;
379 push @attrs => $meta->get_attribute($attr_name);
387 sub add_package_variable {
388 my ($self, $variable, $initial_value) = @_;
389 (defined $variable && $variable =~ /^[\$\@\%]/)
390 || confess "variable name does not have a sigil";
392 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
393 if (defined $initial_value) {
395 *{$self->name . '::' . $name} = $initial_value;
398 eval $sigil . $self->name . '::' . $name;
399 confess "Could not create package variable ($variable) because : $@" if $@;
403 sub has_package_variable {
404 my ($self, $variable) = @_;
405 (defined $variable && $variable =~ /^[\$\@\%]/)
406 || confess "variable name does not have a sigil";
407 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
409 defined ${$self->name . '::'}{$name} ? 1 : 0;
412 sub get_package_variable {
413 my ($self, $variable) = @_;
414 (defined $variable && $variable =~ /^[\$\@\%]/)
415 || confess "variable name does not have a sigil";
416 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
418 # try to fetch it first,.. see what happens
419 eval '\\' . $sigil . $self->name . '::' . $name;
420 confess "Could not get the package variable ($variable) because : $@" if $@;
421 # if we didn't die, then we can return it
423 # this is not ideal, better suggestions are welcome
424 eval '\\' . $sigil . $self->name . '::' . $name;
427 sub remove_package_variable {
428 my ($self, $variable) = @_;
429 (defined $variable && $variable =~ /^[\$\@\%]/)
430 || confess "variable name does not have a sigil";
431 my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
433 delete ${$self->name . '::'}{$name};
444 Class::MOP::Class - Class Meta Object
448 # use this for introspection ...
451 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
453 # elsewhere in the code ...
455 # add a method to Foo ...
456 Foo->meta->add_method('bar' => sub { ... })
458 # get a list of all the classes searched
459 # the method dispatcher in the correct order
460 Foo->meta->class_precedence_list()
462 # remove a method from Foo
463 Foo->meta->remove_method('bar');
465 # or use this to actually create classes ...
467 Class::MOP::Class->create('Bar' => '0.01' => (
468 superclasses => [ 'Foo' ],
470 Class::MOP:::Attribute->new('$bar'),
471 Class::MOP:::Attribute->new('$baz'),
474 calculate_bar => sub { ... },
475 construct_baz => sub { ... }
481 This is the largest and currently most complex part of the Perl 5
482 meta-object protocol. It controls the introspection and
483 manipulation of Perl 5 classes (and it can create them too). The
484 best way to understand what this module can do, is to read the
485 documentation for each of it's methods.
489 =head2 Self Introspection
495 This will return a B<Class::MOP::Class> instance which is related
496 to this class. Thereby allowing B<Class::MOP::Class> to actually
499 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
500 bootstrap this module by installing a number of attribute meta-objects
501 into it's metaclass. This will allow this class to reap all the benifits
502 of the MOP when subclassing it.
506 =head2 Class construction
508 These methods will handle creating B<Class::MOP::Class> objects,
509 which can be used to both create new classes, and analyze
510 pre-existing classes.
512 This module will internally store references to all the instances
513 you create with these methods, so that they do not need to be
514 created any more than nessecary. Basically, they are singletons.
518 =item B<create ($package_name, ?$package_version,
519 superclasses =E<gt> ?@superclasses,
520 methods =E<gt> ?%methods,
521 attributes =E<gt> ?%attributes)>
523 This returns a B<Class::MOP::Class> object, bringing the specified
524 C<$package_name> into existence and adding any of the
525 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
528 =item B<initialize ($package_name)>
530 This initializes and returns returns a B<Class::MOP::Class> object
531 for a given a C<$package_name>.
533 =item B<construct_class_instance ($package_name)>
535 This will construct an instance of B<Class::MOP::Class>, it is
536 here so that we can actually "tie the knot" for B<Class::MOP::Class>
537 to use C<construct_instance> once all the bootstrapping is done. This
538 method is used internally by C<initialize> and should never be called
539 from outside of that method really.
543 =head2 Object instance construction and cloning
545 These methods are B<entirely optional>, it is up to you whether you want
550 =item B<new_object (%params)>
552 This is a convience method for creating a new object of the class, and
553 blessing it into the appropriate package as well. Ideally your class
554 would call a C<new> this method like so:
557 my ($class, %param) = @_;
558 $class->meta->new_object(%params);
561 Of course the ideal place for this would actually be in C<UNIVERSAL::>
562 but that is considered bad style, so we do not do that.
564 =item B<construct_instance (%params)>
566 This method is used to construct an instace structure suitable for
567 C<bless>-ing into your package of choice. It works in conjunction
568 with the Attribute protocol to collect all applicable attributes.
570 This will construct and instance using a HASH ref as storage
571 (currently only HASH references are supported). This will collect all
572 the applicable attributes and layout out the fields in the HASH ref,
573 it will then initialize them using either use the corresponding key
574 in C<%params> or any default value or initializer found in the
575 attribute meta-object.
577 =item B<clone_object ($instance, %params)>
579 This is a convience method for cloning an object instance, then
580 blessing it into the appropriate package. Ideally your class
581 would call a C<clone> this method like so:
584 my ($self, %param) = @_;
585 $self->meta->clone_object($self, %params);
588 Of course the ideal place for this would actually be in C<UNIVERSAL::>
589 but that is considered bad style, so we do not do that.
591 =item B<clone_instance($instance, %params)>
593 This method is a compliment of C<construct_instance> (which means if
594 you override C<construct_instance>, you need to override this one too).
596 This method will clone the C<$instance> structure created by the
597 C<construct_instance> method, and apply any C<%params> passed to it
598 to change the attribute values. The structure returned is (like with
599 C<construct_instance>) an unC<bless>ed HASH reference, it is your
600 responsibility to then bless this cloned structure into the right
611 This is a read-only attribute which returns the package name for the
612 given B<Class::MOP::Class> instance.
616 This is a read-only attribute which returns the C<$VERSION> of the
617 package for the given B<Class::MOP::Class> instance.
621 =head2 Inheritance Relationships
625 =item B<superclasses (?@superclasses)>
627 This is a read-write attribute which represents the superclass
628 relationships of the class the B<Class::MOP::Class> instance is
629 associated with. Basically, it can get and set the C<@ISA> for you.
632 Perl will occasionally perform some C<@ISA> and method caching, if
633 you decide to change your superclass relationship at runtime (which
634 is quite insane and very much not recommened), then you should be
635 aware of this and the fact that this module does not make any
636 attempt to address this issue.
638 =item B<class_precedence_list>
640 This computes the a list of all the class's ancestors in the same order
641 in which method dispatch will be done. This is similair to
642 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
650 =item B<method_metaclass>
652 =item B<add_method ($method_name, $method)>
654 This will take a C<$method_name> and CODE reference to that
655 C<$method> and install it into the class's package.
658 This does absolutely nothing special to C<$method>
659 other than use B<Sub::Name> to make sure it is tagged with the
660 correct name, and therefore show up correctly in stack traces and
663 =item B<has_method ($method_name)>
665 This just provides a simple way to check if the class implements
666 a specific C<$method_name>. It will I<not> however, attempt to check
667 if the class inherits the method (use C<UNIVERSAL::can> for that).
669 This will correctly handle functions defined outside of the package
670 that use a fully qualified name (C<sub Package::name { ... }>).
672 This will correctly handle functions renamed with B<Sub::Name> and
673 installed using the symbol tables. However, if you are naming the
674 subroutine outside of the package scope, you must use the fully
675 qualified name, including the package name, for C<has_method> to
676 correctly identify it.
678 This will attempt to correctly ignore functions imported from other
679 packages using B<Exporter>. It breaks down if the function imported
680 is an C<__ANON__> sub (such as with C<use constant>), which very well
681 may be a valid method being applied to the class.
683 In short, this method cannot always be trusted to determine if the
684 C<$method_name> is actually a method. However, it will DWIM about
685 90% of the time, so it's a small trade off I think.
687 =item B<get_method ($method_name)>
689 This will return a CODE reference of the specified C<$method_name>,
690 or return undef if that method does not exist.
692 =item B<remove_method ($method_name)>
694 This will attempt to remove a given C<$method_name> from the class.
695 It will return the CODE reference that it has removed, and will
696 attempt to use B<Sub::Name> to clear the methods associated name.
698 =item B<get_method_list>
700 This will return a list of method names for all I<locally> defined
701 methods. It does B<not> provide a list of all applicable methods,
702 including any inherited ones. If you want a list of all applicable
703 methods, use the C<compute_all_applicable_methods> method.
705 =item B<compute_all_applicable_methods>
707 This will return a list of all the methods names this class will
708 respond to, taking into account inheritance. The list will be a list of
709 HASH references, each one containing the following information; method
710 name, the name of the class in which the method lives and a CODE
711 reference for the actual method.
713 =item B<find_all_methods_by_name ($method_name)>
715 This will traverse the inheritence hierarchy and locate all methods
716 with a given C<$method_name>. Similar to
717 C<compute_all_applicable_methods> it returns a list of HASH references
718 with the following information; method name (which will always be the
719 same as C<$method_name>), the name of the class in which the method
720 lives and a CODE reference for the actual method.
722 The list of methods produced is a distinct list, meaning there are no
723 duplicates in it. This is especially useful for things like object
724 initialization and destruction where you only want the method called
725 once, and in the correct order.
731 It should be noted that since there is no one consistent way to define
732 the attributes of a class in Perl 5. These methods can only work with
733 the information given, and can not easily discover information on
734 their own. See L<Class::MOP::Attribute> for more details.
738 =item B<attribute_metaclass>
740 =item B<get_attribute_map>
742 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
744 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
745 instance associated with the given class, and associates it with
746 the C<$attribute_name>. Unlike methods, attributes within the MOP
747 are stored as meta-information only. They will be used later to
748 construct instances from (see C<construct_instance> above).
749 More details about the attribute meta-objects can be found in the
750 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
753 It should be noted that any accessor, reader/writer or predicate
754 methods which the C<$attribute_meta_object> has will be installed
755 into the class at this time.
757 =item B<has_attribute ($attribute_name)>
759 Checks to see if this class has an attribute by the name of
760 C<$attribute_name> and returns a boolean.
762 =item B<get_attribute ($attribute_name)>
764 Returns the attribute meta-object associated with C<$attribute_name>,
765 if none is found, it will return undef.
767 =item B<remove_attribute ($attribute_name)>
769 This will remove the attribute meta-object stored at
770 C<$attribute_name>, then return the removed attribute meta-object.
773 Removing an attribute will only affect future instances of
774 the class, it will not make any attempt to remove the attribute from
775 any existing instances of the class.
777 It should be noted that any accessor, reader/writer or predicate
778 methods which the attribute meta-object stored at C<$attribute_name>
779 has will be removed from the class at this time. This B<will> make
780 these attributes somewhat inaccessable in previously created
781 instances. But if you are crazy enough to do this at runtime, then
782 you are crazy enough to deal with something like this :).
784 =item B<get_attribute_list>
786 This returns a list of attribute names which are defined in the local
787 class. If you want a list of all applicable attributes for a class,
788 use the C<compute_all_applicable_attributes> method.
790 =item B<compute_all_applicable_attributes>
792 This will traverse the inheritance heirachy and return a list of all
793 the applicable attributes for this class. It does not construct a
794 HASH reference like C<compute_all_applicable_methods> because all
795 that same information is discoverable through the attribute
800 =head2 Package Variables
802 Since Perl's classes are built atop the Perl package system, it is
803 fairly common to use package scoped variables for things like static
804 class variables. The following methods are convience methods for
805 the creation and inspection of package scoped variables.
809 =item B<add_package_variable ($variable_name, ?$initial_value)>
811 Given a C<$variable_name>, which must contain a leading sigil, this
812 method will create that variable within the package which houses the
813 class. It also takes an optional C<$initial_value>, which must be a
814 reference of the same type as the sigil of the C<$variable_name>
817 =item B<get_package_variable ($variable_name)>
819 This will return a reference to the package variable in
822 =item B<has_package_variable ($variable_name)>
824 Returns true (C<1>) if there is a package variable defined for
825 C<$variable_name>, and false (C<0>) otherwise.
827 =item B<remove_package_variable ($variable_name)>
829 This will attempt to remove the package variable at C<$variable_name>.
835 Stevan Little E<lt>stevan@iinteractive.comE<gt>
837 =head1 COPYRIGHT AND LICENSE
839 Copyright 2006 by Infinity Interactive, Inc.
841 L<http://www.iinteractive.com>
843 This library is free software; you can redistribute it and/or modify
844 it under the same terms as Perl itself.