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