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 (@{$options{attributes}}) {
56 $meta->add_attribute($attr);
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 ($class, %params) = @_;
72 foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
73 # if the attr has an init_arg, use that, otherwise,
74 # use the attributes name itself as the init_arg
75 my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
76 # try to fetch the init arg from the %params ...
78 $val = $params{$init_arg} if exists $params{$init_arg};
79 # if nothing was in the %params, we can use the
80 # attribute's default value (if it has one)
81 $val ||= $attr->default($instance) if $attr->has_default();
82 # now add this to the instance structure
83 $instance->{$attr->name} = $val;
90 sub name { $_[0]->{'$:pkg'} }
95 ${$self->name . '::VERSION'};
105 @{$self->name . '::ISA'} = @supers;
107 @{$self->name . '::ISA'};
110 sub class_precedence_list {
113 # We need to check for ciruclar inheirtance here.
114 # This will do nothing if all is well, and blow
115 # up otherwise. Yes, it's an ugly hack, better
116 # suggestions are welcome.
117 { $self->name->isa('This is a test for circular inheritance') }
118 # ... and no back to our regularly scheduled program
122 $self->initialize($_)->class_precedence_list()
123 } $self->superclasses()
130 my ($self, $method_name, $method) = @_;
131 (defined $method_name && $method_name)
132 || confess "You must define a method name";
133 # use reftype here to allow for blessed subs ...
134 (reftype($method) && reftype($method) eq 'CODE')
135 || confess "Your code block must be a CODE reference";
136 my $full_method_name = ($self->name . '::' . $method_name);
139 no warnings 'redefine';
140 *{$full_method_name} = subname $full_method_name => $method;
145 ## private utility functions for has_method
146 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
147 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
150 my ($self, $method_name) = @_;
151 (defined $method_name && $method_name)
152 || confess "You must define a method name";
154 my $sub_name = ($self->name . '::' . $method_name);
157 return 0 if !defined(&{$sub_name});
158 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
159 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
166 my ($self, $method_name) = @_;
167 (defined $method_name && $method_name)
168 || confess "You must define a method name";
171 return \&{$self->name . '::' . $method_name}
172 if $self->has_method($method_name);
173 return; # <- make sure to return undef
177 my ($self, $method_name) = @_;
178 (defined $method_name && $method_name)
179 || confess "You must define a method name";
181 my $removed_method = $self->get_method($method_name);
184 delete ${$self->name . '::'}{$method_name}
185 if defined $removed_method;
187 return $removed_method;
190 sub get_method_list {
193 grep { $self->has_method($_) } %{$self->name . '::'};
196 sub compute_all_applicable_methods {
199 # keep a record of what we have seen
200 # here, this will handle all the
201 # inheritence issues because we are
202 # using the &class_precedence_list
203 my (%seen_class, %seen_method);
204 foreach my $class ($self->class_precedence_list()) {
205 next if $seen_class{$class};
206 $seen_class{$class}++;
207 # fetch the meta-class ...
208 my $meta = $self->initialize($class);
209 foreach my $method_name ($meta->get_method_list()) {
210 next if exists $seen_method{$method_name};
211 $seen_method{$method_name}++;
213 name => $method_name,
215 code => $meta->get_method($method_name)
222 sub find_all_methods_by_name {
223 my ($self, $method_name) = @_;
224 (defined $method_name && $method_name)
225 || confess "You must define a method name to find";
227 # keep a record of what we have seen
228 # here, this will handle all the
229 # inheritence issues because we are
230 # using the &class_precedence_list
232 foreach my $class ($self->class_precedence_list()) {
233 next if $seen_class{$class};
234 $seen_class{$class}++;
235 # fetch the meta-class ...
236 my $meta = $self->initialize($class);
238 name => $method_name,
240 code => $meta->get_method($method_name)
241 } if $meta->has_method($method_name);
250 my ($self,$attribute) = @_;
251 (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
252 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
253 $attribute->install_accessors($self);
254 $self->{'%:attrs'}->{$attribute->name} = $attribute;
258 my ($self, $attribute_name) = @_;
259 (defined $attribute_name && $attribute_name)
260 || confess "You must define an attribute name";
261 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
265 my ($self, $attribute_name) = @_;
266 (defined $attribute_name && $attribute_name)
267 || confess "You must define an attribute name";
268 return $self->{'%:attrs'}->{$attribute_name}
269 if $self->has_attribute($attribute_name);
272 sub remove_attribute {
273 my ($self, $attribute_name) = @_;
274 (defined $attribute_name && $attribute_name)
275 || confess "You must define an attribute name";
276 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
277 delete $self->{'%:attrs'}->{$attribute_name}
278 if defined $removed_attribute;
279 $removed_attribute->remove_accessors($self);
280 return $removed_attribute;
283 sub get_attribute_list {
285 keys %{$self->{'%:attrs'}};
288 sub compute_all_applicable_attributes {
291 # keep a record of what we have seen
292 # here, this will handle all the
293 # inheritence issues because we are
294 # using the &class_precedence_list
295 my (%seen_class, %seen_attr);
296 foreach my $class ($self->class_precedence_list()) {
297 next if $seen_class{$class};
298 $seen_class{$class}++;
299 # fetch the meta-class ...
300 my $meta = $self->initialize($class);
301 foreach my $attr_name ($meta->get_attribute_list()) {
302 next if exists $seen_attr{$attr_name};
303 $seen_attr{$attr_name}++;
307 attribute => $meta->get_attribute($attr_name)
323 Class::MOP::Class - Class Meta Object
331 =head2 Self Introspection
337 This allows Class::MOP::Class to actually introspect itself.
341 =head2 Class construction
343 These methods handle creating Class objects, which can be used to
344 both create new classes, and analyze pre-existing ones.
346 This module will internally store references to all the instances
347 you create with these methods, so that they do not need to be
348 created any more than nessecary. Basically, they are singletons.
352 =item B<create ($package_name, ?$package_version,
353 superclasses => ?@superclasses,
354 methods => ?%methods,
355 attributes => ?%attributes)>
357 This returns the basic Class object, bringing the specified
358 C<$package_name> into existence and adding any of the
359 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
362 =item B<initialize ($package_name)>
364 This initializes a Class object for a given a C<$package_name>.
368 =head2 Instance construction
372 =item B<construct_instance (%params)>
374 This will construct and instance using a HASH ref as storage
375 (currently only HASH references are supported). This will collect all
376 the applicable attribute meta-objects and layout out the fields in the
377 HASH ref, it will then initialize them using either use the
378 corresponding key in C<%params> or any default value or initializer
379 found in the attribute meta-object.
389 This is a read-only attribute which returns the package name that
390 the Class is stored in.
394 This is a read-only attribute which returns the C<$VERSION> of the
395 package the Class is stored in.
399 =head2 Inheritance Relationships
403 =item B<superclasses (?@superclasses)>
405 This is a read-write attribute which represents the superclass
406 relationships of this Class. Basically, it can get and set the
409 =item B<class_precedence_list>
411 This computes the a list of the Class's ancestors in the same order
412 in which method dispatch will be done.
420 =item B<add_method ($method_name, $method)>
422 This will take a C<$method_name> and CODE reference to that
423 C<$method> and install it into the Class.
425 B<NOTE> : This does absolutely nothing special to C<$method>
426 other than use B<Sub::Name> to make sure it is tagged with the
427 correct name, and therefore show up correctly in stack traces and
430 =item B<has_method ($method_name)>
432 This just provides a simple way to check if the Class implements
433 a specific C<$method_name>. It will I<not> however, attempt to check
434 if the class inherits the method.
436 This will correctly handle functions defined outside of the package
437 that use a fully qualified name (C<sub Package::name { ... }>).
439 This will correctly handle functions renamed with B<Sub::Name> and
440 installed using the symbol tables. However, if you are naming the
441 subroutine outside of the package scope, you must use the fully
442 qualified name, including the package name, for C<has_method> to
443 correctly identify it.
445 This will attempt to correctly ignore functions imported from other
446 packages using B<Exporter>. It breaks down if the function imported
447 is an C<__ANON__> sub (such as with C<use constant>), which very well
448 may be a valid method being applied to the class.
450 In short, this method cannot always be trusted to determine if the
451 C<$method_name> is actually a method. However, it will DWIM about
452 90% of the time, so it's a small trade off IMO.
454 =item B<get_method ($method_name)>
456 This will return a CODE reference of the specified C<$method_name>,
457 or return undef if that method does not exist.
459 =item B<remove_method ($method_name)>
461 This will attempt to remove a given C<$method_name> from the Class.
462 It will return the CODE reference that it has removed, and will
463 attempt to use B<Sub::Name> to clear the methods associated name.
465 =item B<get_method_list>
467 This will return a list of method names for all I<locally> defined
468 methods. It does B<not> provide a list of all applicable methods,
469 including any inherited ones. If you want a list of all applicable
470 methods, use the C<compute_all_applicable_methods> method.
472 =item B<compute_all_applicable_methods>
474 This will return a list of all the methods names this Class will
475 support, taking into account inheritance. The list will be a list of
476 HASH references, each one containing the following information; method
477 name, the name of the class in which the method lives and a CODE
478 reference for the actual method.
480 =item B<find_all_methods_by_name ($method_name)>
482 This will traverse the inheritence hierarchy and locate all methods
483 with a given C<$method_name>. Similar to
484 C<compute_all_applicable_methods> it returns a list of HASH references
485 with the following information; method name (which will always be the
486 same as C<$method_name>), the name of the class in which the method
487 lives and a CODE reference for the actual method.
489 The list of methods produced is a distinct list, meaning there are no
490 duplicates in it. This is especially useful for things like object
491 initialization and destruction where you only want the method called
492 once, and in the correct order.
498 It should be noted that since there is no one consistent way to define
499 the attributes of a class in Perl 5. These methods can only work with
500 the information given, and can not easily discover information on
505 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
507 This stores a C<$attribute_meta_object> in the Class object and
508 associates it with the C<$attribute_name>. Unlike methods, attributes
509 within the MOP are stored as meta-information only. They will be used
510 later to construct instances from (see C<construct_instance> above).
511 More details about the attribute meta-objects can be found in the
512 L<The Attribute protocol> section of this document.
514 =item B<has_attribute ($attribute_name)>
516 Checks to see if this Class has an attribute by the name of
517 C<$attribute_name> and returns a boolean.
519 =item B<get_attribute ($attribute_name)>
521 Returns the attribute meta-object associated with C<$attribute_name>,
522 if none is found, it will return undef.
524 =item B<remove_attribute ($attribute_name)>
526 This will remove the attribute meta-object stored at
527 C<$attribute_name>, then return the removed attribute meta-object.
529 B<NOTE:> Removing an attribute will only affect future instances of
530 the class, it will not make any attempt to remove the attribute from
531 any existing instances of the class.
533 =item B<get_attribute_list>
535 This returns a list of attribute names which are defined in the local
536 class. If you want a list of all applicable attributes for a class,
537 use the C<compute_all_applicable_attributes> method.
539 =item B<compute_all_applicable_attributes>
541 This will traverse the inheritance heirachy and return a list of HASH
542 references for all the applicable attributes for this class. The HASH
543 references will contain the following information; the attribute name,
544 the class which the attribute is associated with and the actual
545 attribute meta-object.
551 Stevan Little E<gt>stevan@iinteractive.comE<lt>
553 =head1 COPYRIGHT AND LICENSE
555 Copyright 2006 by Infinity Interactive, Inc.
557 L<http://www.iinteractive.com>
559 This library is free software; you can redistribute it and/or modify
560 it under the same terms as Perl itself.