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. It will be replaces in
38 # the bootstrap section in Class::MOP with one
39 # which uses the 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";
45 '$:pkg' => $package_name,
47 } => blessed($class) || $class
52 my ($class, $package_name, $package_version, %options) = @_;
53 (defined $package_name && $package_name)
54 || confess "You must pass a package name";
55 my $code = "package $package_name;";
56 $code .= "\$$package_name\:\:VERSION = '$package_version';"
57 if defined $package_version;
59 confess "creation of $package_name failed : $@" if $@;
60 my $meta = $class->initialize($package_name);
61 $meta->superclasses(@{$options{superclasses}})
62 if exists $options{superclasses};
64 # process attributes first, so that they can
65 # install accessors, but locally defined methods
66 # can then overwrite them. It is maybe a little odd, but
67 # I think this should be the order of things.
68 if (exists $options{attributes}) {
69 foreach my $attr (@{$options{attributes}}) {
70 $meta->add_attribute($attr);
73 if (exists $options{methods}) {
74 foreach my $method_name (keys %{$options{methods}}) {
75 $meta->add_method($method_name, $options{methods}->{$method_name});
81 # Instance Construction
83 sub construct_instance {
84 my ($class, %params) = @_;
86 foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
87 # if the attr has an init_arg, use that, otherwise,
88 # use the attributes name itself as the init_arg
89 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
90 # try to fetch the init arg from the %params ...
92 $val = $params{$init_arg} if exists $params{$init_arg};
93 # if nothing was in the %params, we can use the
94 # attribute's default value (if it has one)
95 $val ||= $attr->default($instance) if $attr->has_default();
96 # now add this to the instance structure
97 $instance->{$attr->name} = $val;
104 sub name { $_[0]->{'$:pkg'} }
109 ${$self->name . '::VERSION'};
119 @{$self->name . '::ISA'} = @supers;
121 @{$self->name . '::ISA'};
124 sub class_precedence_list {
127 # We need to check for ciruclar inheirtance here.
128 # This will do nothing if all is well, and blow
129 # up otherwise. Yes, it's an ugly hack, better
130 # suggestions are welcome.
131 { $self->name->isa('This is a test for circular inheritance') }
132 # ... and no back to our regularly scheduled program
136 $self->initialize($_)->class_precedence_list()
137 } $self->superclasses()
144 my ($self, $method_name, $method) = @_;
145 (defined $method_name && $method_name)
146 || confess "You must define a method name";
147 # use reftype here to allow for blessed subs ...
148 (reftype($method) && reftype($method) eq 'CODE')
149 || confess "Your code block must be a CODE reference";
150 my $full_method_name = ($self->name . '::' . $method_name);
153 no warnings 'redefine';
154 *{$full_method_name} = subname $full_method_name => $method;
159 ## private utility functions for has_method
160 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
161 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
164 my ($self, $method_name) = @_;
165 (defined $method_name && $method_name)
166 || confess "You must define a method name";
168 my $sub_name = ($self->name . '::' . $method_name);
171 return 0 if !defined(&{$sub_name});
172 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
173 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
180 my ($self, $method_name) = @_;
181 (defined $method_name && $method_name)
182 || confess "You must define a method name";
185 return \&{$self->name . '::' . $method_name}
186 if $self->has_method($method_name);
187 return; # <- make sure to return undef
191 my ($self, $method_name) = @_;
192 (defined $method_name && $method_name)
193 || confess "You must define a method name";
195 my $removed_method = $self->get_method($method_name);
198 delete ${$self->name . '::'}{$method_name}
199 if defined $removed_method;
201 return $removed_method;
204 sub get_method_list {
207 grep { $self->has_method($_) } %{$self->name . '::'};
210 sub compute_all_applicable_methods {
213 # keep a record of what we have seen
214 # here, this will handle all the
215 # inheritence issues because we are
216 # using the &class_precedence_list
217 my (%seen_class, %seen_method);
218 foreach my $class ($self->class_precedence_list()) {
219 next if $seen_class{$class};
220 $seen_class{$class}++;
221 # fetch the meta-class ...
222 my $meta = $self->initialize($class);
223 foreach my $method_name ($meta->get_method_list()) {
224 next if exists $seen_method{$method_name};
225 $seen_method{$method_name}++;
227 name => $method_name,
229 code => $meta->get_method($method_name)
236 sub find_all_methods_by_name {
237 my ($self, $method_name) = @_;
238 (defined $method_name && $method_name)
239 || confess "You must define a method name to find";
241 # keep a record of what we have seen
242 # here, this will handle all the
243 # inheritence issues because we are
244 # using the &class_precedence_list
246 foreach my $class ($self->class_precedence_list()) {
247 next if $seen_class{$class};
248 $seen_class{$class}++;
249 # fetch the meta-class ...
250 my $meta = $self->initialize($class);
252 name => $method_name,
254 code => $meta->get_method($method_name)
255 } if $meta->has_method($method_name);
264 my ($self,$attribute) = @_;
265 (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
266 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
267 $attribute->install_accessors($self);
268 $self->{'%:attrs'}->{$attribute->name} = $attribute;
272 my ($self, $attribute_name) = @_;
273 (defined $attribute_name && $attribute_name)
274 || confess "You must define an attribute name";
275 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
279 my ($self, $attribute_name) = @_;
280 (defined $attribute_name && $attribute_name)
281 || confess "You must define an attribute name";
282 return $self->{'%:attrs'}->{$attribute_name}
283 if $self->has_attribute($attribute_name);
286 sub remove_attribute {
287 my ($self, $attribute_name) = @_;
288 (defined $attribute_name && $attribute_name)
289 || confess "You must define an attribute name";
290 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
291 delete $self->{'%:attrs'}->{$attribute_name}
292 if defined $removed_attribute;
293 $removed_attribute->remove_accessors($self);
294 return $removed_attribute;
297 sub get_attribute_list {
299 keys %{$self->{'%:attrs'}};
302 sub compute_all_applicable_attributes {
305 # keep a record of what we have seen
306 # here, this will handle all the
307 # inheritence issues because we are
308 # using the &class_precedence_list
309 my (%seen_class, %seen_attr);
310 foreach my $class ($self->class_precedence_list()) {
311 next if $seen_class{$class};
312 $seen_class{$class}++;
313 # fetch the meta-class ...
314 my $meta = $self->initialize($class);
315 foreach my $attr_name ($meta->get_attribute_list()) {
316 next if exists $seen_attr{$attr_name};
317 $seen_attr{$attr_name}++;
321 attribute => $meta->get_attribute($attr_name)
336 Class::MOP::Class - Class Meta Object
340 # use this for introspection ...
343 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
345 # elsewhere in the code ...
347 # add a method to Foo ...
348 Foo->meta->add_method('bar' => sub { ... })
350 # get a list of all the classes searched
351 # the method dispatcher in the correct order
352 Foo->meta->class_precedence_list()
354 # remove a method from Foo
355 Foo->meta->remove_method('bar');
357 # or use this to actually create classes ...
359 Class::MOP::Class->create('Bar' => '0.01' => (
360 superclasses => [ 'Foo' ],
362 Class::MOP:::Attribute->new('$bar'),
363 Class::MOP:::Attribute->new('$baz'),
366 calculate_bar => sub { ... },
367 construct_baz => sub { ... }
373 This is the largest and currently most complex part of the Perl 5
374 meta-object protocol. It controls the introspection and
375 manipulation of Perl 5 classes (and it can create them too). The
376 best way to understand what this module can do, is to read the
377 documentation for each of it's methods.
381 =head2 Self Introspection
387 This will return a B<Class::MOP::Class> instance which is related
388 to this class. Thereby allowing B<Class::MOP::Class> to actually
391 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
392 bootstrap this module by installing a number of attribute meta-objects
393 into it's metaclass. This will allow this class to reap all the benifits
394 of the MOP when subclassing it.
398 =head2 Class construction
400 These methods handle creating Class objects, which can be used to
401 both create new classes, and analyze pre-existing ones.
403 This module will internally store references to all the instances
404 you create with these methods, so that they do not need to be
405 created any more than nessecary. Basically, they are singletons.
409 =item B<create ($package_name, ?$package_version,
410 superclasses => ?@superclasses,
411 methods => ?%methods,
412 attributes => ?%attributes)>
414 This returns the basic Class object, bringing the specified
415 C<$package_name> into existence and adding any of the
416 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
419 =item B<initialize ($package_name)>
421 This initializes a Class object for a given a C<$package_name>.
425 =head2 Instance construction
429 =item B<construct_instance (%params)>
431 This will construct and instance using a HASH ref as storage
432 (currently only HASH references are supported). This will collect all
433 the applicable attribute meta-objects and layout out the fields in the
434 HASH ref, it will then initialize them using either use the
435 corresponding key in C<%params> or any default value or initializer
436 found in the attribute meta-object.
438 =item B<construct_class_instance ($package_name)>
440 This will construct an instance of B<Class::MOP::Class>, it is
441 here so that we can actually "tie the knot" for B<Class::MOP::Class>
442 to use C<construct_instance> once all the bootstrapping is done. This
443 method is used internally by C<initialize> and should never be called
444 from outside of that method really.
454 This is a read-only attribute which returns the package name that
455 the Class is stored in.
459 This is a read-only attribute which returns the C<$VERSION> of the
460 package the Class is stored in.
464 =head2 Inheritance Relationships
468 =item B<superclasses (?@superclasses)>
470 This is a read-write attribute which represents the superclass
471 relationships of this Class. Basically, it can get and set the
474 =item B<class_precedence_list>
476 This computes the a list of the Class's ancestors in the same order
477 in which method dispatch will be done.
485 =item B<add_method ($method_name, $method)>
487 This will take a C<$method_name> and CODE reference to that
488 C<$method> and install it into the Class.
490 B<NOTE> : This does absolutely nothing special to C<$method>
491 other than use B<Sub::Name> to make sure it is tagged with the
492 correct name, and therefore show up correctly in stack traces and
495 =item B<has_method ($method_name)>
497 This just provides a simple way to check if the Class implements
498 a specific C<$method_name>. It will I<not> however, attempt to check
499 if the class inherits the method.
501 This will correctly handle functions defined outside of the package
502 that use a fully qualified name (C<sub Package::name { ... }>).
504 This will correctly handle functions renamed with B<Sub::Name> and
505 installed using the symbol tables. However, if you are naming the
506 subroutine outside of the package scope, you must use the fully
507 qualified name, including the package name, for C<has_method> to
508 correctly identify it.
510 This will attempt to correctly ignore functions imported from other
511 packages using B<Exporter>. It breaks down if the function imported
512 is an C<__ANON__> sub (such as with C<use constant>), which very well
513 may be a valid method being applied to the class.
515 In short, this method cannot always be trusted to determine if the
516 C<$method_name> is actually a method. However, it will DWIM about
517 90% of the time, so it's a small trade off IMO.
519 =item B<get_method ($method_name)>
521 This will return a CODE reference of the specified C<$method_name>,
522 or return undef if that method does not exist.
524 =item B<remove_method ($method_name)>
526 This will attempt to remove a given C<$method_name> from the Class.
527 It will return the CODE reference that it has removed, and will
528 attempt to use B<Sub::Name> to clear the methods associated name.
530 =item B<get_method_list>
532 This will return a list of method names for all I<locally> defined
533 methods. It does B<not> provide a list of all applicable methods,
534 including any inherited ones. If you want a list of all applicable
535 methods, use the C<compute_all_applicable_methods> method.
537 =item B<compute_all_applicable_methods>
539 This will return a list of all the methods names this Class will
540 support, taking into account inheritance. The list will be a list of
541 HASH references, each one containing the following information; method
542 name, the name of the class in which the method lives and a CODE
543 reference for the actual method.
545 =item B<find_all_methods_by_name ($method_name)>
547 This will traverse the inheritence hierarchy and locate all methods
548 with a given C<$method_name>. Similar to
549 C<compute_all_applicable_methods> it returns a list of HASH references
550 with the following information; method name (which will always be the
551 same as C<$method_name>), the name of the class in which the method
552 lives and a CODE reference for the actual method.
554 The list of methods produced is a distinct list, meaning there are no
555 duplicates in it. This is especially useful for things like object
556 initialization and destruction where you only want the method called
557 once, and in the correct order.
563 It should be noted that since there is no one consistent way to define
564 the attributes of a class in Perl 5. These methods can only work with
565 the information given, and can not easily discover information on
570 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
572 This stores a C<$attribute_meta_object> in the Class object and
573 associates it with the C<$attribute_name>. Unlike methods, attributes
574 within the MOP are stored as meta-information only. They will be used
575 later to construct instances from (see C<construct_instance> above).
576 More details about the attribute meta-objects can be found in the
577 L<The Attribute protocol> section of this document.
579 =item B<has_attribute ($attribute_name)>
581 Checks to see if this Class has an attribute by the name of
582 C<$attribute_name> and returns a boolean.
584 =item B<get_attribute ($attribute_name)>
586 Returns the attribute meta-object associated with C<$attribute_name>,
587 if none is found, it will return undef.
589 =item B<remove_attribute ($attribute_name)>
591 This will remove the attribute meta-object stored at
592 C<$attribute_name>, then return the removed attribute meta-object.
594 B<NOTE:> Removing an attribute will only affect future instances of
595 the class, it will not make any attempt to remove the attribute from
596 any existing instances of the class.
598 =item B<get_attribute_list>
600 This returns a list of attribute names which are defined in the local
601 class. If you want a list of all applicable attributes for a class,
602 use the C<compute_all_applicable_attributes> method.
604 =item B<compute_all_applicable_attributes>
606 This will traverse the inheritance heirachy and return a list of HASH
607 references for all the applicable attributes for this class. The HASH
608 references will contain the following information; the attribute name,
609 the class which the attribute is associated with and the actual
610 attribute meta-object.
616 Stevan Little E<gt>stevan@iinteractive.comE<lt>
618 =head1 COPYRIGHT AND LICENSE
620 Copyright 2006 by Infinity Interactive, Inc.
622 L<http://www.iinteractive.com>
624 This library is free software; you can redistribute it and/or modify
625 it under the same terms as Perl itself.