fix
[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm
1
2 package Class::MOP::Class;
3
4 use strict;
5 use warnings;
6
7 use Carp         'confess';
8 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name    'subname';
10 use B            'svref_2object';
11
12 our $VERSION = '0.14';
13
14 use Class::MOP::Instance;
15
16 # Self-introspection 
17
18 sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
19
20 # Creation
21
22 {
23     # Metaclasses are singletons, so we cache them here.
24     # there is no need to worry about destruction though
25     # because they should die only when the program dies.
26     # After all, do package definitions even get reaped?
27     my %METAS;  
28     
29     # means of accessing all the metaclasses that have 
30     # been initialized thus far (for mugwumps obj browser)
31     sub get_all_metaclasses         {        %METAS }            
32     sub get_all_metaclass_instances { values %METAS } 
33     sub get_all_metaclass_names     { keys   %METAS }     
34     
35     sub initialize {
36         my $class        = shift;
37         my $package_name = shift;
38         (defined $package_name && $package_name && !blessed($package_name))
39             || confess "You must pass a package name and it cannot be blessed";    
40         $class->construct_class_instance(':package' => $package_name, @_);
41     }
42     
43     # NOTE: (meta-circularity) 
44     # this is a special form of &construct_instance 
45     # (see below), which is used to construct class
46     # meta-object instances for any Class::MOP::* 
47     # class. All other classes will use the more 
48     # normal &construct_instance.
49     sub construct_class_instance {
50         my $class        = shift;
51         my %options      = @_;
52         my $package_name = $options{':package'};
53         (defined $package_name && $package_name)
54             || confess "You must pass a package name";  
55         # NOTE:
56         # return the metaclass if we have it cached, 
57         # and it is still defined (it has not been 
58         # reaped by DESTROY yet, which can happen 
59         # annoyingly enough during global destruction)
60         return $METAS{$package_name} 
61             if exists $METAS{$package_name} && defined $METAS{$package_name};  
62         $class = blessed($class) || $class;
63         # now create the metaclass
64         my $meta;
65         if ($class =~ /^Class::MOP::/) {    
66             $meta = bless { 
67                 '$:package'             => $package_name, 
68                 '%:attributes'          => {},
69                 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
70                 '$:method_metaclass'    => $options{':method_metaclass'}    || 'Class::MOP::Method',
71                 '$:instance_metaclass'  => $options{':instance_metaclass'}  || 'Class::MOP::Instance',    
72             } => $class;
73         }
74         else {
75             # NOTE:
76             # it is safe to use meta here because
77             # class will always be a subclass of 
78             # Class::MOP::Class, which defines meta
79             $meta = bless $class->meta->construct_instance(%options) => $class
80         }
81         # and check the metaclass compatibility
82         $meta->check_metaclass_compatability();
83         $METAS{$package_name} = $meta;
84     }
85     
86     sub check_metaclass_compatability {
87         my $self = shift;
88
89         # this is always okay ...
90         return if blessed($self) eq 'Class::MOP::Class';
91
92         my @class_list = $self->class_precedence_list;
93         shift @class_list; # shift off $self->name
94
95         foreach my $class_name (@class_list) { 
96             my $meta = $METAS{$class_name} || next;
97             ($self->isa(blessed($meta)))
98                 || confess $self->name . "->meta => (" . (blessed($self)) . ")" . 
99                            " is not compatible with the " . 
100                            $class_name . "->meta => (" . (blessed($meta)) . ")";
101             # NOTE:
102             # we also need to check that instance metaclasses
103             # are compatabile in the same the class.
104             ($self->instance_metaclass->isa($meta->instance_metaclass))
105                 || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" . 
106                            " is not compatible with the " . 
107                            $class_name . "->meta => (" . ($meta->instance_metaclass) . ")";                           
108         }        
109     }
110 }
111
112 sub create {
113     my ($class, $package_name, $package_version, %options) = @_;
114     (defined $package_name && $package_name)
115         || confess "You must pass a package name";
116     my $code = "package $package_name;";
117     $code .= "\$$package_name\:\:VERSION = '$package_version';" 
118         if defined $package_version;
119     eval $code;
120     confess "creation of $package_name failed : $@" if $@;    
121     my $meta = $class->initialize($package_name);
122     
123     $meta->add_method('meta' => sub { 
124         Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
125     });
126     
127     $meta->superclasses(@{$options{superclasses}})
128         if exists $options{superclasses};
129     # NOTE:
130     # process attributes first, so that they can 
131     # install accessors, but locally defined methods
132     # can then overwrite them. It is maybe a little odd, but
133     # I think this should be the order of things.
134     if (exists $options{attributes}) {
135         foreach my $attr (@{$options{attributes}}) {
136             $meta->add_attribute($attr);
137         }
138     }        
139     if (exists $options{methods}) {
140         foreach my $method_name (keys %{$options{methods}}) {
141             $meta->add_method($method_name, $options{methods}->{$method_name});
142         }
143     }  
144     return $meta;
145 }
146
147 {
148     # NOTE:
149     # this should be sufficient, if you have a 
150     # use case where it is not, write a test and 
151     # I will change it.
152     my $ANON_CLASS_SERIAL = 0;
153     
154     sub create_anon_class {
155         my ($class, %options) = @_;   
156         my $package_name = 'Class::MOP::Class::__ANON__::SERIAL::' . ++$ANON_CLASS_SERIAL;
157         return $class->create($package_name, '0.00', %options);
158     }
159 }
160
161 ## Attribute readers
162
163 # NOTE:
164 # all these attribute readers will be bootstrapped 
165 # away in the Class::MOP bootstrap section
166
167 sub name                { $_[0]->{'$:package'}             }
168 sub get_attribute_map   { $_[0]->{'%:attributes'}          }
169 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
170 sub method_metaclass    { $_[0]->{'$:method_metaclass'}    }
171 sub instance_metaclass  { $_[0]->{'$:instance_metaclass'}  }
172
173 # Instance Construction & Cloning
174
175 sub new_object {
176     my $class = shift;
177     # NOTE:
178     # we need to protect the integrity of the 
179     # Class::MOP::Class singletons here, so we
180     # delegate this to &construct_class_instance
181     # which will deal with the singletons
182     return $class->construct_class_instance(@_)
183         if $class->name->isa('Class::MOP::Class');
184     return $class->construct_instance(@_);
185 }
186
187 sub construct_instance {
188     my ($class, %params) = @_;
189     my $meta_instance = $class->get_meta_instance();
190     my $instance = $meta_instance->create_instance();
191     foreach my $attr ($class->compute_all_applicable_attributes()) {
192         $attr->initialize_instance_slot($meta_instance, $instance, \%params);
193     }
194     return $instance;
195 }
196
197 sub get_meta_instance {
198     my $class = shift;
199     return $class->instance_metaclass->new(
200         $class, 
201         $class->compute_all_applicable_attributes()
202     );
203 }
204
205 sub clone_object {
206     my $class    = shift;
207     my $instance = shift; 
208     (blessed($instance) && $instance->isa($class->name))
209         || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
210     # NOTE:
211     # we need to protect the integrity of the 
212     # Class::MOP::Class singletons here, they 
213     # should not be cloned.
214     return $instance if $instance->isa('Class::MOP::Class');   
215     $class->clone_instance($instance, @_);
216 }
217
218 sub clone_instance {
219     my ($class, $instance, %params) = @_;
220     (blessed($instance))
221         || confess "You can only clone instances, \$self is not a blessed instance";
222     my $meta_instance = $class->get_meta_instance();
223     my $clone = $meta_instance->clone_instance($instance);        
224     foreach my $key (%params) {
225         next unless $meta_instance->is_valid_slot($key);
226         $meta_instance->set_slot_value($clone, $key, $params{$key});
227     }
228     return $clone;    
229 }
230
231 # Informational 
232
233 # &name should be here too, but it is above
234 # because it gets bootstrapped away
235
236 sub version {  
237     my $self = shift;
238     ${$self->get_package_variable('$VERSION')};
239 }
240
241 # Inheritance
242
243 sub superclasses {
244     my $self = shift;
245     no strict 'refs';
246     if (@_) {
247         my @supers = @_;
248         @{$self->name . '::ISA'} = @supers;
249     }
250     @{$self->name . '::ISA'};
251 }
252
253 sub class_precedence_list {
254     my $self = shift;
255     # NOTE:
256     # We need to check for ciruclar inheirtance here.
257     # This will do nothing if all is well, and blow
258     # up otherwise. Yes, it's an ugly hack, better 
259     # suggestions are welcome.
260     { ($self->name || return)->isa('This is a test for circular inheritance') }
261     # ... and now back to our regularly scheduled program
262     (
263         $self->name, 
264         map { 
265             $self->initialize($_)->class_precedence_list()
266         } $self->superclasses()
267     );   
268 }
269
270 ## Methods
271
272 sub add_method {
273     my ($self, $method_name, $method) = @_;
274     (defined $method_name && $method_name)
275         || confess "You must define a method name";
276     # use reftype here to allow for blessed subs ...
277     ('CODE' eq (reftype($method) || ''))
278         || confess "Your code block must be a CODE reference";
279     my $full_method_name = ($self->name . '::' . $method_name);    
280
281     $method = $self->method_metaclass->wrap($method) unless blessed($method);
282     
283     no strict 'refs';
284     no warnings 'redefine';
285     *{$full_method_name} = subname $full_method_name => $method;
286 }
287
288 {
289     my $fetch_and_prepare_method = sub {
290         my ($self, $method_name) = @_;
291         # fetch it locally
292         my $method = $self->get_method($method_name);
293         # if we dont have local ...
294         unless ($method) {
295             # make sure this method even exists ...
296             ($self->find_next_method_by_name($method_name))
297                 || confess "The method '$method_name' is not found in the inherience hierarchy for this class";
298             # if so, then create a local which just 
299             # calls the next applicable method ...              
300             $self->add_method($method_name => sub {
301                 $self->find_next_method_by_name($method_name)->(@_);
302             });
303             $method = $self->get_method($method_name);
304         }
305         
306         # now make sure we wrap it properly 
307         # (if it isnt already)
308         unless ($method->isa('Class::MOP::Method::Wrapped')) {
309             $method = Class::MOP::Method::Wrapped->wrap($method);
310             $self->add_method($method_name => $method); 
311         }       
312         return $method;
313     };
314
315     sub add_before_method_modifier {
316         my ($self, $method_name, $method_modifier) = @_;
317         (defined $method_name && $method_name)
318             || confess "You must pass in a method name";    
319         my $method = $fetch_and_prepare_method->($self, $method_name);
320         $method->add_before_modifier(subname ':before' => $method_modifier);
321     }
322
323     sub add_after_method_modifier {
324         my ($self, $method_name, $method_modifier) = @_;
325         (defined $method_name && $method_name)
326             || confess "You must pass in a method name";    
327         my $method = $fetch_and_prepare_method->($self, $method_name);
328         $method->add_after_modifier(subname ':after' => $method_modifier);
329     }
330     
331     sub add_around_method_modifier {
332         my ($self, $method_name, $method_modifier) = @_;
333         (defined $method_name && $method_name)
334             || confess "You must pass in a method name";
335         my $method = $fetch_and_prepare_method->($self, $method_name);
336         $method->add_around_modifier(subname ':around' => $method_modifier);
337     }   
338
339     # NOTE: 
340     # the methods above used to be named like this:
341     #    ${pkg}::${method}:(before|after|around)
342     # but this proved problematic when using one modifier
343     # to wrap multiple methods (something which is likely
344     # to happen pretty regularly IMO). So instead of naming
345     # it like this, I have chosen to just name them purely 
346     # with their modifier names, like so:
347     #    :(before|after|around)
348     # The fact is that in a stack trace, it will be fairly 
349     # evident from the context what method they are attached
350     # to, and so don't need the fully qualified name.
351 }
352
353 sub alias_method {
354     my ($self, $method_name, $method) = @_;
355     (defined $method_name && $method_name)
356         || confess "You must define a method name";
357     # use reftype here to allow for blessed subs ...
358     ('CODE' eq (reftype($method) || ''))
359         || confess "Your code block must be a CODE reference";
360     my $full_method_name = ($self->name . '::' . $method_name);
361
362     $method = $self->method_metaclass->wrap($method) unless blessed($method);    
363         
364     no strict 'refs';
365     no warnings 'redefine';
366     *{$full_method_name} = $method;
367 }
368
369 sub has_method {
370     my ($self, $method_name) = @_;
371     (defined $method_name && $method_name)
372         || confess "You must define a method name";    
373
374     my $sub_name = ($self->name . '::' . $method_name);   
375     
376     no strict 'refs';
377     return 0 if !defined(&{$sub_name});        
378     my $method = \&{$sub_name};
379     return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name &&
380                 (svref_2object($method)->GV->NAME || '')        ne '__ANON__';      
381     
382     # at this point we are relatively sure 
383     # it is our method, so we bless/wrap it 
384     $self->method_metaclass->wrap($method) unless blessed($method);
385     return 1;
386 }
387
388 sub get_method {
389     my ($self, $method_name) = @_;
390     (defined $method_name && $method_name)
391         || confess "You must define a method name";
392
393     return unless $self->has_method($method_name);
394
395     no strict 'refs';    
396     return \&{$self->name . '::' . $method_name};
397 }
398
399 sub remove_method {
400     my ($self, $method_name) = @_;
401     (defined $method_name && $method_name)
402         || confess "You must define a method name";
403     
404     my $removed_method = $self->get_method($method_name);    
405     
406     no strict 'refs';
407     delete ${$self->name . '::'}{$method_name}
408         if defined $removed_method;
409         
410     return $removed_method;
411 }
412
413 sub get_method_list {
414     my $self = shift;
415     no strict 'refs';
416     grep { $self->has_method($_) } keys %{$self->name . '::'};
417 }
418
419 sub compute_all_applicable_methods {
420     my $self = shift;
421     my @methods;
422     # keep a record of what we have seen
423     # here, this will handle all the 
424     # inheritence issues because we are 
425     # using the &class_precedence_list
426     my (%seen_class, %seen_method);
427     foreach my $class ($self->class_precedence_list()) {
428         next if $seen_class{$class};
429         $seen_class{$class}++;
430         # fetch the meta-class ...
431         my $meta = $self->initialize($class);
432         foreach my $method_name ($meta->get_method_list()) { 
433             next if exists $seen_method{$method_name};
434             $seen_method{$method_name}++;
435             push @methods => {
436                 name  => $method_name, 
437                 class => $class,
438                 code  => $meta->get_method($method_name)
439             };
440         }
441     }
442     return @methods;
443 }
444
445 sub find_all_methods_by_name {
446     my ($self, $method_name) = @_;
447     (defined $method_name && $method_name)
448         || confess "You must define a method name to find";    
449     my @methods;
450     # keep a record of what we have seen
451     # here, this will handle all the 
452     # inheritence issues because we are 
453     # using the &class_precedence_list
454     my %seen_class;
455     foreach my $class ($self->class_precedence_list()) {
456         next if $seen_class{$class};
457         $seen_class{$class}++;
458         # fetch the meta-class ...
459         my $meta = $self->initialize($class);
460         push @methods => {
461             name  => $method_name, 
462             class => $class,
463             code  => $meta->get_method($method_name)
464         } if $meta->has_method($method_name);
465     }
466     return @methods;
467 }
468
469 sub find_next_method_by_name {
470     my ($self, $method_name) = @_;
471     (defined $method_name && $method_name)
472         || confess "You must define a method name to find"; 
473     # keep a record of what we have seen
474     # here, this will handle all the 
475     # inheritence issues because we are 
476     # using the &class_precedence_list
477     my %seen_class;
478     my @cpl = $self->class_precedence_list();
479     shift @cpl; # discard ourselves
480     foreach my $class (@cpl) {
481         next if $seen_class{$class};
482         $seen_class{$class}++;
483         # fetch the meta-class ...
484         my $meta = $self->initialize($class);
485         return $meta->get_method($method_name) 
486             if $meta->has_method($method_name);
487     }
488     return;
489 }
490
491 ## Attributes
492
493 sub add_attribute {
494     my $self      = shift;
495     # either we have an attribute object already
496     # or we need to create one from the args provided
497     my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
498     # make sure it is derived from the correct type though
499     ($attribute->isa('Class::MOP::Attribute'))
500         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";    
501     $attribute->attach_to_class($self);
502     $attribute->install_accessors();
503     $self->get_attribute_map->{$attribute->name} = $attribute;
504
505         # FIXME
506         # in theory we have to tell everyone the slot structure may have changed
507 }
508
509 sub has_attribute {
510     my ($self, $attribute_name) = @_;
511     (defined $attribute_name && $attribute_name)
512         || confess "You must define an attribute name";
513     exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;    
514
515
516 sub get_attribute {
517     my ($self, $attribute_name) = @_;
518     (defined $attribute_name && $attribute_name)
519         || confess "You must define an attribute name";
520     return $self->get_attribute_map->{$attribute_name} 
521         if $self->has_attribute($attribute_name);   
522     return; 
523
524
525 sub remove_attribute {
526     my ($self, $attribute_name) = @_;
527     (defined $attribute_name && $attribute_name)
528         || confess "You must define an attribute name";
529     my $removed_attribute = $self->get_attribute_map->{$attribute_name};    
530     return unless defined $removed_attribute;
531     delete $self->get_attribute_map->{$attribute_name};        
532     $removed_attribute->remove_accessors(); 
533     $removed_attribute->detach_from_class();
534     return $removed_attribute;
535
536
537 sub get_attribute_list {
538     my $self = shift;
539     keys %{$self->get_attribute_map};
540
541
542 sub compute_all_applicable_attributes {
543     my $self = shift;
544     my @attrs;
545     # keep a record of what we have seen
546     # here, this will handle all the 
547     # inheritence issues because we are 
548     # using the &class_precedence_list
549     my (%seen_class, %seen_attr);
550     foreach my $class ($self->class_precedence_list()) {
551         next if $seen_class{$class};
552         $seen_class{$class}++;
553         # fetch the meta-class ...
554         my $meta = $self->initialize($class);
555         foreach my $attr_name ($meta->get_attribute_list()) { 
556             next if exists $seen_attr{$attr_name};
557             $seen_attr{$attr_name}++;
558             push @attrs => $meta->get_attribute($attr_name);
559         }
560     }
561     return @attrs;    
562 }
563
564 sub find_attribute_by_name {
565     my ($self, $attr_name) = @_;
566     # keep a record of what we have seen
567     # here, this will handle all the 
568     # inheritence issues because we are 
569     # using the &class_precedence_list
570     my %seen_class;
571     foreach my $class ($self->class_precedence_list()) {
572         next if $seen_class{$class};
573         $seen_class{$class}++;
574         # fetch the meta-class ...
575         my $meta = $self->initialize($class);
576         return $meta->get_attribute($attr_name)
577             if $meta->has_attribute($attr_name);
578     }
579     return;
580 }
581
582 # Class attributes
583
584 sub add_package_variable {
585     my ($self, $variable, $initial_value) = @_;
586     (defined $variable && $variable =~ /^[\$\@\%]/)
587         || confess "variable name does not have a sigil";
588     
589     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); 
590     if (defined $initial_value) {
591         no strict 'refs';
592         *{$self->name . '::' . $name} = $initial_value;
593     }
594     else {
595         my $e;
596         {        
597             # NOTE:
598             # We HAVE to localize $@ or all 
599             # hell breaks loose. It is not 
600             # good, believe me, not good.
601             local $@;
602             eval $sigil . $self->name . '::' . $name;
603             $e = $@ if $@;            
604         }
605         confess "Could not create package variable ($variable) because : $e" if $e;
606     }
607 }
608
609 sub has_package_variable {
610     my ($self, $variable) = @_;
611     (defined $variable && $variable =~ /^[\$\@\%]/)
612         || confess "variable name does not have a sigil";
613     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); 
614     no strict 'refs';
615     defined ${$self->name . '::'}{$name} ? 1 : 0;
616 }
617
618 sub get_package_variable {
619     my ($self, $variable) = @_;
620     (defined $variable && $variable =~ /^[\$\@\%]/)
621         || confess "variable name does not have a sigil";
622     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); 
623     my ($ref, $e);
624     {
625         # NOTE:
626         # We HAVE to localize $@ or all 
627         # hell breaks loose. It is not 
628         # good, believe me, not good.
629         local $@;        
630         $ref = eval '\\' . $sigil . $self->name . '::' . $name;
631         $e = $@ if $@;
632     }
633     confess "Could not get the package variable ($variable) because : $e" if $e;    
634     # if we didn't die, then we can return it
635     return $ref;
636 }
637
638 sub remove_package_variable {
639     my ($self, $variable) = @_;
640     (defined $variable && $variable =~ /^[\$\@\%]/)
641         || confess "variable name does not have a sigil";
642     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); 
643     no strict 'refs';
644     delete ${$self->name . '::'}{$name};
645 }
646
647 1;
648
649 __END__
650
651 =pod
652
653 =head1 NAME 
654
655 Class::MOP::Class - Class Meta Object
656
657 =head1 SYNOPSIS
658
659   # assuming that class Foo 
660   # has been defined, you can
661   
662   # use this for introspection ...
663   
664   # add a method to Foo ...
665   Foo->meta->add_method('bar' => sub { ... })
666   
667   # get a list of all the classes searched 
668   # the method dispatcher in the correct order 
669   Foo->meta->class_precedence_list()
670   
671   # remove a method from Foo
672   Foo->meta->remove_method('bar');
673   
674   # or use this to actually create classes ...
675   
676   Class::MOP::Class->create('Bar' => '0.01' => (
677       superclasses => [ 'Foo' ],
678       attributes => [
679           Class::MOP:::Attribute->new('$bar'),
680           Class::MOP:::Attribute->new('$baz'),          
681       ],
682       methods => {
683           calculate_bar => sub { ... },
684           construct_baz => sub { ... }          
685       }
686   ));
687
688 =head1 DESCRIPTION
689
690 This is the largest and currently most complex part of the Perl 5 
691 meta-object protocol. It controls the introspection and 
692 manipulation of Perl 5 classes (and it can create them too). The 
693 best way to understand what this module can do, is to read the 
694 documentation for each of it's methods.
695
696 =head1 METHODS
697
698 =head2 Self Introspection
699
700 =over 4
701
702 =item B<meta>
703
704 This will return a B<Class::MOP::Class> instance which is related 
705 to this class. Thereby allowing B<Class::MOP::Class> to actually 
706 introspect itself.
707
708 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually 
709 bootstrap this module by installing a number of attribute meta-objects 
710 into it's metaclass. This will allow this class to reap all the benifits 
711 of the MOP when subclassing it. 
712
713 =item B<get_all_metaclasses>
714
715 This will return an hash of all the metaclass instances that have 
716 been cached by B<Class::MOP::Class> keyed by the package name. 
717
718 =item B<get_all_metaclass_instances>
719
720 This will return an array of all the metaclass instances that have 
721 been cached by B<Class::MOP::Class>.
722
723 =item B<get_all_metaclass_names>
724
725 This will return an array of all the metaclass names that have 
726 been cached by B<Class::MOP::Class>.
727
728 =back
729
730 =head2 Class construction
731
732 These methods will handle creating B<Class::MOP::Class> objects, 
733 which can be used to both create new classes, and analyze 
734 pre-existing classes. 
735
736 This module will internally store references to all the instances 
737 you create with these methods, so that they do not need to be 
738 created any more than nessecary. Basically, they are singletons.
739
740 =over 4
741
742 =item B<create ($package_name, ?$package_version,
743                 superclasses =E<gt> ?@superclasses, 
744                 methods      =E<gt> ?%methods, 
745                 attributes   =E<gt> ?%attributes)>
746
747 This returns a B<Class::MOP::Class> object, bringing the specified 
748 C<$package_name> into existence and adding any of the 
749 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes> 
750 to it.
751
752 =item B<create_anon_class (superclasses =E<gt> ?@superclasses, 
753                            methods      =E<gt> ?%methods, 
754                            attributes   =E<gt> ?%attributes)>
755
756 This will create an anonymous class, it works much like C<create> but 
757 it does not need a C<$package_name>. Instead it will create a suitably 
758 unique package name for you to stash things into.
759
760 =item B<initialize ($package_name)>
761
762 This initializes and returns returns a B<Class::MOP::Class> object 
763 for a given a C<$package_name>.
764
765 =item B<construct_class_instance (%options)>
766
767 This will construct an instance of B<Class::MOP::Class>, it is 
768 here so that we can actually "tie the knot" for B<Class::MOP::Class> 
769 to use C<construct_instance> once all the bootstrapping is done. This 
770 method is used internally by C<initialize> and should never be called
771 from outside of that method really.
772
773 =item B<check_metaclass_compatability>
774
775 This method is called as the very last thing in the 
776 C<construct_class_instance> method. This will check that the 
777 metaclass you are creating is compatible with the metaclasses of all 
778 your ancestors. For more inforamtion about metaclass compatibility 
779 see the C<About Metaclass compatibility> section in L<Class::MOP>.
780
781 =back
782
783 =head2 Object instance construction and cloning
784
785 These methods are B<entirely optional>, it is up to you whether you want 
786 to use them or not.
787
788 =over 4
789
790 =item B<instance_metaclass>
791
792 =item B<get_meta_instance>
793
794 =item B<new_object (%params)>
795
796 This is a convience method for creating a new object of the class, and 
797 blessing it into the appropriate package as well. Ideally your class 
798 would call a C<new> this method like so:
799
800   sub MyClass::new { 
801       my ($class, %param) = @_;
802       $class->meta->new_object(%params);
803   }
804
805 Of course the ideal place for this would actually be in C<UNIVERSAL::> 
806 but that is considered bad style, so we do not do that.
807
808 =item B<construct_instance (%params)>
809
810 This method is used to construct an instace structure suitable for 
811 C<bless>-ing into your package of choice. It works in conjunction 
812 with the Attribute protocol to collect all applicable attributes.
813
814 This will construct and instance using a HASH ref as storage 
815 (currently only HASH references are supported). This will collect all 
816 the applicable attributes and layout out the fields in the HASH ref, 
817 it will then initialize them using either use the corresponding key 
818 in C<%params> or any default value or initializer found in the 
819 attribute meta-object.
820
821 =item B<clone_object ($instance, %params)>
822
823 This is a convience method for cloning an object instance, then  
824 blessing it into the appropriate package. This method will call 
825 C<clone_instance>, which performs a shallow copy of the object, 
826 see that methods documentation for more details. Ideally your 
827 class would call a C<clone> this method like so:
828
829   sub MyClass::clone {
830       my ($self, %param) = @_;
831       $self->meta->clone_object($self, %params);
832   }
833
834 Of course the ideal place for this would actually be in C<UNIVERSAL::> 
835 but that is considered bad style, so we do not do that.
836
837 =item B<clone_instance($instance, %params)>
838
839 This method is a compliment of C<construct_instance> (which means if 
840 you override C<construct_instance>, you need to override this one too), 
841 and clones the instance shallowly.
842
843 The cloned structure returned is (like with C<construct_instance>) an 
844 unC<bless>ed HASH reference, it is your responsibility to then bless 
845 this cloned structure into the right class (which C<clone_object> will
846 do for you).
847
848 As of 0.11, this method will clone the C<$instance> structure shallowly, 
849 as opposed to the deep cloning implemented in prior versions. After much 
850 thought, research and discussion, I have decided that anything but basic 
851 shallow cloning is outside the scope of the meta-object protocol. I 
852 think Yuval "nothingmuch" Kogman put it best when he said that cloning 
853 is too I<context-specific> to be part of the MOP.
854
855 =back
856
857 =head2 Informational 
858
859 =over 4
860
861 =item B<name>
862
863 This is a read-only attribute which returns the package name for the 
864 given B<Class::MOP::Class> instance.
865
866 =item B<version>
867
868 This is a read-only attribute which returns the C<$VERSION> of the 
869 package for the given B<Class::MOP::Class> instance.
870
871 =back
872
873 =head2 Inheritance Relationships
874
875 =over 4
876
877 =item B<superclasses (?@superclasses)>
878
879 This is a read-write attribute which represents the superclass 
880 relationships of the class the B<Class::MOP::Class> instance is
881 associated with. Basically, it can get and set the C<@ISA> for you.
882
883 B<NOTE:>
884 Perl will occasionally perform some C<@ISA> and method caching, if 
885 you decide to change your superclass relationship at runtime (which 
886 is quite insane and very much not recommened), then you should be 
887 aware of this and the fact that this module does not make any 
888 attempt to address this issue.
889
890 =item B<class_precedence_list>
891
892 This computes the a list of all the class's ancestors in the same order 
893 in which method dispatch will be done. This is similair to 
894 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
895
896 =back
897
898 =head2 Methods
899
900 =over 4
901
902 =item B<method_metaclass>
903
904 =item B<add_method ($method_name, $method)>
905
906 This will take a C<$method_name> and CODE reference to that 
907 C<$method> and install it into the class's package. 
908
909 B<NOTE>: 
910 This does absolutely nothing special to C<$method> 
911 other than use B<Sub::Name> to make sure it is tagged with the 
912 correct name, and therefore show up correctly in stack traces and 
913 such.
914
915 =item B<alias_method ($method_name, $method)>
916
917 This will take a C<$method_name> and CODE reference to that 
918 C<$method> and alias the method into the class's package. 
919
920 B<NOTE>: 
921 Unlike C<add_method>, this will B<not> try to name the 
922 C<$method> using B<Sub::Name>, it only aliases the method in 
923 the class's package. 
924
925 =item B<has_method ($method_name)>
926
927 This just provides a simple way to check if the class implements 
928 a specific C<$method_name>. It will I<not> however, attempt to check 
929 if the class inherits the method (use C<UNIVERSAL::can> for that).
930
931 This will correctly handle functions defined outside of the package 
932 that use a fully qualified name (C<sub Package::name { ... }>).
933
934 This will correctly handle functions renamed with B<Sub::Name> and 
935 installed using the symbol tables. However, if you are naming the 
936 subroutine outside of the package scope, you must use the fully 
937 qualified name, including the package name, for C<has_method> to 
938 correctly identify it. 
939
940 This will attempt to correctly ignore functions imported from other 
941 packages using B<Exporter>. It breaks down if the function imported 
942 is an C<__ANON__> sub (such as with C<use constant>), which very well 
943 may be a valid method being applied to the class. 
944
945 In short, this method cannot always be trusted to determine if the 
946 C<$method_name> is actually a method. However, it will DWIM about 
947 90% of the time, so it's a small trade off I think.
948
949 =item B<get_method ($method_name)>
950
951 This will return a CODE reference of the specified C<$method_name>, 
952 or return undef if that method does not exist.
953
954 =item B<remove_method ($method_name)>
955
956 This will attempt to remove a given C<$method_name> from the class. 
957 It will return the CODE reference that it has removed, and will 
958 attempt to use B<Sub::Name> to clear the methods associated name.
959
960 =item B<get_method_list>
961
962 This will return a list of method names for all I<locally> defined 
963 methods. It does B<not> provide a list of all applicable methods, 
964 including any inherited ones. If you want a list of all applicable 
965 methods, use the C<compute_all_applicable_methods> method.
966
967 =item B<compute_all_applicable_methods>
968
969 This will return a list of all the methods names this class will 
970 respond to, taking into account inheritance. The list will be a list of 
971 HASH references, each one containing the following information; method 
972 name, the name of the class in which the method lives and a CODE 
973 reference for the actual method.
974
975 =item B<find_all_methods_by_name ($method_name)>
976
977 This will traverse the inheritence hierarchy and locate all methods 
978 with a given C<$method_name>. Similar to 
979 C<compute_all_applicable_methods> it returns a list of HASH references 
980 with the following information; method name (which will always be the 
981 same as C<$method_name>), the name of the class in which the method 
982 lives and a CODE reference for the actual method.
983
984 The list of methods produced is a distinct list, meaning there are no 
985 duplicates in it. This is especially useful for things like object 
986 initialization and destruction where you only want the method called 
987 once, and in the correct order.
988
989 =item B<find_next_method_by_name ($method_name)>
990
991 This will return the first method to match a given C<$method_name> in 
992 the superclasses, this is basically equivalent to calling 
993 C<SUPER::$method_name>, but it can be dispatched at runtime.
994
995 =back
996
997 =head2 Method Modifiers
998
999 Method modifiers are a concept borrowed from CLOS, in which a method 
1000 can be wrapped with I<before>, I<after> and I<around> method modifiers 
1001 that will be called everytime the method is called. 
1002
1003 =head3 How method modifiers work?
1004
1005 Method modifiers work by wrapping the original method and then replacing 
1006 it in the classes symbol table. The wrappers will handle calling all the 
1007 modifiers in the appropariate orders and preserving the calling context 
1008 for the original method. 
1009
1010 Each method modifier serves a particular purpose, which may not be 
1011 obvious to users of other method wrapping modules. To start with, the 
1012 return values of I<before> and I<after> modifiers are ignored. This is 
1013 because thier purpose is B<not> to filter the input and output of the 
1014 primary method (this is done with an I<around> modifier). This may seem 
1015 like an odd restriction to some, but doing this allows for simple code 
1016 to be added at the begining or end of a method call without jeapordizing 
1017 the normal functioning of the primary method or placing any extra 
1018 responsibility on the code of the modifier. Of course if you have more 
1019 complex needs, then use the I<around> modifier, which uses a variation 
1020 of continutation passing style to allow for a high degree of flexibility. 
1021
1022 Before and around modifiers are called in last-defined-first-called order, 
1023 while after modifiers are called in first-defined-first-called order. So 
1024 the call tree might looks something like this:
1025   
1026   before 2
1027    before 1
1028     around 2
1029      around 1
1030       primary
1031      after 1
1032     after 2
1033
1034 To see examples of using method modifiers, see the following examples 
1035 included in the distribution; F<InstanceCountingClass>, F<Perl6Attribute>, 
1036 F<AttributesWithHistory> and F<C3MethodDispatchOrder>. There is also a 
1037 classic CLOS usage example in the test F<017_add_method_modifier.t>.
1038
1039 =head3 What is the performance impact?
1040
1041 Of course there is a performance cost associated with method modifiers, 
1042 but we have made every effort to make that cost be directly proportional 
1043 to the amount of modifier features you utilize.
1044
1045 The wrapping method does it's best to B<only> do as much work as it 
1046 absolutely needs to. In order to do this we have moved some of the 
1047 performance costs to set-up time, where they are easier to amortize.
1048
1049 All this said, my benchmarks have indicated the following:
1050
1051   simple wrapper with no modifiers             100% slower
1052   simple wrapper with simple before modifier   400% slower
1053   simple wrapper with simple after modifier    450% slower
1054   simple wrapper with simple around modifier   500-550% slower
1055   simple wrapper with all 3 modifiers          1100% slower
1056
1057 These numbers may seem daunting, but you must remember, every feature 
1058 comes with some cost. To put things in perspective, just doing a simple 
1059 C<AUTOLOAD> which does nothing but extract the name of the method called
1060 and return it costs about 400% over a normal method call. 
1061
1062 =over 4
1063
1064 =item B<add_before_method_modifier ($method_name, $code)>
1065
1066 This will wrap the method at C<$method_name> and the supplied C<$code> 
1067 will be passed the C<@_> arguments, and called before the original 
1068 method is called. As specified above, the return value of the I<before> 
1069 method modifiers is ignored, and it's ability to modify C<@_> is 
1070 fairly limited. If you need to do either of these things, use an 
1071 C<around> method modifier.
1072
1073 =item B<add_after_method_modifier ($method_name, $code)>
1074
1075 This will wrap the method at C<$method_name> so that the original 
1076 method will be called, it's return values stashed, and then the 
1077 supplied C<$code> will be passed the C<@_> arguments, and called.
1078 As specified above, the return value of the I<after> method 
1079 modifiers is ignored, and it cannot modify the return values of 
1080 the original method. If you need to do either of these things, use an 
1081 C<around> method modifier.
1082
1083 =item B<add_around_method_modifier ($method_name, $code)>
1084
1085 This will wrap the method at C<$method_name> so that C<$code> 
1086 will be called and passed the original method as an extra argument 
1087 at the begining of the C<@_> argument list. This is a variation of 
1088 continuation passing style, where the function prepended to C<@_> 
1089 can be considered a continuation. It is up to C<$code> if it calls 
1090 the original method or not, there is no restriction on what the 
1091 C<$code> can or cannot do.
1092
1093 =back
1094
1095 =head2 Attributes
1096
1097 It should be noted that since there is no one consistent way to define 
1098 the attributes of a class in Perl 5. These methods can only work with 
1099 the information given, and can not easily discover information on 
1100 their own. See L<Class::MOP::Attribute> for more details.
1101
1102 =over 4
1103
1104 =item B<attribute_metaclass>
1105
1106 =item B<get_attribute_map>
1107
1108 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
1109
1110 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class> 
1111 instance associated with the given class, and associates it with 
1112 the C<$attribute_name>. Unlike methods, attributes within the MOP 
1113 are stored as meta-information only. They will be used later to 
1114 construct instances from (see C<construct_instance> above).
1115 More details about the attribute meta-objects can be found in the 
1116 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
1117 section.
1118
1119 It should be noted that any accessor, reader/writer or predicate 
1120 methods which the C<$attribute_meta_object> has will be installed 
1121 into the class at this time.
1122
1123 =item B<has_attribute ($attribute_name)>
1124
1125 Checks to see if this class has an attribute by the name of 
1126 C<$attribute_name> and returns a boolean.
1127
1128 =item B<get_attribute ($attribute_name)>
1129
1130 Returns the attribute meta-object associated with C<$attribute_name>, 
1131 if none is found, it will return undef. 
1132
1133 =item B<remove_attribute ($attribute_name)>
1134
1135 This will remove the attribute meta-object stored at 
1136 C<$attribute_name>, then return the removed attribute meta-object. 
1137
1138 B<NOTE:> 
1139 Removing an attribute will only affect future instances of 
1140 the class, it will not make any attempt to remove the attribute from 
1141 any existing instances of the class.
1142
1143 It should be noted that any accessor, reader/writer or predicate 
1144 methods which the attribute meta-object stored at C<$attribute_name> 
1145 has will be removed from the class at this time. This B<will> make 
1146 these attributes somewhat inaccessable in previously created 
1147 instances. But if you are crazy enough to do this at runtime, then 
1148 you are crazy enough to deal with something like this :).
1149
1150 =item B<get_attribute_list>
1151
1152 This returns a list of attribute names which are defined in the local 
1153 class. If you want a list of all applicable attributes for a class, 
1154 use the C<compute_all_applicable_attributes> method.
1155
1156 =item B<compute_all_applicable_attributes>
1157
1158 This will traverse the inheritance heirachy and return a list of all 
1159 the applicable attributes for this class. It does not construct a 
1160 HASH reference like C<compute_all_applicable_methods> because all 
1161 that same information is discoverable through the attribute 
1162 meta-object itself.
1163
1164 =item B<find_attribute_by_name ($attr_name)>
1165
1166 This method will traverse the inheritance heirachy and find the 
1167 first attribute whose name matches C<$attr_name>, then return it. 
1168 It will return undef if nothing is found.
1169
1170 =back
1171
1172 =head2 Package Variables
1173
1174 Since Perl's classes are built atop the Perl package system, it is 
1175 fairly common to use package scoped variables for things like static 
1176 class variables. The following methods are convience methods for 
1177 the creation and inspection of package scoped variables.
1178
1179 =over 4
1180
1181 =item B<add_package_variable ($variable_name, ?$initial_value)>
1182
1183 Given a C<$variable_name>, which must contain a leading sigil, this 
1184 method will create that variable within the package which houses the 
1185 class. It also takes an optional C<$initial_value>, which must be a 
1186 reference of the same type as the sigil of the C<$variable_name> 
1187 implies.
1188
1189 =item B<get_package_variable ($variable_name)>
1190
1191 This will return a reference to the package variable in 
1192 C<$variable_name>. 
1193
1194 =item B<has_package_variable ($variable_name)>
1195
1196 Returns true (C<1>) if there is a package variable defined for 
1197 C<$variable_name>, and false (C<0>) otherwise.
1198
1199 =item B<remove_package_variable ($variable_name)>
1200
1201 This will attempt to remove the package variable at C<$variable_name>.
1202
1203 =back
1204
1205 =head1 AUTHOR
1206
1207 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1208
1209 =head1 COPYRIGHT AND LICENSE
1210
1211 Copyright 2006 by Infinity Interactive, Inc.
1212
1213 L<http://www.iinteractive.com>
1214
1215 This library is free software; you can redistribute it and/or modify
1216 it under the same terms as Perl itself. 
1217
1218 =cutchistian