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';
17 # Metaclasses are singletons, so we cache them here.
18 # there is no need to worry about destruction though
19 # because they should die only when the program dies.
20 # After all, do package definitions even get reaped?
23 my ($class, $package_name) = @_;
24 (defined $package_name && $package_name)
25 || confess "You must pass a package name";
26 $METAS{$package_name} ||= bless {
27 '$:pkg' => $package_name,
29 } => blessed($class) || $class;
34 my ($class, $package_name, $package_version, %options) = @_;
35 (defined $package_name && $package_name)
36 || confess "You must pass a package name";
37 my $code = "package $package_name;";
38 $code .= "\$$package_name\:\:VERSION = '$package_version';"
39 if defined $package_version;
41 confess "creation of $package_name failed : $@" if $@;
42 my $meta = $class->initialize($package_name);
43 $meta->superclasses(@{$options{superclasses}})
44 if exists $options{superclasses};
45 if (exists $options{methods}) {
46 foreach my $method_name (keys %{$options{methods}}) {
47 $meta->add_method($method_name, $options{methods}->{$method_name});
53 # Instance Construction
55 sub construct_instance {
56 my ($canidate, %params) = @_;
62 sub name { $_[0]->{'$:pkg'} }
67 ${$self->name . '::VERSION'};
77 @{$self->name . '::ISA'} = @supers;
79 @{$self->name . '::ISA'};
82 sub class_precedence_list {
85 # We need to check for ciruclar inheirtance here.
86 # This will do nothing if all is well, and blow
87 # up otherwise. Yes, it's an ugly hack, better
88 # suggestions are welcome.
89 { $self->name->isa('This is a test for circular inheritance') }
90 # ... and no back to our regularly scheduled program
94 $self->initialize($_)->class_precedence_list()
95 } $self->superclasses()
102 my ($self, $method_name, $method) = @_;
103 (defined $method_name && $method_name)
104 || confess "You must define a method name";
105 # use reftype here to allow for blessed subs ...
106 (reftype($method) && reftype($method) eq 'CODE')
107 || confess "Your code block must be a CODE reference";
108 my $full_method_name = ($self->name . '::' . $method_name);
111 no warnings 'redefine';
112 *{$full_method_name} = subname $full_method_name => $method;
117 ## private utility functions for has_method
118 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
119 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } };
122 my ($self, $method_name) = @_;
123 (defined $method_name && $method_name)
124 || confess "You must define a method name";
126 my $sub_name = ($self->name . '::' . $method_name);
129 return 0 if !defined(&{$sub_name});
130 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
131 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
138 my ($self, $method_name) = @_;
139 (defined $method_name && $method_name)
140 || confess "You must define a method name";
143 return \&{$self->name . '::' . $method_name}
144 if $self->has_method($method_name);
145 return; # <- make sure to return undef
149 my ($self, $method_name) = @_;
150 (defined $method_name && $method_name)
151 || confess "You must define a method name";
153 my $removed_method = $self->get_method($method_name);
156 delete ${$self->name . '::'}{$method_name}
157 if defined $removed_method;
159 return $removed_method;
162 sub get_method_list {
165 grep { $self->has_method($_) } %{$self->name . '::'};
168 sub compute_all_applicable_methods {
171 # keep a record of what we have seen
172 # here, this will handle all the
173 # inheritence issues because we are
174 # using the &class_precedence_list
175 my (%seen_class, %seen_method);
176 foreach my $class ($self->class_precedence_list()) {
177 next if $seen_class{$class};
178 $seen_class{$class}++;
179 # fetch the meta-class ...
180 my $meta = $self->initialize($class);
181 foreach my $method_name ($meta->get_method_list()) {
182 next if exists $seen_method{$method_name};
183 $seen_method{$method_name}++;
185 name => $method_name,
187 code => $meta->get_method($method_name)
194 sub find_all_methods_by_name {
195 my ($self, $method_name) = @_;
196 (defined $method_name && $method_name)
197 || confess "You must define a method name to find";
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
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);
210 name => $method_name,
212 code => $meta->get_method($method_name)
213 } if $meta->has_method($method_name);
222 my ($self, $attribute_name, $attribute) = @_;
223 (defined $attribute_name && $attribute_name)
224 || confess "You must define an attribute name";
225 (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
226 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
227 $self->{'%:attrs'}->{$attribute_name} = $attribute;
231 my ($self, $attribute_name) = @_;
232 (defined $attribute_name && $attribute_name)
233 || confess "You must define an attribute name";
234 exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
238 my ($self, $attribute_name) = @_;
239 (defined $attribute_name && $attribute_name)
240 || confess "You must define an attribute name";
241 return $self->{'%:attrs'}->{$attribute_name}
242 if $self->has_attribute($attribute_name);
245 sub remove_attribute {
246 my ($self, $attribute_name) = @_;
247 (defined $attribute_name && $attribute_name)
248 || confess "You must define an attribute name";
249 my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
250 delete $self->{'%:attrs'}->{$attribute_name}
251 if defined $removed_attribute;
252 return $removed_attribute;
255 sub get_attribute_list {
257 keys %{$self->{'%:attrs'}};
260 sub compute_all_applicable_attributes {
263 # keep a record of what we have seen
264 # here, this will handle all the
265 # inheritence issues because we are
266 # using the &class_precedence_list
267 my (%seen_class, %seen_attr);
268 foreach my $class ($self->class_precedence_list()) {
269 next if $seen_class{$class};
270 $seen_class{$class}++;
271 # fetch the meta-class ...
272 my $meta = $self->initialize($class);
273 foreach my $attr_name ($meta->get_attribute_list()) {
274 next if exists $seen_attr{$attr_name};
275 $seen_attr{$attr_name}++;
279 attribute => $meta->get_attribute($attr_name)
286 sub create_all_accessors {
298 Class::MOP::Class - Class Meta Object
306 =head2 Class construction
308 These methods handle creating Class objects, which can be used to
309 both create new classes, and analyze pre-existing ones.
311 This module will internally store references to all the instances
312 you create with these methods, so that they do not need to be
313 created any more than nessecary. Basically, they are singletons.
317 =item B<create ($package_name, ?$package_version,
318 superclasses => ?@superclasses,
319 methods => ?%methods,
320 attributes => ?%attributes)>
322 This returns the basic Class object, bringing the specified
323 C<$package_name> into existence and adding any of the
324 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
327 =item B<initialize ($package_name)>
329 This initializes a Class object for a given a C<$package_name>.
333 =head2 Instance construction
337 =item B<construct_instance ($canidate, %params)>
339 This will construct and instance using the C<$canidate> as storage
340 (currently only HASH references are supported). This will collect all
341 the applicable attribute meta-objects and layout out the fields in the
342 C<$canidate>, it will then initialize them using either use the
343 corresponding key in C<%params> or any default value or initializer
344 found in the attribute meta-object.
354 This is a read-only attribute which returns the package name that
355 the Class is stored in.
359 This is a read-only attribute which returns the C<$VERSION> of the
360 package the Class is stored in.
364 =head2 Inheritance Relationships
368 =item B<superclasses (?@superclasses)>
370 This is a read-write attribute which represents the superclass
371 relationships of this Class. Basically, it can get and set the
374 =item B<class_precedence_list>
376 This computes the a list of the Class's ancestors in the same order
377 in which method dispatch will be done.
385 =item B<add_method ($method_name, $method)>
387 This will take a C<$method_name> and CODE reference to that
388 C<$method> and install it into the Class.
390 B<NOTE> : This does absolutely nothing special to C<$method>
391 other than use B<Sub::Name> to make sure it is tagged with the
392 correct name, and therefore show up correctly in stack traces and
395 =item B<has_method ($method_name)>
397 This just provides a simple way to check if the Class implements
398 a specific C<$method_name>. It will I<not> however, attempt to check
399 if the class inherits the method.
401 This will correctly handle functions defined outside of the package
402 that use a fully qualified name (C<sub Package::name { ... }>).
404 This will correctly handle functions renamed with B<Sub::Name> and
405 installed using the symbol tables. However, if you are naming the
406 subroutine outside of the package scope, you must use the fully
407 qualified name, including the package name, for C<has_method> to
408 correctly identify it.
410 This will attempt to correctly ignore functions imported from other
411 packages using B<Exporter>. It breaks down if the function imported
412 is an C<__ANON__> sub (such as with C<use constant>), which very well
413 may be a valid method being applied to the class.
415 In short, this method cannot always be trusted to determine if the
416 C<$method_name> is actually a method. However, it will DWIM about
417 90% of the time, so it's a small trade off IMO.
419 =item B<get_method ($method_name)>
421 This will return a CODE reference of the specified C<$method_name>,
422 or return undef if that method does not exist.
424 =item B<remove_method ($method_name)>
426 This will attempt to remove a given C<$method_name> from the Class.
427 It will return the CODE reference that it has removed, and will
428 attempt to use B<Sub::Name> to clear the methods associated name.
430 =item B<get_method_list>
432 This will return a list of method names for all I<locally> defined
433 methods. It does B<not> provide a list of all applicable methods,
434 including any inherited ones. If you want a list of all applicable
435 methods, use the C<compute_all_applicable_methods> method.
437 =item B<compute_all_applicable_methods>
439 This will return a list of all the methods names this Class will
440 support, taking into account inheritance. The list will be a list of
441 HASH references, each one containing the following information; method
442 name, the name of the class in which the method lives and a CODE
443 reference for the actual method.
445 =item B<find_all_methods_by_name ($method_name)>
447 This will traverse the inheritence hierarchy and locate all methods
448 with a given C<$method_name>. Similar to
449 C<compute_all_applicable_methods> it returns a list of HASH references
450 with the following information; method name (which will always be the
451 same as C<$method_name>), the name of the class in which the method
452 lives and a CODE reference for the actual method.
454 The list of methods produced is a distinct list, meaning there are no
455 duplicates in it. This is especially useful for things like object
456 initialization and destruction where you only want the method called
457 once, and in the correct order.
463 It should be noted that since there is no one consistent way to define
464 the attributes of a class in Perl 5. These methods can only work with
465 the information given, and can not easily discover information on
470 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
472 This stores a C<$attribute_meta_object> in the Class object and
473 associates it with the C<$attribute_name>. Unlike methods, attributes
474 within the MOP are stored as meta-information only. They will be used
475 later to construct instances from (see C<construct_instance> above).
476 More details about the attribute meta-objects can be found in the
477 L<The Attribute protocol> section of this document.
479 =item B<has_attribute ($attribute_name)>
481 Checks to see if this Class has an attribute by the name of
482 C<$attribute_name> and returns a boolean.
484 =item B<get_attribute ($attribute_name)>
486 Returns the attribute meta-object associated with C<$attribute_name>,
487 if none is found, it will return undef.
489 =item B<remove_attribute ($attribute_name)>
491 This will remove the attribute meta-object stored at
492 C<$attribute_name>, then return the removed attribute meta-object.
494 B<NOTE:> Removing an attribute will only affect future instances of
495 the class, it will not make any attempt to remove the attribute from
496 any existing instances of the class.
498 =item B<get_attribute_list>
500 This returns a list of attribute names which are defined in the local
501 class. If you want a list of all applicable attributes for a class,
502 use the C<compute_all_applicable_attributes> method.
504 =item B<compute_all_applicable_attributes>
506 This will traverse the inheritance heirachy and return a list of HASH
507 references for all the applicable attributes for this class. The HASH
508 references will contain the following information; the attribute name,
509 the class which the attribute is associated with and the actual
510 attribute meta-object
512 =item B<create_all_accessors>
514 This will communicate with all of the classes attributes to create
515 and install the appropriate accessors. (see L<The Attribute Protocol>
516 below for more details).
522 Stevan Little E<gt>stevan@iinteractive.comE<lt>
524 =head1 COPYRIGHT AND LICENSE
526 Copyright 2006 by Infinity Interactive, Inc.
528 L<http://www.iinteractive.com>
530 This library is free software; you can redistribute it and/or modify
531 it under the same terms as Perl itself.