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