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