Merge branch 'master' of gitmo@git.moose.perl.org:Class-MOP
[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 Class::MOP::Instance;
8 use Class::MOP::Method::Wrapped;
9 use Class::MOP::Method::Accessor;
10 use Class::MOP::Method::Constructor;
11
12 use Carp         'confess';
13 use Scalar::Util 'blessed', 'weaken';
14 use Sub::Name 'subname';
15 use Devel::GlobalDestruction 'in_global_destruction';
16
17 our $VERSION   = '0.89';
18 $VERSION = eval $VERSION;
19 our $AUTHORITY = 'cpan:STEVAN';
20
21 use base 'Class::MOP::Module';
22
23 # Creation
24
25 sub initialize {
26     my $class = shift;
27
28     my $package_name;
29     
30     if ( @_ % 2 ) {
31         $package_name = shift;
32     } else {
33         my %options = @_;
34         $package_name = $options{package};
35     }
36
37     (defined $package_name && $package_name && !ref($package_name))
38         || confess "You must pass a package name and it cannot be blessed";
39
40     return Class::MOP::get_metaclass_by_name($package_name)
41         || $class->_construct_class_instance(package => $package_name, @_);
42 }
43
44 sub construct_class_instance {
45     Carp::cluck('The construct_class_instance method has been made private.'
46         . " The public version is deprecated and will be removed in a future release.\n");
47     shift->_construct_class_instance(@_);
48 }
49
50 # NOTE: (meta-circularity)
51 # this is a special form of _construct_instance
52 # (see below), which is used to construct class
53 # meta-object instances for any Class::MOP::*
54 # class. All other classes will use the more
55 # normal &construct_instance.
56 sub _construct_class_instance {
57     my $class        = shift;
58     my $options      = @_ == 1 ? $_[0] : {@_};
59     my $package_name = $options->{package};
60     (defined $package_name && $package_name)
61         || confess "You must pass a package name";
62     # NOTE:
63     # return the metaclass if we have it cached,
64     # and it is still defined (it has not been
65     # reaped by DESTROY yet, which can happen
66     # annoyingly enough during global destruction)
67
68     if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
69         return $meta;
70     }
71
72     # NOTE:
73     # we need to deal with the possibility
74     # of class immutability here, and then
75     # get the name of the class appropriately
76     $class = (ref($class)
77                     ? ($class->is_immutable
78                         ? $class->get_mutable_metaclass_name()
79                         : ref($class))
80                     : $class);
81
82     # now create the metaclass
83     my $meta;
84     if ($class eq 'Class::MOP::Class') {
85         $meta = $class->_new($options);
86     }
87     else {
88         # NOTE:
89         # it is safe to use meta here because
90         # class will always be a subclass of
91         # Class::MOP::Class, which defines meta
92         $meta = $class->meta->_construct_instance($options)
93     }
94
95     # and check the metaclass compatibility
96     $meta->_check_metaclass_compatibility();  
97
98     Class::MOP::store_metaclass_by_name($package_name, $meta);
99
100     # NOTE:
101     # we need to weaken any anon classes
102     # so that they can call DESTROY properly
103     Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class;
104
105     $meta;
106 }
107
108 sub _new {
109     my $class = shift;
110     my $options = @_ == 1 ? $_[0] : {@_};
111
112     bless {
113         # inherited from Class::MOP::Package
114         'package' => $options->{package},
115
116         # NOTE:
117         # since the following attributes will
118         # actually be loaded from the symbol
119         # table, and actually bypass the instance
120         # entirely, we can just leave these things
121         # listed here for reference, because they
122         # should not actually have a value associated
123         # with the slot.
124         'namespace' => \undef,
125
126         # inherited from Class::MOP::Module
127         'version'   => \undef,
128         'authority' => \undef,
129
130         # defined in Class::MOP::Class
131         'superclasses' => \undef,
132
133         'methods'    => {},
134         'attributes' => {},
135         'attribute_metaclass' =>
136             ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
137         'method_metaclass' =>
138             ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
139         'wrapped_method_metaclass' => (
140             $options->{'wrapped_method_metaclass'}
141                 || 'Class::MOP::Method::Wrapped'
142         ),
143         'instance_metaclass' =>
144             ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
145         'immutable_trait' => (
146             $options->{'immutable_trait'}
147                 || 'Class::MOP::Class::Immutable::Trait'
148         ),
149         'constructor_name' => ( $options->{constructor_name} || 'new' ),
150         'constructor_class' => (
151             $options->{constructor_class} || 'Class::MOP::Method::Constructor'
152         ),
153         'destructor_class' => $options->{destructor_class},
154     }, $class;
155 }
156
157 sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef } 
158 sub update_package_cache_flag {
159     my $self = shift;
160     # NOTE:
161     # we can manually update the cache number 
162     # since we are actually adding the method
163     # to our cache as well. This avoids us 
164     # having to regenerate the method_map.
165     # - SL    
166     $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);    
167 }
168
169
170 sub check_metaclass_compatibility {
171     Carp::cluck('The check_metaclass_compatibility method has been made private.'
172         . " The public version is deprecated and will be removed in a future release.\n");
173     shift->_check_metaclass_compatibility(@_);
174 }
175
176 sub _check_metaclass_compatibility {
177     my $self = shift;
178
179     # this is always okay ...
180     return if ref($self)                eq 'Class::MOP::Class'   &&
181               $self->instance_metaclass eq 'Class::MOP::Instance';
182
183     my @class_list = $self->linearized_isa;
184     shift @class_list; # shift off $self->name
185
186     foreach my $superclass_name (@class_list) {
187         my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next;
188
189         # NOTE:
190         # we need to deal with the possibility
191         # of class immutability here, and then
192         # get the name of the class appropriately
193         my $super_meta_type
194             = $super_meta->is_immutable
195             ? $super_meta->get_mutable_metaclass_name()
196             : ref($super_meta);
197
198         ($self->isa($super_meta_type))
199             || confess "The metaclass of " . $self->name . " ("
200                        . (ref($self)) . ")" .  " is not compatible with the " .
201                        "metaclass of its superclass, ".$superclass_name . " ("
202                        . ($super_meta_type) . ")";
203         # NOTE:
204         # we also need to check that instance metaclasses
205         # are compatibile in the same the class.
206         ($self->instance_metaclass->isa($super_meta->instance_metaclass))
207             || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" .
208                        " is not compatible with the " .
209                        "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")";
210     }
211 }
212
213 ## ANON classes
214
215 {
216     # NOTE:
217     # this should be sufficient, if you have a
218     # use case where it is not, write a test and
219     # I will change it.
220     my $ANON_CLASS_SERIAL = 0;
221
222     # NOTE:
223     # we need a sufficiently annoying prefix
224     # this should suffice for now, this is
225     # used in a couple of places below, so
226     # need to put it up here for now.
227     my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
228
229     sub is_anon_class {
230         my $self = shift;
231         no warnings 'uninitialized';
232         $self->name =~ /^$ANON_CLASS_PREFIX/;
233     }
234
235     sub create_anon_class {
236         my ($class, %options) = @_;
237         my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
238         return $class->create($package_name, %options);
239     }
240
241     # NOTE:
242     # this will only get called for
243     # anon-classes, all other calls
244     # are assumed to occur during
245     # global destruction and so don't
246     # really need to be handled explicitly
247     sub DESTROY {
248         my $self = shift;
249
250         return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
251
252         no warnings 'uninitialized';
253         my $name = $self->name;
254         return unless $name =~ /^$ANON_CLASS_PREFIX/;
255         # Moose does a weird thing where it replaces the metaclass for
256         # class when fixing metaclass incompatibility. In that case,
257         # we don't want to clean out the namespace now. We can detect
258         # that because Moose will explicitly update the singleton
259         # cache in Class::MOP.
260         my $current_meta = Class::MOP::get_metaclass_by_name($name);
261         return if $current_meta ne $self;
262
263         my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/);
264         no strict 'refs';
265         @{$name . '::ISA'} = ();
266         %{$name . '::'}    = ();
267         delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
268
269         Class::MOP::remove_metaclass_by_name($name);
270     }
271
272 }
273
274 # creating classes with MOP ...
275
276 sub create {
277     my ( $class, @args ) = @_;
278
279     unshift @args, 'package' if @args % 2 == 1;
280
281     my (%options) = @args;
282     my $package_name = $options{package};
283
284     (ref $options{superclasses} eq 'ARRAY')
285         || confess "You must pass an ARRAY ref of superclasses"
286             if exists $options{superclasses};
287             
288     (ref $options{attributes} eq 'ARRAY')
289         || confess "You must pass an ARRAY ref of attributes"
290             if exists $options{attributes};      
291             
292     (ref $options{methods} eq 'HASH')
293         || confess "You must pass a HASH ref of methods"
294             if exists $options{methods};                  
295
296     my (%initialize_options) = @args;
297     delete @initialize_options{qw(
298         package
299         superclasses
300         attributes
301         methods
302         version
303         authority
304     )};
305     my $meta = $class->initialize( $package_name => %initialize_options );
306
307     $meta->_instantiate_module( $options{version}, $options{authority} );
308
309     # FIXME totally lame
310     $meta->add_method('meta' => sub {
311         $class->initialize(ref($_[0]) || $_[0]);
312     });
313
314     $meta->superclasses(@{$options{superclasses}})
315         if exists $options{superclasses};
316     # NOTE:
317     # process attributes first, so that they can
318     # install accessors, but locally defined methods
319     # can then overwrite them. It is maybe a little odd, but
320     # I think this should be the order of things.
321     if (exists $options{attributes}) {
322         foreach my $attr (@{$options{attributes}}) {
323             $meta->add_attribute($attr);
324         }
325     }
326     if (exists $options{methods}) {
327         foreach my $method_name (keys %{$options{methods}}) {
328             $meta->add_method($method_name, $options{methods}->{$method_name});
329         }
330     }
331     return $meta;
332 }
333
334 ## Attribute readers
335
336 # NOTE:
337 # all these attribute readers will be bootstrapped
338 # away in the Class::MOP bootstrap section
339
340 sub get_attribute_map        { $_[0]->{'attributes'}                  }
341 sub attribute_metaclass      { $_[0]->{'attribute_metaclass'}         }
342 sub method_metaclass         { $_[0]->{'method_metaclass'}            }
343 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'}    }
344 sub instance_metaclass       { $_[0]->{'instance_metaclass'}          }
345 sub immutable_trait          { $_[0]->{'immutable_trait'}             }
346 sub constructor_class        { $_[0]->{'constructor_class'}           }
347 sub constructor_name         { $_[0]->{'constructor_name'}            }
348 sub destructor_class         { $_[0]->{'destructor_class'}            }
349
350 # Instance Construction & Cloning
351
352 sub new_object {
353     my $class = shift;
354
355     # NOTE:
356     # we need to protect the integrity of the
357     # Class::MOP::Class singletons here, so we
358     # delegate this to &construct_class_instance
359     # which will deal with the singletons
360     return $class->_construct_class_instance(@_)
361         if $class->name->isa('Class::MOP::Class');
362     return $class->_construct_instance(@_);
363 }
364
365 sub construct_instance {
366     Carp::cluck('The construct_instance method has been made private.'
367         . " The public version is deprecated and will be removed in a future release.\n");
368     shift->_construct_instance(@_);
369 }
370
371 sub _construct_instance {
372     my $class = shift;
373     my $params = @_ == 1 ? $_[0] : {@_};
374     my $meta_instance = $class->get_meta_instance();
375     # FIXME:
376     # the code below is almost certainly incorrect
377     # but this is foreign inheritance, so we might
378     # have to kludge it in the end.
379     my $instance = $params->{__INSTANCE__} || $meta_instance->create_instance();
380     foreach my $attr ($class->get_all_attributes()) {
381         $attr->initialize_instance_slot($meta_instance, $instance, $params);
382     }
383     # NOTE:
384     # this will only work for a HASH instance type
385     if ($class->is_anon_class) {
386         (Scalar::Util::reftype($instance) eq 'HASH')
387             || confess "Currently only HASH based instances are supported with instance of anon-classes";
388         # NOTE:
389         # At some point we should make this official
390         # as a reserved slot name, but right now I am
391         # going to keep it here.
392         # my $RESERVED_MOP_SLOT = '__MOP__';
393         $instance->{'__MOP__'} = $class;
394     }
395     return $instance;
396 }
397
398
399 sub get_meta_instance {
400     my $self = shift;
401     $self->{'_meta_instance'} ||= $self->_create_meta_instance();
402 }
403
404 sub create_meta_instance {
405     Carp::cluck('The create_meta_instance method has been made private.'
406         . " The public version is deprecated and will be removed in a future release.\n");
407     shift->_create_meta_instance(@_);
408 }
409
410 sub _create_meta_instance {
411     my $self = shift;
412     
413     my $instance = $self->instance_metaclass->new(
414         associated_metaclass => $self,
415         attributes => [ $self->get_all_attributes() ],
416     );
417
418     $self->add_meta_instance_dependencies()
419         if $instance->is_dependent_on_superclasses();
420
421     return $instance;
422 }
423
424 sub clone_object {
425     my $class    = shift;
426     my $instance = shift;
427     (blessed($instance) && $instance->isa($class->name))
428         || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
429
430     # NOTE:
431     # we need to protect the integrity of the
432     # Class::MOP::Class singletons here, they
433     # should not be cloned.
434     return $instance if $instance->isa('Class::MOP::Class');
435     $class->_clone_instance($instance, @_);
436 }
437
438 sub clone_instance {
439     Carp::cluck('The clone_instance method has been made private.'
440         . " The public version is deprecated and will be removed in a future release.\n");
441     shift->_clone_instance(@_);
442 }
443
444 sub _clone_instance {
445     my ($class, $instance, %params) = @_;
446     (blessed($instance))
447         || confess "You can only clone instances, ($instance) is not a blessed instance";
448     my $meta_instance = $class->get_meta_instance();
449     my $clone = $meta_instance->clone_instance($instance);
450     foreach my $attr ($class->get_all_attributes()) {
451         if ( defined( my $init_arg = $attr->init_arg ) ) {
452             if (exists $params{$init_arg}) {
453                 $attr->set_value($clone, $params{$init_arg});
454             }
455         }
456     }
457     return $clone;
458 }
459
460 sub rebless_instance {
461     my ($self, $instance, %params) = @_;
462
463     my $old_metaclass = Class::MOP::class_of($instance);
464
465     my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
466     $self->name->isa($old_class)
467         || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
468
469     $old_metaclass->rebless_instance_away($instance, $self, %params)
470         if $old_metaclass;
471
472     my $meta_instance = $self->get_meta_instance();
473
474     # rebless!
475     # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
476     $meta_instance->rebless_instance_structure($_[1], $self);
477
478     foreach my $attr ( $self->get_all_attributes ) {
479         if ( $attr->has_value($instance) ) {
480             if ( defined( my $init_arg = $attr->init_arg ) ) {
481                 $params{$init_arg} = $attr->get_value($instance)
482                     unless exists $params{$init_arg};
483             } 
484             else {
485                 $attr->set_value($instance, $attr->get_value($instance));
486             }
487         }
488     }
489
490     foreach my $attr ($self->get_all_attributes) {
491         $attr->initialize_instance_slot($meta_instance, $instance, \%params);
492     }
493     
494     $instance;
495 }
496
497 sub rebless_instance_away {
498     # this intentionally does nothing, it is just a hook
499 }
500
501 # Inheritance
502
503 sub superclasses {
504     my $self     = shift;
505     my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
506     if (@_) {
507         my @supers = @_;
508         @{$self->get_package_symbol($var_spec)} = @supers;
509
510         # NOTE:
511         # on 5.8 and below, we need to call
512         # a method to get Perl to detect
513         # a cycle in the class hierarchy
514         my $class = $self->name;
515         $class->isa($class);
516
517         # NOTE:
518         # we need to check the metaclass
519         # compatibility here so that we can
520         # be sure that the superclass is
521         # not potentially creating an issues
522         # we don't know about
523
524         $self->_check_metaclass_compatibility();
525         $self->_superclasses_updated();
526     }
527     @{$self->get_package_symbol($var_spec)};
528 }
529
530 sub _superclasses_updated {
531     my $self = shift;
532     $self->update_meta_instance_dependencies();
533 }
534
535 sub subclasses {
536     my $self = shift;
537     my $super_class = $self->name;
538
539     return @{ $super_class->mro::get_isarev() };
540 }
541
542 sub direct_subclasses {
543     my $self = shift;
544     my $super_class = $self->name;
545
546     return grep {
547         grep {
548             $_ eq $super_class
549         } Class::MOP::Class->initialize($_)->superclasses
550     } $self->subclasses;
551 }
552
553 sub linearized_isa {
554     return @{ mro::get_linear_isa( (shift)->name ) };
555 }
556
557 sub class_precedence_list {
558     my $self = shift;
559     my $name = $self->name;
560
561     unless (Class::MOP::IS_RUNNING_ON_5_10()) { 
562         # NOTE:
563         # We need to check for circular inheritance here
564         # if we are are not on 5.10, cause 5.8 detects it 
565         # late. This will do nothing if all is well, and 
566         # blow up otherwise. Yes, it's an ugly hack, better
567         # suggestions are welcome.        
568         # - SL
569         ($name || return)->isa('This is a test for circular inheritance') 
570     }
571
572     # if our mro is c3, we can 
573     # just grab the linear_isa
574     if (mro::get_mro($name) eq 'c3') {
575         return @{ mro::get_linear_isa($name) }
576     }
577     else {
578         # NOTE:
579         # we can't grab the linear_isa for dfs
580         # since it has all the duplicates 
581         # already removed.
582         return (
583             $name,
584             map {
585                 $self->initialize($_)->class_precedence_list()
586             } $self->superclasses()
587         );
588     }
589 }
590
591 ## Methods
592
593 sub wrap_method_body {
594     my ( $self, %args ) = @_;
595
596     ('CODE' eq ref $args{body})
597         || confess "Your code block must be a CODE reference";
598
599     $self->method_metaclass->wrap(
600         package_name => $self->name,
601         %args,
602     );
603 }
604
605 sub add_method {
606     my ($self, $method_name, $method) = @_;
607     (defined $method_name && $method_name)
608         || confess "You must define a method name";
609
610     my $body;
611     if (blessed($method)) {
612         $body = $method->body;
613         if ($method->package_name ne $self->name) {
614             $method = $method->clone(
615                 package_name => $self->name,
616                 name         => $method_name            
617             ) if $method->can('clone');
618         }
619     }
620     else {
621         $body = $method;
622         $method = $self->wrap_method_body( body => $body, name => $method_name );
623     }
624
625     $method->attach_to_class($self);
626
627     $self->get_method_map->{$method_name} = $method;
628
629     my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
630
631     if ( !defined $current_name || $current_name eq '__ANON__' ) {
632         my $full_method_name = ($self->name . '::' . $method_name);
633         subname($full_method_name => $body);
634     }
635
636     $self->add_package_symbol(
637         { sigil => '&', type => 'CODE', name => $method_name },
638         $body,
639     );
640 }
641
642 {
643     my $fetch_and_prepare_method = sub {
644         my ($self, $method_name) = @_;
645         my $wrapped_metaclass = $self->wrapped_method_metaclass;
646         # fetch it locally
647         my $method = $self->get_method($method_name);
648         # if we dont have local ...
649         unless ($method) {
650             # try to find the next method
651             $method = $self->find_next_method_by_name($method_name);
652             # die if it does not exist
653             (defined $method)
654                 || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
655             # and now make sure to wrap it
656             # even if it is already wrapped
657             # because we need a new sub ref
658             $method = $wrapped_metaclass->wrap($method);
659         }
660         else {
661             # now make sure we wrap it properly
662             $method = $wrapped_metaclass->wrap($method)
663                 unless $method->isa($wrapped_metaclass);
664         }
665         $self->add_method($method_name => $method);
666         return $method;
667     };
668
669     sub add_before_method_modifier {
670         my ($self, $method_name, $method_modifier) = @_;
671         (defined $method_name && $method_name)
672             || confess "You must pass in a method name";
673         my $method = $fetch_and_prepare_method->($self, $method_name);
674         $method->add_before_modifier(
675             subname(':before' => $method_modifier)
676         );
677     }
678
679     sub add_after_method_modifier {
680         my ($self, $method_name, $method_modifier) = @_;
681         (defined $method_name && $method_name)
682             || confess "You must pass in a method name";
683         my $method = $fetch_and_prepare_method->($self, $method_name);
684         $method->add_after_modifier(
685             subname(':after' => $method_modifier)
686         );
687     }
688
689     sub add_around_method_modifier {
690         my ($self, $method_name, $method_modifier) = @_;
691         (defined $method_name && $method_name)
692             || confess "You must pass in a method name";
693         my $method = $fetch_and_prepare_method->($self, $method_name);
694         $method->add_around_modifier(
695             subname(':around' => $method_modifier)
696         );
697     }
698
699     # NOTE:
700     # the methods above used to be named like this:
701     #    ${pkg}::${method}:(before|after|around)
702     # but this proved problematic when using one modifier
703     # to wrap multiple methods (something which is likely
704     # to happen pretty regularly IMO). So instead of naming
705     # it like this, I have chosen to just name them purely
706     # with their modifier names, like so:
707     #    :(before|after|around)
708     # The fact is that in a stack trace, it will be fairly
709     # evident from the context what method they are attached
710     # to, and so don't need the fully qualified name.
711 }
712
713 sub alias_method {
714     Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
715
716     shift->add_method(@_);
717 }
718
719 sub has_method {
720     my ($self, $method_name) = @_;
721     (defined $method_name && $method_name)
722         || confess "You must define a method name";
723
724     exists $self->get_method_map->{$method_name};
725 }
726
727 sub get_method {
728     my ($self, $method_name) = @_;
729     (defined $method_name && $method_name)
730         || confess "You must define a method name";
731
732     return $self->get_method_map->{$method_name};
733 }
734
735 sub remove_method {
736     my ($self, $method_name) = @_;
737     (defined $method_name && $method_name)
738         || confess "You must define a method name";
739
740     my $removed_method = delete $self->get_method_map->{$method_name};
741     
742     $self->remove_package_symbol(
743         { sigil => '&', type => 'CODE', name => $method_name }
744     );
745
746     $removed_method->detach_from_class if $removed_method;
747
748     $self->update_package_cache_flag; # still valid, since we just removed the method from the map
749
750     return $removed_method;
751 }
752
753 sub get_method_list {
754     my $self = shift;
755     keys %{$self->get_method_map};
756 }
757
758 sub find_method_by_name {
759     my ($self, $method_name) = @_;
760     (defined $method_name && $method_name)
761         || confess "You must define a method name to find";
762     foreach my $class ($self->linearized_isa) {
763         # fetch the meta-class ...
764         my $meta = $self->initialize($class);
765         return $meta->get_method($method_name)
766             if $meta->has_method($method_name);
767     }
768     return;
769 }
770
771 sub get_all_methods {
772     my $self = shift;
773     my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa;
774     return values %methods;
775 }
776
777 sub compute_all_applicable_methods {
778     Carp::cluck('The compute_all_applicable_methods method is deprecated.'
779         . " Use get_all_methods instead.\n");
780
781     return map {
782         {
783             name  => $_->name,
784             class => $_->package_name,
785             code  => $_, # sigh, overloading
786         },
787     } shift->get_all_methods(@_);
788 }
789
790 sub get_all_method_names {
791     my $self = shift;
792     my %uniq;
793     grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods;
794 }
795
796 sub find_all_methods_by_name {
797     my ($self, $method_name) = @_;
798     (defined $method_name && $method_name)
799         || confess "You must define a method name to find";
800     my @methods;
801     foreach my $class ($self->linearized_isa) {
802         # fetch the meta-class ...
803         my $meta = $self->initialize($class);
804         push @methods => {
805             name  => $method_name,
806             class => $class,
807             code  => $meta->get_method($method_name)
808         } if $meta->has_method($method_name);
809     }
810     return @methods;
811 }
812
813 sub find_next_method_by_name {
814     my ($self, $method_name) = @_;
815     (defined $method_name && $method_name)
816         || confess "You must define a method name to find";
817     my @cpl = $self->linearized_isa;
818     shift @cpl; # discard ourselves
819     foreach my $class (@cpl) {
820         # fetch the meta-class ...
821         my $meta = $self->initialize($class);
822         return $meta->get_method($method_name)
823             if $meta->has_method($method_name);
824     }
825     return;
826 }
827
828 ## Attributes
829
830 sub add_attribute {
831     my $self      = shift;
832     # either we have an attribute object already
833     # or we need to create one from the args provided
834     my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
835     # make sure it is derived from the correct type though
836     ($attribute->isa('Class::MOP::Attribute'))
837         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
838
839     # first we attach our new attribute
840     # because it might need certain information
841     # about the class which it is attached to
842     $attribute->attach_to_class($self);
843
844     # then we remove attributes of a conflicting
845     # name here so that we can properly detach
846     # the old attr object, and remove any
847     # accessors it would have generated
848     if ( $self->has_attribute($attribute->name) ) {
849         $self->remove_attribute($attribute->name);
850     } else {
851         $self->invalidate_meta_instances();
852     }
853     
854     # get our count of previously inserted attributes and
855     # increment by one so this attribute knows its order
856     my $order = (scalar keys %{$self->get_attribute_map}) - 1; 
857     $attribute->_set_insertion_order($order + 1);
858
859     # then onto installing the new accessors
860     $self->get_attribute_map->{$attribute->name} = $attribute;
861
862     # invalidate package flag here
863     my $e = do {
864         local $@;
865         local $SIG{__DIE__};
866         eval { $attribute->install_accessors() };
867         $@;
868     };
869     if ( $e ) {
870         $self->remove_attribute($attribute->name);
871         die $e;
872     }
873
874     return $attribute;
875 }
876
877 sub update_meta_instance_dependencies {
878     my $self = shift;
879
880     if ( $self->{meta_instance_dependencies} ) {
881         return $self->add_meta_instance_dependencies;
882     }
883 }
884
885 sub add_meta_instance_dependencies {
886     my $self = shift;
887
888     $self->remove_meta_instance_dependencies;
889
890     my @attrs = $self->get_all_attributes();
891
892     my %seen;
893     my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
894
895     foreach my $class ( @classes ) { 
896         $class->add_dependent_meta_instance($self);
897     }
898
899     $self->{meta_instance_dependencies} = \@classes;
900 }
901
902 sub remove_meta_instance_dependencies {
903     my $self = shift;
904
905     if ( my $classes = delete $self->{meta_instance_dependencies} ) {
906         foreach my $class ( @$classes ) {
907             $class->remove_dependent_meta_instance($self);
908         }
909
910         return $classes;
911     }
912
913     return;
914
915 }
916
917 sub add_dependent_meta_instance {
918     my ( $self, $metaclass ) = @_;
919     push @{ $self->{dependent_meta_instances} }, $metaclass;
920 }
921
922 sub remove_dependent_meta_instance {
923     my ( $self, $metaclass ) = @_;
924     my $name = $metaclass->name;
925     @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances};
926 }
927
928 sub invalidate_meta_instances {
929     my $self = shift;
930     $_->invalidate_meta_instance() for $self, @{ $self->{dependent_meta_instances} };
931 }
932
933 sub invalidate_meta_instance {
934     my $self = shift;
935     undef $self->{_meta_instance};
936 }
937
938 sub has_attribute {
939     my ($self, $attribute_name) = @_;
940     (defined $attribute_name && $attribute_name)
941         || confess "You must define an attribute name";
942     exists $self->get_attribute_map->{$attribute_name};
943 }
944
945 sub get_attribute {
946     my ($self, $attribute_name) = @_;
947     (defined $attribute_name && $attribute_name)
948         || confess "You must define an attribute name";
949     return $self->get_attribute_map->{$attribute_name}
950     # NOTE:
951     # this will return undef anyway, so no need ...
952     #    if $self->has_attribute($attribute_name);
953     #return;
954 }
955
956 sub remove_attribute {
957     my ($self, $attribute_name) = @_;
958     (defined $attribute_name && $attribute_name)
959         || confess "You must define an attribute name";
960     my $removed_attribute = $self->get_attribute_map->{$attribute_name};
961     return unless defined $removed_attribute;
962     delete $self->get_attribute_map->{$attribute_name};
963     $self->invalidate_meta_instances();
964     $removed_attribute->remove_accessors();
965     $removed_attribute->detach_from_class();
966     return $removed_attribute;
967 }
968
969 sub get_attribute_list {
970     my $self = shift;
971     keys %{$self->get_attribute_map};
972 }
973
974 sub get_all_attributes {
975     my $self = shift;
976     my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa;
977     return values %attrs;
978 }
979
980 sub compute_all_applicable_attributes {
981     Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
982         . " Use get_all_attributes instead.\n");
983
984     shift->get_all_attributes(@_);
985 }
986
987 sub find_attribute_by_name {
988     my ($self, $attr_name) = @_;
989     foreach my $class ($self->linearized_isa) {
990         # fetch the meta-class ...
991         my $meta = $self->initialize($class);
992         return $meta->get_attribute($attr_name)
993             if $meta->has_attribute($attr_name);
994     }
995     return;
996 }
997
998 # check if we can reinitialize
999 sub is_pristine {
1000     my $self = shift;
1001
1002     # if any local attr is defined
1003     return if $self->get_attribute_list;
1004
1005     # or any non-declared methods
1006     if ( my @methods = values %{ $self->get_method_map } ) {
1007         my $metaclass = $self->method_metaclass;
1008         foreach my $method ( @methods ) {
1009             return if $method->isa("Class::MOP::Method::Generated");
1010             # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
1011         }
1012     }
1013
1014     return 1;
1015 }
1016
1017 ## Class closing
1018
1019 sub is_mutable   { 1 }
1020 sub is_immutable { 0 }
1021
1022 sub _immutable_options {
1023     my ( $self, @args ) = @_;
1024
1025     return (
1026         inline_accessors   => 1,
1027         inline_constructor => 1,
1028         inline_destructor  => 0,
1029         debug              => 0,
1030         immutable_trait    => $self->immutable_trait,
1031         constructor_name   => $self->constructor_name,
1032         constructor_class  => $self->constructor_class,
1033         destructor_class   => $self->destructor_class,
1034         @args,
1035     );
1036 }
1037
1038 sub make_immutable {
1039     my ( $self, @args ) = @_;
1040
1041     if ( $self->is_mutable ) {
1042         $self->_initialize_immutable( $self->_immutable_options(@args) );
1043         $self->_rebless_as_immutable(@args);
1044         return $self;
1045     }
1046     else {
1047         return;
1048     }
1049 }
1050
1051 sub make_mutable {
1052     my $self = shift;
1053
1054     if ( $self->is_immutable ) {
1055         my @args = $self->immutable_options;
1056         $self->_rebless_as_mutable();
1057         $self->_remove_inlined_code(@args);
1058         delete $self->{__immutable};
1059         return $self;
1060     }
1061     else {
1062         return;
1063     }
1064 }
1065
1066 sub _rebless_as_immutable {
1067     my ( $self, @args ) = @_;
1068
1069     $self->{__immutable}{original_class} = ref $self;
1070
1071     bless $self => $self->_immutable_metaclass(@args);
1072 }
1073
1074 sub _immutable_metaclass {
1075     my ( $self, %args ) = @_;
1076
1077     if ( my $class = $args{immutable_metaclass} ) {
1078         return $class;
1079     }
1080
1081     my $trait = $args{immutable_trait} = $self->immutable_trait
1082         || confess "no immutable trait specified for $self";
1083
1084     my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
1085
1086     my $class_name;
1087
1088     if ( $meta_attr and $trait eq $meta_attr->default ) {
1089         # if the trait is the same as the default we try and pick a
1090         # predictable name for the immutable metaclass
1091         $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1092     }
1093     else {
1094         $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1095             $trait, 'ForMetaClass', ref($self);
1096     }
1097
1098     return $class_name
1099         if Class::MOP::is_class_loaded($class_name);
1100
1101     # If the metaclass is a subclass of CMOP::Class which has had
1102     # metaclass roles applied (via Moose), then we want to make sure
1103     # that we preserve that anonymous class (see Fey::ORM for an
1104     # example of where this matters).
1105     my $meta_name
1106         = $self->meta->is_immutable
1107         ? $self->meta->get_mutable_metaclass_name
1108         : ref $self->meta;
1109
1110     my $meta = $meta_name->create(
1111         $class_name,
1112         superclasses => [ ref $self ],
1113     );
1114
1115     Class::MOP::load_class($trait);
1116     for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) {
1117         next if $meta->has_method( $meth->name );
1118
1119         if ( $meta->find_method_by_name( $meth->name ) ) {
1120             $meta->add_around_method_modifier( $meth->name, $meth->body );
1121         }
1122         else {
1123             $meta->add_method( $meth->name, $meth->clone );
1124         }
1125     }
1126
1127     $meta->make_immutable( inline_constructor => 0 );
1128
1129     return $class_name;
1130 }
1131
1132 sub _remove_inlined_code {
1133     my $self = shift;
1134
1135     $self->remove_method( $_->name ) for $self->_inlined_methods;
1136
1137     delete $self->{__immutable}{inlined_methods};
1138 }
1139
1140 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
1141
1142 sub _add_inlined_method {
1143     my ( $self, $method ) = @_;
1144
1145     push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
1146 }
1147
1148 sub _initialize_immutable {
1149     my ( $self, %args ) = @_;
1150
1151     $self->{__immutable}{options} = \%args;
1152     $self->_install_inlined_code(%args);
1153 }
1154
1155 sub _install_inlined_code {
1156     my ( $self, %args ) = @_;
1157
1158     # FIXME
1159     $self->_inline_accessors(%args)   if $args{inline_accessors};
1160     $self->_inline_constructor(%args) if $args{inline_constructor};
1161     $self->_inline_destructor(%args)  if $args{inline_destructor};
1162 }
1163
1164 sub _rebless_as_mutable {
1165     my $self = shift;
1166
1167     bless $self, $self->get_mutable_metaclass_name;
1168
1169     return $self;
1170 }
1171
1172 sub _inline_accessors {
1173     my $self = shift;
1174
1175     foreach my $attr_name ( $self->get_attribute_list ) {
1176         $self->get_attribute($attr_name)->install_accessors(1);
1177     }
1178 }
1179
1180 sub _inline_constructor {
1181     my ( $self, %args ) = @_;
1182
1183     my $name = $args{constructor_name};
1184
1185     if ( $self->has_method($name) && !$args{replace_constructor} ) {
1186         my $class = $self->name;
1187         warn "Not inlining a constructor for $class since it defines"
1188             . " its own constructor.\n"
1189             . "If you are certain you don't need to inline your"
1190             . " constructor, specify inline_constructor => 0 in your"
1191             . " call to $class->meta->make_immutable\n";
1192         return;
1193     }
1194
1195     my $constructor_class = $args{constructor_class};
1196
1197     Class::MOP::load_class($constructor_class);
1198
1199     my $constructor = $constructor_class->new(
1200         options      => \%args,
1201         metaclass    => $self,
1202         is_inline    => 1,
1203         package_name => $self->name,
1204         name         => $name,
1205     );
1206
1207     if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1208         $self->add_method( $name => $constructor );
1209         $self->_add_inlined_method($constructor);
1210     }
1211 }
1212
1213 sub _inline_destructor {
1214     my ( $self, %args ) = @_;
1215
1216     ( exists $args{destructor_class} && defined $args{destructor_class} )
1217         || confess "The 'inline_destructor' option is present, but "
1218         . "no destructor class was specified";
1219
1220     if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1221         my $class = $self->name;
1222         warn "Not inlining a destructor for $class since it defines"
1223             . " its own destructor.\n";
1224         return;
1225     }
1226
1227     my $destructor_class = $args{destructor_class};
1228
1229     Class::MOP::load_class($destructor_class);
1230
1231     return unless $destructor_class->is_needed($self);
1232
1233     my $destructor = $destructor_class->new(
1234         options      => \%args,
1235         metaclass    => $self,
1236         package_name => $self->name,
1237         name         => 'DESTROY'
1238     );
1239
1240     if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1241         $self->add_method( 'DESTROY' => $destructor );
1242         $self->_add_inlined_method($destructor);
1243     }
1244 }
1245
1246 1;
1247
1248 __END__
1249
1250 =pod
1251
1252 =head1 NAME
1253
1254 Class::MOP::Class - Class Meta Object
1255
1256 =head1 SYNOPSIS
1257
1258   # assuming that class Foo
1259   # has been defined, you can
1260
1261   # use this for introspection ...
1262
1263   # add a method to Foo ...
1264   Foo->meta->add_method( 'bar' => sub {...} )
1265
1266   # get a list of all the classes searched
1267   # the method dispatcher in the correct order
1268   Foo->meta->class_precedence_list()
1269
1270   # remove a method from Foo
1271   Foo->meta->remove_method('bar');
1272
1273   # or use this to actually create classes ...
1274
1275   Class::MOP::Class->create(
1276       'Bar' => (
1277           version      => '0.01',
1278           superclasses => ['Foo'],
1279           attributes   => [
1280               Class::MOP::Attribute->new('$bar'),
1281               Class::MOP::Attribute->new('$baz'),
1282           ],
1283           methods => {
1284               calculate_bar => sub {...},
1285               construct_baz => sub {...}
1286           }
1287       )
1288   );
1289
1290 =head1 DESCRIPTION
1291
1292 The Class Protocol is the largest and most complex part of the
1293 Class::MOP meta-object protocol. It controls the introspection and
1294 manipulation of Perl 5 classes, and it can create them as well. The
1295 best way to understand what this module can do, is to read the
1296 documentation for each of its methods.
1297
1298 =head1 INHERITANCE
1299
1300 C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1301
1302 =head1 METHODS
1303
1304 =head2 Class construction
1305
1306 These methods all create new C<Class::MOP::Class> objects. These
1307 objects can represent existing classes, or they can be used to create
1308 new classes from scratch.
1309
1310 The metaclass object for a given class is a singleton. If you attempt
1311 to create a metaclass for the same class twice, you will just get the
1312 existing object.
1313
1314 =over 4
1315
1316 =item B<< Class::MOP::Class->create($package_name, %options) >>
1317
1318 This method creates a new C<Class::MOP::Class> object with the given
1319 package name. It accepts a number of options.
1320
1321 =over 8
1322
1323 =item * version
1324
1325 An optional version number for the newly created package.
1326
1327 =item * authority
1328
1329 An optional authority for the newly created package.
1330
1331 =item * superclasses
1332
1333 An optional array reference of superclass names.
1334
1335 =item * methods
1336
1337 An optional hash reference of methods for the class. The keys of the
1338 hash reference are method names, and values are subroutine references.
1339
1340 =item * attributes
1341
1342 An optional array reference of L<Class::MOP::Attribute> objects.
1343
1344 =back
1345
1346 =item B<< Class::MOP::Class->create_anon_class(%options) >>
1347
1348 This method works just like C<< Class::MOP::Class->create >> but it
1349 creates an "anonymous" class. In fact, the class does have a name, but
1350 that name is a unique name generated internally by this module.
1351
1352 It accepts the same C<superclasses>, C<methods>, and C<attributes>
1353 parameters that C<create> accepts.
1354
1355 Anonymous classes are destroyed once the metaclass they are attached
1356 to goes out of scope, and will be removed from Perl's internal symbol
1357 table.
1358
1359 All instances of an anonymous class keep a special reference to the
1360 metaclass object, which prevents the metaclass from going out of scope
1361 while any instances exist.
1362
1363 This only works if the instance if based on a hash reference, however.
1364
1365 =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1366
1367 This method will initialize a C<Class::MOP::Class> object for the
1368 named package. Unlike C<create>, this method I<will not> create a new
1369 class.
1370
1371 The purpose of this method is to retrieve a C<Class::MOP::Class>
1372 object for introspecting an existing class.
1373
1374 If an existing C<Class::MOP::Class> object exists for the named
1375 package, it will be returned, and any options provided will be
1376 ignored!
1377
1378 If the object does not yet exist, it will be created.
1379
1380 The valid options that can be passed to this method are
1381 C<attribute_metaclass>, C<method_metaclass>,
1382 C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1383 optional, and default to the appropriate class in the C<Class::MOP>
1384 distribution.
1385
1386 =back
1387
1388 =head2 Object instance construction and cloning
1389
1390 These methods are all related to creating and/or cloning object
1391 instances.
1392
1393 =over 4
1394
1395 =item B<< $metaclass->clone_object($instance, %params) >>
1396
1397 This method clones an existing object instance. Any parameters you
1398 provide are will override existing attribute values in the object.
1399
1400 This is a convenience method for cloning an object instance, then
1401 blessing it into the appropriate package.
1402
1403 You could implement a clone method in your class, using this method:
1404
1405   sub clone {
1406       my ($self, %params) = @_;
1407       $self->meta->clone_object($self, %params);
1408   }
1409
1410 =item B<< $metaclass->rebless_instance($instance, %params) >>
1411
1412 This method changes the class of C<$instance> to the metaclass's class.
1413
1414 You can only rebless an instance into a subclass of its current
1415 class. If you pass any additional parameters, these will be treated
1416 like constructor parameters and used to initialize the object's
1417 attributes. Any existing attributes that are already set will be
1418 overwritten.
1419
1420 Before reblessing the instance, this method will call
1421 C<rebless_instance_away> on the instance's current metaclass. This method
1422 will be passed the instance, the new metaclass, and any parameters
1423 specified to C<rebless_instance>. By default, C<rebless_instance_away>
1424 does nothing; it is merely a hook.
1425
1426 =item B<< $metaclass->new_object(%params) >>
1427
1428 This method is used to create a new object of the metaclass's
1429 class. Any parameters you provide are used to initialize the
1430 instance's attributes. A special C<__INSTANCE__> key can be passed to
1431 provide an already generated instance, rather than having Class::MOP
1432 generate it for you. This is mostly useful for using Class::MOP with
1433 foreign classes, which generally generate instances using their own
1434 constructor.
1435
1436 =item B<< $metaclass->instance_metaclass >>
1437
1438 Returns the class name of the instance metaclass, see
1439 L<Class::MOP::Instance> for more information on the instance
1440 metaclass.
1441
1442 =item B<< $metaclass->get_meta_instance >>
1443
1444 Returns an instance of the C<instance_metaclass> to be used in the
1445 construction of a new instance of the class.
1446
1447 =back
1448
1449 =head2 Informational predicates
1450
1451 These are a few predicate methods for asking information about the
1452 class itself.
1453
1454 =over 4
1455
1456 =item B<< $metaclass->is_anon_class >>
1457
1458 This returns true if the class was created by calling C<<
1459 Class::MOP::Class->create_anon_class >>.
1460
1461 =item B<< $metaclass->is_mutable >>
1462
1463 This returns true if the class is still mutable.
1464
1465 =item B<< $metaclass->is_immutable >>
1466
1467 This returns true if the class has been made immutable.
1468
1469 =item B<< $metaclass->is_pristine >>
1470
1471 A class is I<not> pristine if it has non-inherited attributes or if it
1472 has any generated methods.
1473
1474 =back
1475
1476 =head2 Inheritance Relationships
1477
1478 =over 4
1479
1480 =item B<< $metaclass->superclasses(@superclasses) >>
1481
1482 This is a read-write accessor which represents the superclass
1483 relationships of the metaclass's class.
1484
1485 This is basically sugar around getting and setting C<@ISA>.
1486
1487 =item B<< $metaclass->class_precedence_list >>
1488
1489 This returns a list of all of the class's ancestor classes. The
1490 classes are returned in method dispatch order.
1491
1492 =item B<< $metaclass->linearized_isa >>
1493
1494 This returns a list based on C<class_precedence_list> but with all
1495 duplicates removed.
1496
1497 =item B<< $metaclass->subclasses >>
1498
1499 This returns a list of all subclasses for this class, even indirect
1500 subclasses.
1501
1502 =item B<< $metaclass->direct_subclasses >>
1503
1504 This returns a list of immediate subclasses for this class, which does not
1505 include indirect subclasses.
1506
1507 =back
1508
1509 =head2 Method introspection and creation
1510
1511 These methods allow you to introspect a class's methods, as well as
1512 add, remove, or change methods.
1513
1514 Determining what is truly a method in a Perl 5 class requires some
1515 heuristics (aka guessing).
1516
1517 Methods defined outside the package with a fully qualified name (C<sub
1518 Package::name { ... }>) will be included. Similarly, methods named
1519 with a fully qualified name using L<Sub::Name> are also included.
1520
1521 However, we attempt to ignore imported functions.
1522
1523 Ultimately, we are using heuristics to determine what truly is a
1524 method in a class, and these heuristics may get the wrong answer in
1525 some edge cases. However, for most "normal" cases the heuristics work
1526 correctly.
1527
1528 =over 4
1529
1530 =item B<< $metaclass->get_method($method_name) >>
1531
1532 This will return a L<Class::MOP::Method> for the specified
1533 C<$method_name>. If the class does not have the specified method, it
1534 returns C<undef>
1535
1536 =item B<< $metaclass->has_method($method_name) >>
1537
1538 Returns a boolean indicating whether or not the class defines the
1539 named method. It does not include methods inherited from parent
1540 classes.
1541
1542 =item B<< $metaclass->get_method_map >>
1543
1544 Returns a hash reference representing the methods defined in this
1545 class. The keys are method names and the values are
1546 L<Class::MOP::Method> objects.
1547
1548 =item B<< $metaclass->get_method_list >>
1549
1550 This will return a list of method I<names> for all methods defined in
1551 this class.
1552
1553 =item B<< $metaclass->get_all_methods >>
1554
1555 This will traverse the inheritance hierarchy and return a list of all
1556 the L<Class::MOP::Method> objects for this class and its parents.
1557
1558 =item B<< $metaclass->find_method_by_name($method_name) >>
1559
1560 This will return a L<Class::MOP::Method> for the specified
1561 C<$method_name>. If the class does not have the specified method, it
1562 returns C<undef>
1563
1564 Unlike C<get_method>, this method I<will> look for the named method in
1565 superclasses.
1566
1567 =item B<< $metaclass->get_all_method_names >>
1568
1569 This will return a list of method I<names> for all of this class's
1570 methods, including inherited methods.
1571
1572 =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1573
1574 This method looks for the named method in the class and all of its
1575 parents. It returns every matching method it finds in the inheritance
1576 tree, so it returns a list of methods.
1577
1578 Each method is returned as a hash reference with three keys. The keys
1579 are C<name>, C<class>, and C<code>. The C<code> key has a
1580 L<Class::MOP::Method> object as its value.
1581
1582 The list of methods is distinct.
1583
1584 =item B<< $metaclass->find_next_method_by_name($method_name) >>
1585
1586 This method returns the first method in any superclass matching the
1587 given name. It is effectively the method that C<SUPER::$method_name>
1588 would dispatch to.
1589
1590 =item B<< $metaclass->add_method($method_name, $method) >>
1591
1592 This method takes a method name and a subroutine reference, and adds
1593 the method to the class.
1594
1595 The subroutine reference can be a L<Class::MOP::Method>, and you are
1596 strongly encouraged to pass a meta method object instead of a code
1597 reference. If you do so, that object gets stored as part of the
1598 class's method map directly. If not, the meta information will have to
1599 be recreated later, and may be incorrect.
1600
1601 If you provide a method object, this method will clone that object if
1602 the object's package name does not match the class name. This lets us
1603 track the original source of any methods added from other classes
1604 (notably Moose roles).
1605
1606 =item B<< $metaclass->remove_method($method_name) >>
1607
1608 Remove the named method from the class. This method returns the
1609 L<Class::MOP::Method> object for the method.
1610
1611 =item B<< $metaclass->method_metaclass >>
1612
1613 Returns the class name of the method metaclass, see
1614 L<Class::MOP::Method> for more information on the method metaclass.
1615
1616 =item B<< $metaclass->wrapped_method_metaclass >>
1617
1618 Returns the class name of the wrapped method metaclass, see
1619 L<Class::MOP::Method::Wrapped> for more information on the wrapped
1620 method metaclass.
1621
1622 =back
1623
1624 =head2 Attribute introspection and creation
1625
1626 Because Perl 5 does not have a core concept of attributes in classes,
1627 we can only return information about attributes which have been added
1628 via this class's methods. We cannot discover information about
1629 attributes which are defined in terms of "regular" Perl 5 methods.
1630
1631 =over 4
1632
1633 =item B<< $metaclass->get_attribute($attribute_name) >>
1634
1635 This will return a L<Class::MOP::Attribute> for the specified
1636 C<$attribute_name>. If the class does not have the specified
1637 attribute, it returns C<undef>.
1638
1639 NOTE that get_attribute does not search superclasses, for that you
1640 need to use C<find_attribute_by_name>.
1641
1642 =item B<< $metaclass->has_attribute($attribute_name) >>
1643
1644 Returns a boolean indicating whether or not the class defines the
1645 named attribute. It does not include attributes inherited from parent
1646 classes.
1647
1648 =item B<< $metaclass->get_attribute_map >>
1649
1650 Returns a hash reference representing the attributes defined in this
1651 class. The keys are attribute names and the values are
1652 L<Class::MOP::Attribute> objects.
1653
1654 =item B<< $metaclass->get_attribute_list >>
1655
1656 This will return a list of attributes I<names> for all attributes
1657 defined in this class.
1658
1659 =item B<< $metaclass->get_all_attributes >>
1660
1661 This will traverse the inheritance hierarchy and return a list of all
1662 the L<Class::MOP::Attribute> objects for this class and its parents.
1663
1664 =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1665
1666 This will return a L<Class::MOP::Attribute> for the specified
1667 C<$attribute_name>. If the class does not have the specified
1668 attribute, it returns C<undef>
1669
1670 Unlike C<get_attribute>, this attribute I<will> look for the named
1671 attribute in superclasses.
1672
1673 =item B<< $metaclass->add_attribute(...) >>
1674
1675 This method accepts either an existing L<Class::MOP::Attribute>
1676 object, or parameters suitable for passing to that class's C<new>
1677 method.
1678
1679 The attribute provided will be added to the class.
1680
1681 Any accessor methods defined by the attribute will be added to the
1682 class when the attribute is added.
1683
1684 If an attribute of the same name already exists, the old attribute
1685 will be removed first.
1686
1687 =item B<< $metaclass->remove_attribute($attribute_name) >>
1688
1689 This will remove the named attribute from the class, and
1690 L<Class::MOP::Attribute> object.
1691
1692 Removing an attribute also removes any accessor methods defined by the
1693 attribute.
1694
1695 However, note that removing an attribute will only affect I<future>
1696 object instances created for this class, not existing instances.
1697
1698 =item B<< $metaclass->attribute_metaclass >>
1699
1700 Returns the class name of the attribute metaclass for this class. By
1701 default, this is L<Class::MOP::Attribute>.  for more information on
1702
1703 =back
1704
1705 =head2 Class Immutability
1706
1707 Making a class immutable "freezes" the class definition. You can no
1708 longer call methods which alter the class, such as adding or removing
1709 methods or attributes.
1710
1711 Making a class immutable lets us optimize the class by inlining some
1712 methods, and also allows us to optimize some methods on the metaclass
1713 object itself.
1714
1715 After immutabilization, the metaclass object will cache most
1716 informational methods such as C<get_method_map> and
1717 C<get_all_attributes>. Methods which would alter the class, such as
1718 C<add_attribute>, C<add_method>, and so on will throw an error on an
1719 immutable metaclass object.
1720
1721 The immutabilization system in L<Moose> takes much greater advantage
1722 of the inlining features than Class::MOP itself does.
1723
1724 =over 4
1725
1726 =item B<< $metaclass->make_immutable(%options) >>
1727
1728 This method will create an immutable transformer and uses it to make
1729 the class and its metaclass object immutable.
1730
1731 This method accepts the following options:
1732
1733 =over 8
1734
1735 =item * inline_accessors
1736
1737 =item * inline_constructor
1738
1739 =item * inline_destructor
1740
1741 These are all booleans indicating whether the specified method(s)
1742 should be inlined.
1743
1744 By default, accessors and the constructor are inlined, but not the
1745 destructor.
1746
1747 =item * immutable_trait
1748
1749 The name of a class which will be used as a parent class for the
1750 metaclass object being made immutable. This "trait" implements the
1751 post-immutability functionality of the metaclass (but not the
1752 transformation itself).
1753
1754 This defaults to L<Class::MOP::Class::Immutable::Trait>.
1755
1756 =item * constructor_name
1757
1758 This is the constructor method name. This defaults to "new".
1759
1760 =item * constructor_class
1761
1762 The name of the method metaclass for constructors. It will be used to
1763 generate the inlined constructor. This defaults to
1764 "Class::MOP::Method::Constructor".
1765
1766 =item * replace_constructor
1767
1768 This is a boolean indicating whether an existing constructor should be
1769 replaced when inlining a constructor. This defaults to false.
1770
1771 =item * destructor_class
1772
1773 The name of the method metaclass for destructors. It will be used to
1774 generate the inlined destructor. This defaults to
1775 "Class::MOP::Method::Denstructor".
1776
1777 =item * replace_destructor
1778
1779 This is a boolean indicating whether an existing destructor should be
1780 replaced when inlining a destructor. This defaults to false.
1781
1782 =back
1783
1784 =item B<< $metaclass->make_mutable >>
1785
1786 Calling this method reverse the immutabilization transformation.
1787
1788 =back
1789
1790 =head2 Method Modifiers
1791
1792 Method modifiers are hooks which allow a method to be wrapped with
1793 I<before>, I<after> and I<around> method modifiers. Every time a
1794 method is called, it's modifiers are also called.
1795
1796 A class can modify its own methods, as well as methods defined in
1797 parent classes.
1798
1799 =head3 How method modifiers work?
1800
1801 Method modifiers work by wrapping the original method and then
1802 replacing it in the class's symbol table. The wrappers will handle
1803 calling all the modifiers in the appropriate order and preserving the
1804 calling context for the original method.
1805
1806 The return values of C<before> and C<after> modifiers are
1807 ignored. This is because their purpose is B<not> to filter the input
1808 and output of the primary method (this is done with an I<around>
1809 modifier).
1810
1811 This may seem like an odd restriction to some, but doing this allows
1812 for simple code to be added at the beginning or end of a method call
1813 without altering the function of the wrapped method or placing any
1814 extra responsibility on the code of the modifier.
1815
1816 Of course if you have more complex needs, you can use the C<around>
1817 modifier which allows you to change both the parameters passed to the
1818 wrapped method, as well as its return value.
1819
1820 Before and around modifiers are called in last-defined-first-called
1821 order, while after modifiers are called in first-defined-first-called
1822 order. So the call tree might looks something like this:
1823
1824   before 2
1825    before 1
1826     around 2
1827      around 1
1828       primary
1829      around 1
1830     around 2
1831    after 1
1832   after 2
1833
1834 =head3 What is the performance impact?
1835
1836 Of course there is a performance cost associated with method
1837 modifiers, but we have made every effort to make that cost directly
1838 proportional to the number of modifier features you utilize.
1839
1840 The wrapping method does it's best to B<only> do as much work as it
1841 absolutely needs to. In order to do this we have moved some of the
1842 performance costs to set-up time, where they are easier to amortize.
1843
1844 All this said, our benchmarks have indicated the following:
1845
1846   simple wrapper with no modifiers             100% slower
1847   simple wrapper with simple before modifier   400% slower
1848   simple wrapper with simple after modifier    450% slower
1849   simple wrapper with simple around modifier   500-550% slower
1850   simple wrapper with all 3 modifiers          1100% slower
1851
1852 These numbers may seem daunting, but you must remember, every feature
1853 comes with some cost. To put things in perspective, just doing a
1854 simple C<AUTOLOAD> which does nothing but extract the name of the
1855 method called and return it costs about 400% over a normal method
1856 call.
1857
1858 =over 4
1859
1860 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
1861
1862 This wraps the specified method with the supplied subroutine
1863 reference. The modifier will be called as a method itself, and will
1864 receive the same arguments as are passed to the method.
1865
1866 When the modifier exits, the wrapped method will be called.
1867
1868 The return value of the modifier will be ignored.
1869
1870 =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
1871
1872 This wraps the specified method with the supplied subroutine
1873 reference. The modifier will be called as a method itself, and will
1874 receive the same arguments as are passed to the method.
1875
1876 When the wrapped methods exits, the modifier will be called.
1877
1878 The return value of the modifier will be ignored.
1879
1880 =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
1881
1882 This wraps the specified method with the supplied subroutine
1883 reference.
1884
1885 The first argument passed to the modifier will be a subroutine
1886 reference to the wrapped method. The second argument is the object,
1887 and after that come any arguments passed when the method is called.
1888
1889 The around modifier can choose to call the original method, as well as
1890 what arguments to pass if it does so.
1891
1892 The return value of the modifier is what will be seen by the caller.
1893
1894 =back
1895
1896 =head2 Introspection
1897
1898 =over 4
1899
1900 =item B<< Class::MOP::Class->meta >>
1901
1902 This will return a L<Class::MOP::Class> instance for this class.
1903
1904 It should also be noted that L<Class::MOP> will actually bootstrap
1905 this module by installing a number of attribute meta-objects into its
1906 metaclass.
1907
1908 =back
1909
1910 =head1 AUTHORS
1911
1912 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1913
1914 =head1 COPYRIGHT AND LICENSE
1915
1916 Copyright 2006-2009 by Infinity Interactive, Inc.
1917
1918 L<http://www.iinteractive.com>
1919
1920 This library is free software; you can redistribute it and/or modify
1921 it under the same terms as Perl itself.
1922
1923 =cut