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 $METAS{$package_name} ||= bless {
31 '$:pkg' => $package_name,
33 } => blessed($class) || $class;
38 my ($class, $package_name, $package_version, %options) = @_;
39 (defined $package_name && $package_name)
40 || confess "You must pass a package name";
41 my $code = "package $package_name;";
42 $code .= "\$$package_name\:\:VERSION = '$package_version';"
43 if defined $package_version;
45 confess "creation of $package_name failed : $@" if $@;
46 my $meta = $class->initialize($package_name);
47 $meta->superclasses(@{$options{superclasses}})
48 if exists $options{superclasses};
50 # process attributes first, so that they can
51 # install accessors, but locally defined methods
52 # can then overwrite them. It is maybe a little odd, but
53 # I think this should be the order of things.
54 if (exists $options{attributes}) {
55 foreach my $attr_name (keys %{$options{attributes}}) {
56 $meta->add_attribute($attr_name, $options{attributes}->{$attr_name});
59 if (exists $options{methods}) {
60 foreach my $method_name (keys %{$options{methods}}) {
61 $meta->add_method($method_name, $options{methods}->{$method_name});
67 # Instance Construction
69 sub construct_instance {
70 my ($canidate, %params) = @_;
76 sub name { $_[0]->{'$:pkg'} }
81 ${$self->name . '::VERSION'};
91 @{$self->name . '::ISA'} = @supers;
93 @{$self->name . '::ISA'};
96 sub class_precedence_list {
99 # We need to check for ciruclar inheirtance here.
100 # This will do nothing if all is well, and blow
101 # up otherwise. Yes, it's an ugly hack, better
102 # suggestions are welcome.
103 { $self->name->isa('This is a test for circular inheritance') }
104 # ... and no back to our regularly scheduled program
108 $self->initialize($_)->class_precedence_list()
109 } $self->superclasses()
116 my ($self, $method_name, $method) = @_;
117 (defined $method_name && $method_name)
118 || confess "You must define a method name";
119 # use reftype here to allow for blessed subs ...
120 (reftype($method) && reftype($method) eq 'CODE')
121 || confess "Your code block must be a CODE reference";
122 my $full_method_name = ($self->name . '::' . $method_name);
125 no warnings 'redefine';
126 *{$full_method_name} = subname $full_method_name => $method;
131 ## private utility functions for has_method
132 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
133 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
136 my ($self, $method_name) = @_;
137 (defined $method_name && $method_name)
138 || confess "You must define a method name";
140 my $sub_name = ($self->name . '::' . $method_name);
143 return 0 if !defined(&{$sub_name});
144 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
145 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
152 my ($self, $method_name) = @_;
153 (defined $method_name && $method_name)
154 || confess "You must define a method name";
157 return \&{$self->name . '::' . $method_name}
158 if $self->has_method($method_name);
159 return; # <- make sure to return undef
163 my ($self, $method_name) = @_;
164 (defined $method_name && $method_name)
165 || confess "You must define a method name";
167 my $removed_method = $self->get_method($method_name);
170 delete ${$self->name . '::'}{$method_name}
171 if defined $removed_method;
173 return $removed_method;
176 sub get_method_list {
179 grep { $self->has_method($_) } %{$self->name . '::'};
182 sub compute_all_applicable_methods {
185 # keep a record of what we have seen
186 # here, this will handle all the
187 # inheritence issues because we are
188 # using the &class_precedence_list
189 my (%seen_class, %seen_method);
190 foreach my $class ($self->class_precedence_list()) {
191 next if $seen_class{$class};
192 $seen_class{$class}++;
193 # fetch the meta-class ...
194 my $meta = $self->initialize($class);
195 foreach my $method_name ($meta->get_method_list()) {
196 next if exists $seen_method{$method_name};
197 $seen_method{$method_name}++;
199 name => $method_name,
201 code => $meta->get_method($method_name)
208 sub find_all_methods_by_name {
209 my ($self, $method_name) = @_;
210 (defined $method_name && $method_name)
211 || confess "You must define a method name to find";
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
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);
224 name => $method_name,
226 code => $meta->get_method($method_name)
227 } if $meta->has_method($method_name);
236 my ($self,$attribute) = @_;
237 (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
238 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
239 $attribute->install_accessors($self);
240 $self->{'%:attrs'}->{$attribute->name} = $attribute;
244 my ($self, $attribute_name) = @_;
245 (defined $attribute_name && $attribute_name)
246 || confess "You must define an attribute name";
247 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
251 my ($self, $attribute_name) = @_;
252 (defined $attribute_name && $attribute_name)
253 || confess "You must define an attribute name";
254 return $self->{'%:attrs'}->{$attribute_name}
255 if $self->has_attribute($attribute_name);
258 sub remove_attribute {
259 my ($self, $attribute_name) = @_;
260 (defined $attribute_name && $attribute_name)
261 || confess "You must define an attribute name";
262 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
263 delete $self->{'%:attrs'}->{$attribute_name}
264 if defined $removed_attribute;
265 $removed_attribute->remove_accessors($self);
266 return $removed_attribute;
269 sub get_attribute_list {
271 keys %{$self->{'%:attrs'}};
274 sub compute_all_applicable_attributes {
277 # keep a record of what we have seen
278 # here, this will handle all the
279 # inheritence issues because we are
280 # using the &class_precedence_list
281 my (%seen_class, %seen_attr);
282 foreach my $class ($self->class_precedence_list()) {
283 next if $seen_class{$class};
284 $seen_class{$class}++;
285 # fetch the meta-class ...
286 my $meta = $self->initialize($class);
287 foreach my $attr_name ($meta->get_attribute_list()) {
288 next if exists $seen_attr{$attr_name};
289 $seen_attr{$attr_name}++;
293 attribute => $meta->get_attribute($attr_name)
309 Class::MOP::Class - Class Meta Object
317 =head2 Self Introspection
323 This allows Class::MOP::Class to actually introspect itself.
327 =head2 Class construction
329 These methods handle creating Class objects, which can be used to
330 both create new classes, and analyze pre-existing ones.
332 This module will internally store references to all the instances
333 you create with these methods, so that they do not need to be
334 created any more than nessecary. Basically, they are singletons.
338 =item B<create ($package_name, ?$package_version,
339 superclasses => ?@superclasses,
340 methods => ?%methods,
341 attributes => ?%attributes)>
343 This returns the basic Class object, bringing the specified
344 C<$package_name> into existence and adding any of the
345 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
348 =item B<initialize ($package_name)>
350 This initializes a Class object for a given a C<$package_name>.
354 =head2 Instance construction
358 =item B<construct_instance ($canidate, %params)>
360 This will construct and instance using the C<$canidate> as storage
361 (currently only HASH references are supported). This will collect all
362 the applicable attribute meta-objects and layout out the fields in the
363 C<$canidate>, it will then initialize them using either use the
364 corresponding key in C<%params> or any default value or initializer
365 found in the attribute meta-object.
375 This is a read-only attribute which returns the package name that
376 the Class is stored in.
380 This is a read-only attribute which returns the C<$VERSION> of the
381 package the Class is stored in.
385 =head2 Inheritance Relationships
389 =item B<superclasses (?@superclasses)>
391 This is a read-write attribute which represents the superclass
392 relationships of this Class. Basically, it can get and set the
395 =item B<class_precedence_list>
397 This computes the a list of the Class's ancestors in the same order
398 in which method dispatch will be done.
406 =item B<add_method ($method_name, $method)>
408 This will take a C<$method_name> and CODE reference to that
409 C<$method> and install it into the Class.
411 B<NOTE> : This does absolutely nothing special to C<$method>
412 other than use B<Sub::Name> to make sure it is tagged with the
413 correct name, and therefore show up correctly in stack traces and
416 =item B<has_method ($method_name)>
418 This just provides a simple way to check if the Class implements
419 a specific C<$method_name>. It will I<not> however, attempt to check
420 if the class inherits the method.
422 This will correctly handle functions defined outside of the package
423 that use a fully qualified name (C<sub Package::name { ... }>).
425 This will correctly handle functions renamed with B<Sub::Name> and
426 installed using the symbol tables. However, if you are naming the
427 subroutine outside of the package scope, you must use the fully
428 qualified name, including the package name, for C<has_method> to
429 correctly identify it.
431 This will attempt to correctly ignore functions imported from other
432 packages using B<Exporter>. It breaks down if the function imported
433 is an C<__ANON__> sub (such as with C<use constant>), which very well
434 may be a valid method being applied to the class.
436 In short, this method cannot always be trusted to determine if the
437 C<$method_name> is actually a method. However, it will DWIM about
438 90% of the time, so it's a small trade off IMO.
440 =item B<get_method ($method_name)>
442 This will return a CODE reference of the specified C<$method_name>,
443 or return undef if that method does not exist.
445 =item B<remove_method ($method_name)>
447 This will attempt to remove a given C<$method_name> from the Class.
448 It will return the CODE reference that it has removed, and will
449 attempt to use B<Sub::Name> to clear the methods associated name.
451 =item B<get_method_list>
453 This will return a list of method names for all I<locally> defined
454 methods. It does B<not> provide a list of all applicable methods,
455 including any inherited ones. If you want a list of all applicable
456 methods, use the C<compute_all_applicable_methods> method.
458 =item B<compute_all_applicable_methods>
460 This will return a list of all the methods names this Class will
461 support, taking into account inheritance. The list will be a list of
462 HASH references, each one containing the following information; method
463 name, the name of the class in which the method lives and a CODE
464 reference for the actual method.
466 =item B<find_all_methods_by_name ($method_name)>
468 This will traverse the inheritence hierarchy and locate all methods
469 with a given C<$method_name>. Similar to
470 C<compute_all_applicable_methods> it returns a list of HASH references
471 with the following information; method name (which will always be the
472 same as C<$method_name>), the name of the class in which the method
473 lives and a CODE reference for the actual method.
475 The list of methods produced is a distinct list, meaning there are no
476 duplicates in it. This is especially useful for things like object
477 initialization and destruction where you only want the method called
478 once, and in the correct order.
484 It should be noted that since there is no one consistent way to define
485 the attributes of a class in Perl 5. These methods can only work with
486 the information given, and can not easily discover information on
491 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
493 This stores a C<$attribute_meta_object> in the Class object and
494 associates it with the C<$attribute_name>. Unlike methods, attributes
495 within the MOP are stored as meta-information only. They will be used
496 later to construct instances from (see C<construct_instance> above).
497 More details about the attribute meta-objects can be found in the
498 L<The Attribute protocol> section of this document.
500 =item B<has_attribute ($attribute_name)>
502 Checks to see if this Class has an attribute by the name of
503 C<$attribute_name> and returns a boolean.
505 =item B<get_attribute ($attribute_name)>
507 Returns the attribute meta-object associated with C<$attribute_name>,
508 if none is found, it will return undef.
510 =item B<remove_attribute ($attribute_name)>
512 This will remove the attribute meta-object stored at
513 C<$attribute_name>, then return the removed attribute meta-object.
515 B<NOTE:> Removing an attribute will only affect future instances of
516 the class, it will not make any attempt to remove the attribute from
517 any existing instances of the class.
519 =item B<get_attribute_list>
521 This returns a list of attribute names which are defined in the local
522 class. If you want a list of all applicable attributes for a class,
523 use the C<compute_all_applicable_attributes> method.
525 =item B<compute_all_applicable_attributes>
527 This will traverse the inheritance heirachy and return a list of HASH
528 references for all the applicable attributes for this class. The HASH
529 references will contain the following information; the attribute name,
530 the class which the attribute is associated with and the actual
531 attribute meta-object.
537 Stevan Little E<gt>stevan@iinteractive.comE<lt>
539 =head1 COPYRIGHT AND LICENSE
541 Copyright 2006 by Infinity Interactive, Inc.
543 L<http://www.iinteractive.com>
545 This library is free software; you can redistribute it and/or modify
546 it under the same terms as Perl itself.