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