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