many docs additions and a new test
[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm
CommitLineData
8b978dd5 1
2package Class::MOP::Class;
3
4use strict;
5use warnings;
6
7use Carp 'confess';
0882828e 8use Scalar::Util 'blessed', 'reftype';
8b978dd5 9use Sub::Name 'subname';
10use B 'svref_2object';
11
12our $VERSION = '0.01';
13
2eb717d5 14# Self-introspection
15
16sub meta { $_[0]->initialize($_[0]) }
17
8b978dd5 18# Creation
19
bfe4d0fc 20{
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?
25 my %METAS;
26 sub initialize {
27 my ($class, $package_name) = @_;
28 (defined $package_name && $package_name)
727919c5 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);
32 }
33
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";
44 bless {
e16da3e6 45 '$:pkg' => $package_name,
46 '%:attrs' => {}
727919c5 47 } => blessed($class) || $class
bfe4d0fc 48 }
8b978dd5 49}
50
51sub create {
52 my ($class, $package_name, $package_version, %options) = @_;
bfe4d0fc 53 (defined $package_name && $package_name)
8b978dd5 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;
58 eval $code;
59 confess "creation of $package_name failed : $@" if $@;
bfe4d0fc 60 my $meta = $class->initialize($package_name);
8b978dd5 61 $meta->superclasses(@{$options{superclasses}})
62 if exists $options{superclasses};
2eb717d5 63 # NOTE:
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}) {
cbd9f942 69 foreach my $attr (@{$options{attributes}}) {
70 $meta->add_attribute($attr);
2eb717d5 71 }
72 }
bfe4d0fc 73 if (exists $options{methods}) {
74 foreach my $method_name (keys %{$options{methods}}) {
75 $meta->add_method($method_name, $options{methods}->{$method_name});
76 }
2eb717d5 77 }
8b978dd5 78 return $meta;
79}
80
e16da3e6 81# Instance Construction
82
83sub construct_instance {
cbd9f942 84 my ($class, %params) = @_;
85 my $instance = {};
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 ...
91 my $val;
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)
c50c603e 95 $val ||= $attr->default($instance) if $attr->has_default();
cbd9f942 96 # now add this to the instance structure
97 $instance->{$attr->name} = $val;
98 }
99 return $instance;
e16da3e6 100}
101
8b978dd5 102# Informational
103
e16da3e6 104sub name { $_[0]->{'$:pkg'} }
8b978dd5 105
106sub version {
107 my $self = shift;
108 no strict 'refs';
109 ${$self->name . '::VERSION'};
110}
111
112# Inheritance
113
114sub superclasses {
115 my $self = shift;
116 no strict 'refs';
117 if (@_) {
118 my @supers = @_;
119 @{$self->name . '::ISA'} = @supers;
120 }
121 @{$self->name . '::ISA'};
122}
123
124sub class_precedence_list {
125 my $self = shift;
bfe4d0fc 126 # NOTE:
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
8b978dd5 133 (
134 $self->name,
135 map {
bfe4d0fc 136 $self->initialize($_)->class_precedence_list()
8b978dd5 137 } $self->superclasses()
138 );
139}
140
0882828e 141## Methods
142
143sub add_method {
144 my ($self, $method_name, $method) = @_;
145 (defined $method_name && $method_name)
146 || confess "You must define a method name";
a5eca695 147 # use reftype here to allow for blessed subs ...
0882828e 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);
151
152 no strict 'refs';
c9b8b7f9 153 no warnings 'redefine';
0882828e 154 *{$full_method_name} = subname $full_method_name => $method;
155}
156
bfe4d0fc 157{
158
159 ## private utility functions for has_method
2eb717d5 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 } || '' };
bfe4d0fc 162
163 sub has_method {
c9b8b7f9 164 my ($self, $method_name) = @_;
bfe4d0fc 165 (defined $method_name && $method_name)
166 || confess "You must define a method name";
0882828e 167
bfe4d0fc 168 my $sub_name = ($self->name . '::' . $method_name);
0882828e 169
bfe4d0fc 170 no strict 'refs';
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__';
174 return 1;
175 }
176
0882828e 177}
178
179sub get_method {
c9b8b7f9 180 my ($self, $method_name) = @_;
0882828e 181 (defined $method_name && $method_name)
182 || confess "You must define a method name";
183
184 no strict 'refs';
185 return \&{$self->name . '::' . $method_name}
bfe4d0fc 186 if $self->has_method($method_name);
c9b8b7f9 187 return; # <- make sure to return undef
188}
189
190sub remove_method {
191 my ($self, $method_name) = @_;
192 (defined $method_name && $method_name)
193 || confess "You must define a method name";
194
195 my $removed_method = $self->get_method($method_name);
196
197 no strict 'refs';
198 delete ${$self->name . '::'}{$method_name}
199 if defined $removed_method;
200
201 return $removed_method;
202}
203
204sub get_method_list {
205 my $self = shift;
206 no strict 'refs';
a5eca695 207 grep { $self->has_method($_) } %{$self->name . '::'};
208}
209
210sub compute_all_applicable_methods {
211 my $self = shift;
212 my @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}++;
226 push @methods => {
227 name => $method_name,
228 class => $class,
229 code => $meta->get_method($method_name)
230 };
231 }
232 }
233 return @methods;
234}
235
a5eca695 236sub 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";
240 my @methods;
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
245 my %seen_class;
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);
251 push @methods => {
252 name => $method_name,
253 class => $class,
254 code => $meta->get_method($method_name)
255 } if $meta->has_method($method_name);
256 }
257 return @methods;
258
8b978dd5 259}
260
552e3d24 261## Attributes
262
e16da3e6 263sub add_attribute {
2eb717d5 264 my ($self,$attribute) = @_;
e16da3e6 265 (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
266 || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
2eb717d5 267 $attribute->install_accessors($self);
268 $self->{'%:attrs'}->{$attribute->name} = $attribute;
e16da3e6 269}
270
271sub has_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;
276}
277
278sub get_attribute {
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);
284}
285
286sub 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;
2eb717d5 293 $removed_attribute->remove_accessors($self);
e16da3e6 294 return $removed_attribute;
295}
296
297sub get_attribute_list {
298 my $self = shift;
299 keys %{$self->{'%:attrs'}};
300}
301
302sub compute_all_applicable_attributes {
303 my $self = shift;
304 my @attrs;
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}++;
318 push @attrs => {
319 name => $attr_name,
320 class => $class,
321 attribute => $meta->get_attribute($attr_name)
322 };
323 }
324 }
325 return @attrs;
326}
2eb717d5 327
8b978dd5 3281;
329
330__END__
331
332=pod
333
334=head1 NAME
335
336Class::MOP::Class - Class Meta Object
337
338=head1 SYNOPSIS
339
fe122940 340 # use this for introspection ...
341
342 package Foo;
343 sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
344
345 # elsewhere in the code ...
346
347 # add a method to Foo ...
348 Foo->meta->add_method('bar' => sub { ... })
349
350 # get a list of all the classes searched
351 # the method dispatcher in the correct order
352 Foo->meta->class_precedence_list()
353
354 # remove a method from Foo
355 Foo->meta->remove_method('bar');
356
357 # or use this to actually create classes ...
358
359 Class::MOP::Class->create('Bar' => '0.01' => (
360 superclasses => [ 'Foo' ],
361 attributes => [
362 Class::MOP:::Attribute->new('$bar'),
363 Class::MOP:::Attribute->new('$baz'),
364 ],
365 methods => {
366 calculate_bar => sub { ... },
367 construct_baz => sub { ... }
368 }
369 ));
370
8b978dd5 371=head1 DESCRIPTION
372
fe122940 373This is the largest and currently most complex part of the Perl 5
374meta-object protocol. It controls the introspection and
375manipulation of Perl 5 classes (and it can create them too). The
376best way to understand what this module can do, is to read the
377documentation for each of it's methods.
378
552e3d24 379=head1 METHODS
380
2eb717d5 381=head2 Self Introspection
382
383=over 4
384
385=item B<meta>
386
fe122940 387This will return a B<Class::MOP::Class> instance which is related
388to this class. Thereby allowing B<Class::MOP::Class> to actually
389introspect itself.
390
391As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
392bootstrap this module by installing a number of attribute meta-objects
393into it's metaclass. This will allow this class to reap all the benifits
394of the MOP when subclassing it.
2eb717d5 395
396=back
397
552e3d24 398=head2 Class construction
399
400These methods handle creating Class objects, which can be used to
401both create new classes, and analyze pre-existing ones.
402
403This module will internally store references to all the instances
404you create with these methods, so that they do not need to be
405created any more than nessecary. Basically, they are singletons.
406
407=over 4
408
409=item B<create ($package_name, ?$package_version,
410 superclasses => ?@superclasses,
411 methods => ?%methods,
412 attributes => ?%attributes)>
413
414This returns the basic Class object, bringing the specified
415C<$package_name> into existence and adding any of the
416C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
417to it.
418
419=item B<initialize ($package_name)>
420
421This initializes a Class object for a given a C<$package_name>.
422
423=back
424
425=head2 Instance construction
426
427=over 4
428
cbd9f942 429=item B<construct_instance (%params)>
552e3d24 430
cbd9f942 431This will construct and instance using a HASH ref as storage
552e3d24 432(currently only HASH references are supported). This will collect all
433the applicable attribute meta-objects and layout out the fields in the
cbd9f942 434HASH ref, it will then initialize them using either use the
552e3d24 435corresponding key in C<%params> or any default value or initializer
436found in the attribute meta-object.
437
727919c5 438=item B<construct_class_instance ($package_name)>
439
440This will construct an instance of B<Class::MOP::Class>, it is
441here so that we can actually "tie the knot" for B<Class::MOP::Class>
442to use C<construct_instance> once all the bootstrapping is done. This
443method is used internally by C<initialize> and should never be called
444from outside of that method really.
445
552e3d24 446=back
447
448=head2 Informational
449
450=over 4
451
452=item B<name>
453
454This is a read-only attribute which returns the package name that
455the Class is stored in.
456
457=item B<version>
458
459This is a read-only attribute which returns the C<$VERSION> of the
460package the Class is stored in.
461
462=back
463
464=head2 Inheritance Relationships
465
466=over 4
467
468=item B<superclasses (?@superclasses)>
469
470This is a read-write attribute which represents the superclass
471relationships of this Class. Basically, it can get and set the
472C<@ISA> for you.
473
474=item B<class_precedence_list>
475
476This computes the a list of the Class's ancestors in the same order
477in which method dispatch will be done.
478
479=back
480
481=head2 Methods
482
483=over 4
484
485=item B<add_method ($method_name, $method)>
486
487This will take a C<$method_name> and CODE reference to that
488C<$method> and install it into the Class.
489
490B<NOTE> : This does absolutely nothing special to C<$method>
491other than use B<Sub::Name> to make sure it is tagged with the
492correct name, and therefore show up correctly in stack traces and
493such.
494
495=item B<has_method ($method_name)>
496
497This just provides a simple way to check if the Class implements
498a specific C<$method_name>. It will I<not> however, attempt to check
499if the class inherits the method.
500
501This will correctly handle functions defined outside of the package
502that use a fully qualified name (C<sub Package::name { ... }>).
503
504This will correctly handle functions renamed with B<Sub::Name> and
505installed using the symbol tables. However, if you are naming the
506subroutine outside of the package scope, you must use the fully
507qualified name, including the package name, for C<has_method> to
508correctly identify it.
509
510This will attempt to correctly ignore functions imported from other
511packages using B<Exporter>. It breaks down if the function imported
512is an C<__ANON__> sub (such as with C<use constant>), which very well
513may be a valid method being applied to the class.
514
515In short, this method cannot always be trusted to determine if the
516C<$method_name> is actually a method. However, it will DWIM about
51790% of the time, so it's a small trade off IMO.
518
519=item B<get_method ($method_name)>
520
521This will return a CODE reference of the specified C<$method_name>,
522or return undef if that method does not exist.
523
524=item B<remove_method ($method_name)>
525
526This will attempt to remove a given C<$method_name> from the Class.
527It will return the CODE reference that it has removed, and will
528attempt to use B<Sub::Name> to clear the methods associated name.
529
530=item B<get_method_list>
531
532This will return a list of method names for all I<locally> defined
533methods. It does B<not> provide a list of all applicable methods,
534including any inherited ones. If you want a list of all applicable
535methods, use the C<compute_all_applicable_methods> method.
536
537=item B<compute_all_applicable_methods>
538
539This will return a list of all the methods names this Class will
540support, taking into account inheritance. The list will be a list of
541HASH references, each one containing the following information; method
542name, the name of the class in which the method lives and a CODE
543reference for the actual method.
544
545=item B<find_all_methods_by_name ($method_name)>
546
547This will traverse the inheritence hierarchy and locate all methods
548with a given C<$method_name>. Similar to
549C<compute_all_applicable_methods> it returns a list of HASH references
550with the following information; method name (which will always be the
551same as C<$method_name>), the name of the class in which the method
552lives and a CODE reference for the actual method.
553
554The list of methods produced is a distinct list, meaning there are no
555duplicates in it. This is especially useful for things like object
556initialization and destruction where you only want the method called
557once, and in the correct order.
558
559=back
560
561=head2 Attributes
562
563It should be noted that since there is no one consistent way to define
564the attributes of a class in Perl 5. These methods can only work with
565the information given, and can not easily discover information on
566their own.
567
568=over 4
569
570=item B<add_attribute ($attribute_name, $attribute_meta_object)>
571
572This stores a C<$attribute_meta_object> in the Class object and
573associates it with the C<$attribute_name>. Unlike methods, attributes
574within the MOP are stored as meta-information only. They will be used
575later to construct instances from (see C<construct_instance> above).
576More details about the attribute meta-objects can be found in the
577L<The Attribute protocol> section of this document.
578
579=item B<has_attribute ($attribute_name)>
580
581Checks to see if this Class has an attribute by the name of
582C<$attribute_name> and returns a boolean.
583
584=item B<get_attribute ($attribute_name)>
585
586Returns the attribute meta-object associated with C<$attribute_name>,
587if none is found, it will return undef.
588
589=item B<remove_attribute ($attribute_name)>
590
591This will remove the attribute meta-object stored at
592C<$attribute_name>, then return the removed attribute meta-object.
593
594B<NOTE:> Removing an attribute will only affect future instances of
595the class, it will not make any attempt to remove the attribute from
596any existing instances of the class.
597
598=item B<get_attribute_list>
599
600This returns a list of attribute names which are defined in the local
601class. If you want a list of all applicable attributes for a class,
602use the C<compute_all_applicable_attributes> method.
603
604=item B<compute_all_applicable_attributes>
605
606This will traverse the inheritance heirachy and return a list of HASH
607references for all the applicable attributes for this class. The HASH
608references will contain the following information; the attribute name,
609the class which the attribute is associated with and the actual
2eb717d5 610attribute meta-object.
552e3d24 611
612=back
613
8b978dd5 614=head1 AUTHOR
615
616Stevan Little E<gt>stevan@iinteractive.comE<lt>
617
618=head1 COPYRIGHT AND LICENSE
619
620Copyright 2006 by Infinity Interactive, Inc.
621
622L<http://www.iinteractive.com>
623
624This library is free software; you can redistribute it and/or modify
625it under the same terms as Perl itself.
626
627=cut