File Coverage

blib/lib/Class/MOP/Class.pm
Criterion Covered Total %
statement 562 575 97.7
branch 216 236 91.5
condition 74 101 73.2
subroutine 112 116 96.5
pod 31 39 79.4
total 995 1067 93.2


line stmt bran cond sub pod time code
1             package Class::MOP::Class;
2             our $VERSION = '2.2206';
3              
4 450     450   3277 use strict;
  450         1034  
  450         13797  
5 450     450   2339 use warnings;
  450         953  
  450         11573  
6              
7 450     450   216946 use Class::MOP::Instance;
  450         1188  
  450         14720  
8 450     450   211858 use Class::MOP::Method::Wrapped;
  450         1258  
  450         18027  
9 450     450   213543 use Class::MOP::Method::Accessor;
  450         1370  
  450         16105  
10 450     450   206716 use Class::MOP::Method::Constructor;
  450         1244  
  450         16865  
11 450     450   191241 use Class::MOP::MiniTrait;
  450         1206  
  450         22202  
12              
13 450     450   2580 use Carp 'confess';
  450         1050  
  450         21397  
14 450     450   2798 use Module::Runtime 'use_package_optimistically';
  450         977  
  450         3764  
15 450     450   18655 use Scalar::Util 'blessed';
  450         1090  
  450         20681  
16 450     450   2833 use Sub::Util 1.40 'set_subname';
  450         9198  
  450         19491  
17 450     450   2817 use Try::Tiny;
  450         1029  
  450         28405  
18 450     450   3324 use List::Util 1.33 'all';
  450         8686  
  450         41923  
19              
20 450         3083 use parent 'Class::MOP::Module',
21             'Class::MOP::Mixin::HasAttributes',
22             'Class::MOP::Mixin::HasMethods',
23 450     450   3441 'Class::MOP::Mixin::HasOverloads';
  450         1239  
24              
25             # Creation
26              
27             sub initialize {
28 684217     684217 1 1009783 my $class = shift;
29              
30 684217         834376 my $package_name;
31              
32 684217 100       1297037 if ( @_ % 2 ) {
33 684215         923872 $package_name = shift;
34             } else {
35 2         7 my %options = @_;
36 2         7 $package_name = $options{package};
37             }
38              
39 684217 100 100     2016432 ($package_name && !ref($package_name))
      100        
40             || ($class||__PACKAGE__)->_throw_exception( InitializeTakesUnBlessedPackageName => package_name => $package_name );
41 684210   66     1381912 return Class::MOP::get_metaclass_by_name($package_name)
42             || $class->_construct_class_instance(package => $package_name, @_);
43             }
44              
45             sub reinitialize {
46 115     115 1 2548 my ( $class, @args ) = @_;
47 115 50       593 unshift @args, "package" if @args % 2;
48 115         634 my %options = @args;
49             my $old_metaclass = blessed($options{package})
50             ? $options{package}
51 115 100       728 : 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 115 100 66     2013 && blessed($old_metaclass)
      100        
55             && $old_metaclass->isa('Class::MOP::Class');
56 115 100 100     1206 $old_metaclass->_remove_generated_metaobjects
57             if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
58 115         1036 my $new_metaclass = $class->SUPER::reinitialize(%options);
59 112 50 33     1395 $new_metaclass->_restore_metaobjects_from($old_metaclass)
60             if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
61 109         866 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 29423     29423   52335 my $class = shift;
72 29423 50       107593 my $options = @_ == 1 ? $_[0] : {@_};
73 29423         60449 my $package_name = $options->{package};
74 29423 100 66     104805 (defined $package_name && $package_name)
75             || $class->_throw_exception("ConstructClassInstanceTakesPackageName");
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 29419 100       62148 if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
83 5         26 return $meta;
84             }
85              
86             $class
87 29414 100       66359 = ref $class
88             ? $class->_real_ref_name
89             : $class;
90              
91             # now create the metaclass
92 29414         40295 my $meta;
93 29414 100       59377 if ($class eq 'Class::MOP::Class') {
94 26732         67664 $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 2682         12380 $meta = $class->meta->_construct_instance($options)
102             }
103              
104             # and check the metaclass compatibility
105 29410         98685 $meta->_check_metaclass_compatibility();
106              
107 29407         147097 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 29407 100       72125 Class::MOP::weaken_metaclass($package_name) if $options->{weaken};
113              
114 29407         168024 $meta;
115             }
116              
117             sub _real_ref_name {
118 30515     30515   45594 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 30515 100       75527 return $self->is_immutable
123             ? $self->_get_mutable_metaclass_name()
124             : ref $self;
125             }
126              
127             sub _new {
128 26732     26732   42378 my $class = shift;
129              
130 26732 50       56124 return Class::MOP::Class->initialize($class)->new_object(@_)
131             if $class ne __PACKAGE__;
132              
133 26732 50       55638 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 26732   100     537778 }, $class;
      100        
      100        
      100        
      50        
      50        
      100        
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 40343     40343   209078 sub _base_metaclasses { %base_metaclass }
192             }
193              
194             sub _check_metaclass_compatibility {
195 32934     32934   51544 my $self = shift;
196              
197 32934 100       87159 my @superclasses = $self->superclasses
198             or return;
199              
200 17756         64759 $self->_fix_metaclass_incompatibility(@superclasses);
201              
202 17750         38992 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 88965     88965   192043 my $meta = $self->$_;
209 88965 100       270237 !defined($meta) || $meta eq $base_metaclass{$_};
210             }
211 17750 100 100     151506 keys %base_metaclass;
212              
213 2929         7770 for my $superclass (@superclasses) {
214 3266         11271 $self->_check_class_metaclass_compatibility($superclass);
215             }
216              
217 2923         10928 for my $metaclass_type ( keys %base_metaclass ) {
218 17505 100       206264 next unless defined $self->$metaclass_type;
219 17473         31089 for my $superclass (@superclasses) {
220 19495         38050 $self->_check_single_metaclass_compatibility( $metaclass_type,
221             $superclass );
222             }
223             }
224             }
225              
226             sub _check_class_metaclass_compatibility {
227 3266     3266   6286 my $self = shift;
228 3266         6731 my ( $superclass_name ) = @_;
229              
230 3266 100       10147 if (!$self->_class_metaclass_is_compatible($superclass_name)) {
231 6         31 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
232              
233 6         15 my $super_meta_type = $super_meta->_real_ref_name;
234              
235 6         59 $self->_throw_exception( IncompatibleMetaclassOfSuperclass => class_name => $self->name,
236             class_meta_type => ref( $self ),
237             superclass_name => $superclass_name,
238             superclass_meta_type => $super_meta_type
239             );
240             }
241             }
242              
243             sub _class_metaclass_is_compatible {
244 3353     3353   6033 my $self = shift;
245 3353         6887 my ( $superclass_name ) = @_;
246              
247 3353   50     9653 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
248             || return 1;
249              
250 3353         9182 my $super_meta_name = $super_meta->_real_ref_name;
251              
252 3353         10790 return $self->_is_compatible_with($super_meta_name);
253             }
254              
255             sub _check_single_metaclass_compatibility {
256 19495     19495   27291 my $self = shift;
257 19495         33837 my ( $metaclass_type, $superclass_name ) = @_;
258              
259 19495 100       37857 if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
260 10         30 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
261              
262 10         61 $self->_throw_exception( MetaclassTypeIncompatible => class_name => $self->name,
263             superclass_name => $superclass_name,
264             metaclass_type => $metaclass_type
265             );
266             }
267             }
268              
269             sub _single_metaclass_is_compatible {
270 19983     19983   27199 my $self = shift;
271 19983         30903 my ( $metaclass_type, $superclass_name ) = @_;
272              
273 19983   50     38813 my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
274             || return 1;
275              
276             # for instance, Moose::Meta::Class has a error_class attribute, but
277             # Class::MOP::Class doesn't - this shouldn't be an error
278 19983 100       56146 return 1 unless $super_meta->can($metaclass_type);
279             # for instance, Moose::Meta::Class has a destructor_class, but
280             # Class::MOP::Class doesn't - this shouldn't be an error
281 19980 100       170362 return 1 unless defined $super_meta->$metaclass_type;
282             # if metaclass is defined in superclass but not here, it's not compatible
283             # this is a really odd case
284 19137 100       181227 return 0 unless defined $self->$metaclass_type;
285              
286 19118         192230 return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
287             }
288              
289             sub _fix_metaclass_incompatibility {
290 17756     17756   27992 my $self = shift;
291 17756         35547 my @supers = map { Class::MOP::Class->initialize($_) } @_;
  22581         53800  
292              
293 17756         35664 my $necessary = 0;
294 17756         36369 for my $super (@supers) {
295 22581 100       53377 $necessary = 1
296             if $self->_can_fix_metaclass_incompatibility($super);
297             }
298 17755 100       47209 return unless $necessary;
299              
300 81         199 for my $super (@supers) {
301 87 100       435 if (!$self->_class_metaclass_is_compatible($super->name)) {
302 67         289 $self->_fix_class_metaclass_incompatibility($super);
303             }
304             }
305              
306 78         340 my %base_metaclass = $self->_base_metaclasses;
307 78         295 for my $metaclass_type (keys %base_metaclass) {
308 464         847 for my $super (@supers) {
309 488 100       1347 if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
310 136         497 $self->_fix_single_metaclass_incompatibility(
311             $metaclass_type, $super
312             );
313             }
314             }
315             }
316             }
317              
318             sub _can_fix_metaclass_incompatibility {
319 22581     22581   34135 my $self = shift;
320 22581         39780 my ($super_meta) = @_;
321              
322 22581 100       48738 return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
323              
324 22515         60120 my %base_metaclass = $self->_base_metaclasses;
325 22515         68606 for my $metaclass_type (keys %base_metaclass) {
326 135052 100       243368 return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
327             }
328              
329 22499         88072 return;
330             }
331              
332             sub _class_metaclass_can_be_made_compatible {
333 22683     22683   33071 my $self = shift;
334 22683         34849 my ($super_meta) = @_;
335              
336 22683         51209 return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
337             }
338              
339             sub _single_metaclass_can_be_made_compatible {
340 135312     135312   174364 my $self = shift;
341 135312         200138 my ($super_meta, $metaclass_type) = @_;
342              
343 135312         538897 my $specific_meta = $self->$metaclass_type;
344              
345 135312 50       370038 return unless $super_meta->can($metaclass_type);
346 135312         427828 my $super_specific_meta = $super_meta->$metaclass_type;
347              
348             # for instance, Moose::Meta::Class has a destructor_class, but
349             # Class::MOP::Class doesn't - this shouldn't be an error
350 135312 100       255809 return unless defined $super_specific_meta;
351              
352             # if metaclass is defined in superclass but not here, it's fixable
353             # this is a really odd case
354 115149 100       178898 return 1 unless defined $specific_meta;
355              
356 115128 100       333348 return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
357             }
358              
359             sub _fix_class_metaclass_incompatibility {
360 67     67   144 my $self = shift;
361 67         145 my ( $super_meta ) = @_;
362              
363 67 100       194 if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
364 66 100       386 ($self->is_pristine)
365             || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name,
366             superclass => $super_meta
367             );
368              
369 63         414 my $super_meta_name = $super_meta->_real_ref_name;
370              
371 63         339 $self->_make_compatible_with($super_meta_name);
372             }
373             }
374              
375             sub _fix_single_metaclass_incompatibility {
376 136     136   231 my $self = shift;
377 136         248 my ( $metaclass_type, $super_meta ) = @_;
378              
379 136 100       302 if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
380 135 100       392 ($self->is_pristine)
381             || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name,
382             superclass => $super_meta,
383             metaclass_type => $metaclass_type
384             );
385              
386 133 100       2102 my $new_metaclass = $self->$metaclass_type
387             ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
388             : $super_meta->$metaclass_type;
389 133         388 $self->{$metaclass_type} = $new_metaclass;
390             }
391             }
392              
393             sub _restore_metaobjects_from {
394 112     112   231 my $self = shift;
395 112         242 my ($old_meta) = @_;
396              
397 112         1332 $self->_restore_metamethods_from($old_meta);
398 109         1147 $self->_restore_metaattributes_from($old_meta);
399             }
400              
401             sub _remove_generated_metaobjects {
402 113     113   274 my $self = shift;
403              
404 113         1094 for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
  25         120  
405 25         143 $attr->remove_accessors;
406             }
407             }
408              
409             # creating classes with MOP ...
410              
411             sub create {
412 1504     1504 1 16613 my $class = shift;
413 1504         5024 my @args = @_;
414              
415 1504 100       7472 unshift @args, 'package' if @args % 2 == 1;
416 1504         5765 my %options = @args;
417              
418             (ref $options{superclasses} eq 'ARRAY')
419             || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfSuperclasses => class => $class,
420             params => \%options
421             )
422 1504 100 100     9015 if exists $options{superclasses};
423              
424             (ref $options{attributes} eq 'ARRAY')
425             || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfAttributes => class => $class,
426             params => \%options
427             )
428 1503 100 66     5277 if exists $options{attributes};
429              
430             (ref $options{methods} eq 'HASH')
431             || __PACKAGE__->_throw_exception( CreateMOPClassTakesHashRefOfMethods => class => $class,
432             params => \%options
433             )
434 1502 100 66     5324 if exists $options{methods};
435              
436 1501         3722 my $package = delete $options{package};
437 1501         3546 my $superclasses = delete $options{superclasses};
438 1501         9841 my $attributes = delete $options{attributes};
439 1501         3107 my $methods = delete $options{methods};
440             my $meta_name = exists $options{meta_name}
441             ? delete $options{meta_name}
442 1501 100       4830 : 'meta';
443              
444 1501         15252 my $meta = $class->SUPER::create($package => %options);
445              
446 1496 100       24259 $meta->_add_meta_method($meta_name)
447             if defined $meta_name;
448              
449 1496 100       7263 $meta->superclasses(@{$superclasses})
  1411         6242  
450             if defined $superclasses;
451             # NOTE:
452             # process attributes first, so that they can
453             # install accessors, but locally defined methods
454             # can then overwrite them. It is maybe a little odd, but
455             # I think this should be the order of things.
456 1485 100       6169 if (defined $attributes) {
457 23         42 foreach my $attr (@{$attributes}) {
  23         53  
458 25         90 $meta->add_attribute($attr);
459             }
460             }
461 1484 100       5124 if (defined $methods) {
462 25         41 foreach my $method_name (keys %{$methods}) {
  25         86  
463 32         94 $meta->add_method($method_name, $methods->{$method_name});
464             }
465             }
466 1484         6199 return $meta;
467             }
468              
469             # XXX: something more intelligent here?
470 67     67   222 sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' }
471              
472 2772     2772 1 25520 sub create_anon_class { shift->create_anon(@_) }
473 7     7 1 75 sub is_anon_class { shift->is_anon(@_) }
474              
475             sub _anon_cache_key {
476 0     0   0 my $class = shift;
477 0         0 my %options = @_;
478             # Makes something like Super::Class|Super::Class::2
479             return join '=' => (
480 0 0       0 join( '|', sort @{ $options{superclasses} || [] } ),
  0         0  
481             );
482             }
483              
484             # Instance Construction & Cloning
485              
486             sub new_object {
487 20911     20911 1 42984 my $class = shift;
488              
489             # NOTE:
490             # we need to protect the integrity of the
491             # Class::MOP::Class singletons here, so we
492             # delegate this to &construct_class_instance
493             # which will deal with the singletons
494 20911 100       143353 return $class->_construct_class_instance(@_)
495             if $class->name->isa('Class::MOP::Class');
496 20905         56115 return $class->_construct_instance(@_);
497             }
498              
499             sub _construct_instance {
500 23587     23587   37367 my $class = shift;
501 23587 100       52569 my $params = @_ == 1 ? $_[0] : {@_};
502 23587         67326 my $meta_instance = $class->get_meta_instance();
503             # FIXME:
504             # the code below is almost certainly incorrect
505             # but this is foreign inheritance, so we might
506             # have to kludge it in the end.
507 23587         38694 my $instance;
508 23587 100       129090 if (my $instance_class = blessed($params->{__INSTANCE__})) {
    100          
509             ($instance_class eq $class->name)
510             || $class->_throw_exception( InstanceBlessedIntoWrongClass => class_name => $class->name,
511             params => $params,
512             instance => $params->{__INSTANCE__}
513 9 100       75 );
514 6         14 $instance = $params->{__INSTANCE__};
515             }
516             elsif (exists $params->{__INSTANCE__}) {
517             $class->_throw_exception( InstanceMustBeABlessedReference => class_name => $class->name,
518             params => $params,
519             instance => $params->{__INSTANCE__}
520 5         31 );
521             }
522             else {
523 23573         75323 $instance = $meta_instance->create_instance();
524             }
525 23579         81776 foreach my $attr ($class->get_all_attributes()) {
526 168074         372031 $attr->initialize_instance_slot($meta_instance, $instance, $params);
527             }
528 22585 100       95040 if (Class::MOP::metaclass_is_weak($class->name)) {
529 1683         4111 $meta_instance->_set_mop_slot($instance, $class);
530             }
531 22585         76408 return $instance;
532             }
533              
534             sub _inline_new_object {
535 12217     12217   19295 my $self = shift;
536              
537             return (
538 12217         30970 'my $class = shift;',
539             '$class = Scalar::Util::blessed($class) || $class;',
540             $self->_inline_fallback_constructor('$class'),
541             $self->_inline_params('$params', '$class'),
542             $self->_inline_generate_instance('$instance', '$class'),
543             $self->_inline_slot_initializers,
544             $self->_inline_preserve_weak_metaclasses,
545             $self->_inline_extra_init,
546             'return $instance',
547             );
548             }
549              
550             sub _inline_fallback_constructor {
551 12217     12217   18739 my $self = shift;
552 12217         23219 my ($class) = @_;
553             return (
554 12217         28609 'return ' . $self->_generate_fallback_constructor($class),
555             'if ' . $class . ' ne \'' . $self->name . '\';',
556             );
557             }
558              
559             sub _generate_fallback_constructor {
560 11472     11472   16513 my $self = shift;
561 11472         18475 my ($class) = @_;
562 11472         61769 return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)',
563             }
564              
565             sub _inline_params {
566 11472     11472   18693 my $self = shift;
567 11472         20962 my ($params, $class) = @_;
568             return (
569 11472         32892 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};',
570             );
571             }
572              
573             sub _inline_generate_instance {
574 12217     12217   19188 my $self = shift;
575 12217         22236 my ($inst, $class) = @_;
576             return (
577 12217         30472 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';',
578             );
579             }
580              
581             sub _inline_create_instance {
582 12217     12217   17813 my $self = shift;
583              
584 12217         27309 return $self->get_meta_instance->inline_create_instance(@_);
585             }
586              
587             sub _inline_slot_initializers {
588 12217     12217   20128 my $self = shift;
589              
590 12217         17713 my $idx = 0;
591              
592 110435         221572 return map { $self->_inline_slot_initializer($_, $idx++) }
593 12217         26660 sort { $a->name cmp $b->name } $self->get_all_attributes;
  291070         583090  
594             }
595              
596             sub _inline_slot_initializer {
597 110435     110435   150848 my $self = shift;
598 110435         170514 my ($attr, $idx) = @_;
599              
600 110435 100       304943 if (defined(my $init_arg = $attr->init_arg)) {
    100          
601 106279         286043 my @source = (
602             'if (exists $params->{\'' . $init_arg . '\'}) {',
603             $self->_inline_init_attr_from_constructor($attr, $idx),
604             '}',
605             );
606 106279 100       204028 if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
607 33943         69041 push @source, (
608             'else {',
609             @default,
610             '}',
611             );
612             }
613 106279         355236 return @source;
614             }
615             elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
616             return (
617 3778         12987 '{',
618             @default,
619             '}',
620             );
621             }
622             else {
623 378         1795 return ();
624             }
625             }
626              
627             sub _inline_init_attr_from_constructor {
628 103799     103799   142938 my $self = shift;
629 103799         150929 my ($attr, $idx) = @_;
630              
631 103799         312551 my @initial_value = $attr->_inline_set_value(
632             '$instance', '$params->{\'' . $attr->init_arg . '\'}',
633             );
634              
635 103799 50       254226 push @initial_value, (
636             '$attrs->[' . $idx . ']->set_initial_value(',
637             '$instance,',
638             $attr->_inline_instance_get('$instance'),
639             ');',
640             ) if $attr->has_initializer;
641              
642 103799         249802 return @initial_value;
643             }
644              
645             sub _inline_init_attr_from_default {
646 107946     107946   147525 my $self = shift;
647 107946         159668 my ($attr, $idx) = @_;
648              
649 107946         175626 my $default = $self->_inline_default_value($attr, $idx);
650 107946 100       261241 return unless $default;
651              
652 37580         78829 my @initial_value = $attr->_inline_set_value('$instance', $default);
653              
654 37580 50       89453 push @initial_value, (
655             '$attrs->[' . $idx . ']->set_initial_value(',
656             '$instance,',
657             $attr->_inline_instance_get('$instance'),
658             ');',
659             ) if $attr->has_initializer;
660              
661 37580         111864 return @initial_value;
662             }
663              
664             sub _inline_default_value {
665 109164     109164   138104 my $self = shift;
666 109164         160644 my ($attr, $index) = @_;
667              
668 109164 100       205171 if ($attr->has_default) {
    100          
669             # NOTE:
670             # default values can either be CODE refs
671             # in which case we need to call them. Or
672             # they can be scalars (strings/numbers)
673             # in which case we can just deal with them
674             # in the code we eval.
675 37718 100       79206 if ($attr->is_default_a_coderef) {
676 26659         76594 return '$defaults->[' . $index . ']->($instance)';
677             }
678             else {
679 11059         32215 return '$defaults->[' . $index . ']';
680             }
681             }
682             elsif ($attr->has_builder) {
683 3         32 return '$instance->' . $attr->builder;
684             }
685             else {
686 71443         145409 return;
687             }
688             }
689              
690             sub _inline_preserve_weak_metaclasses {
691 12217     12217   21478 my $self = shift;
692 12217 100       45960 if (Class::MOP::metaclass_is_weak($self->name)) {
693             return (
694 21         55 $self->_inline_set_mop_slot(
695             '$instance', 'Class::MOP::class_of($class)'
696             ) . ';'
697             );
698             }
699             else {
700 12196         33935 return ();
701             }
702             }
703              
704       11442     sub _inline_extra_init { }
705              
706             sub _eval_environment {
707 12218     12218   19691 my $self = shift;
708              
709 12218         29092 my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
  291436         574628  
710              
711 12218         28740 my $defaults = [map { $_->default } @attrs];
  110435         200733  
712              
713             return {
714 12218         67855 '$defaults' => \$defaults,
715             };
716             }
717              
718              
719             sub get_meta_instance {
720 139639     139639 1 221620 my $self = shift;
721 139639   66     434225 $self->{'_meta_instance'} ||= $self->_create_meta_instance();
722             }
723              
724             sub _create_meta_instance {
725 21139     21139   31993 my $self = shift;
726              
727 21139         71386 my $instance = $self->instance_metaclass->new(
728             associated_metaclass => $self,
729             attributes => [ $self->get_all_attributes() ],
730             );
731              
732 21139 100       70268 $self->add_meta_instance_dependencies()
733             if $instance->is_dependent_on_superclasses();
734              
735 21139         80663 return $instance;
736             }
737              
738             # TODO: this is actually not being used!
739             sub _inline_rebless_instance {
740 0     0   0 my $self = shift;
741              
742 0         0 return $self->get_meta_instance->inline_rebless_instance_structure(@_);
743             }
744              
745             sub _inline_get_mop_slot {
746 0     0   0 my $self = shift;
747              
748 0         0 return $self->get_meta_instance->_inline_get_mop_slot(@_);
749             }
750              
751             sub _inline_set_mop_slot {
752 21     21   34 my $self = shift;
753              
754 21         47 return $self->get_meta_instance->_inline_set_mop_slot(@_);
755             }
756              
757             sub _inline_clear_mop_slot {
758 0     0   0 my $self = shift;
759              
760 0         0 return $self->get_meta_instance->_inline_clear_mop_slot(@_);
761             }
762              
763             sub clone_object {
764 27     27 1 4681 my $class = shift;
765 27         51 my $instance = shift;
766 27 100 100     299 (blessed($instance) && $instance->isa($class->name))
767             || $class->_throw_exception( CloneObjectExpectsAnInstanceOfMetaclass => class_name => $class->name,
768             instance => $instance,
769             );
770             # NOTE:
771             # we need to protect the integrity of the
772             # Class::MOP::Class singletons here, they
773             # should not be cloned.
774 22 100       125 return $instance if $instance->isa('Class::MOP::Class');
775 17         86 $class->_clone_instance($instance, @_);
776             }
777              
778             sub _clone_instance {
779 18     18   132 my ($class, $instance, %params) = @_;
780 18 100       89 (blessed($instance))
781             || $class->_throw_exception( OnlyInstancesCanBeCloned => class_name => $class->name,
782             instance => $instance,
783             params => \%params
784             );
785 17         66 my $meta_instance = $class->get_meta_instance();
786 17         108 my $clone = $meta_instance->clone_instance($instance);
787 17         59 foreach my $attr ($class->get_all_attributes()) {
788 172 100       428 if ( defined( my $init_arg = $attr->init_arg ) ) {
789 163 100       316 if (exists $params{$init_arg}) {
790 15         49 $attr->set_value($clone, $params{$init_arg});
791             }
792             }
793             }
794 17         74 return $clone;
795             }
796              
797             sub _force_rebless_instance {
798 126     126   389 my ($self, $instance, %params) = @_;
799 126         334 my $old_metaclass = Class::MOP::class_of($instance);
800              
801 126 50       936 $old_metaclass->rebless_instance_away($instance, $self, %params)
802             if $old_metaclass;
803              
804 126         366 my $meta_instance = $self->get_meta_instance;
805              
806 126 100       626 if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
807 1         6 $meta_instance->_clear_mop_slot($instance);
808             }
809              
810             # rebless!
811             # we use $_[1] here because of t/cmop/rebless_overload.t regressions
812             # on 5.8.8
813 126         774 $meta_instance->rebless_instance_structure($_[1], $self);
814              
815 126         959 $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
816              
817 122 100       931 if (Class::MOP::metaclass_is_weak($self->name)) {
818 4         20 $meta_instance->_set_mop_slot($instance, $self);
819             }
820             }
821              
822             sub rebless_instance {
823 45     45 1 187 my ($self, $instance, %params) = @_;
824 45         157 my $old_metaclass = Class::MOP::class_of($instance);
825              
826 45 50       266 my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
827 45 100       334 $self->name->isa($old_class)
828             || $self->_throw_exception( CanReblessOnlyIntoASubclass => class_name => $self->name,
829             instance => $instance,
830             instance_class => blessed( $instance ),
831             params => \%params,
832             );
833              
834 42         301 $self->_force_rebless_instance($_[1], %params);
835              
836 38         127 return $instance;
837             }
838              
839             sub rebless_instance_back {
840 9     9 1 703 my ( $self, $instance ) = @_;
841 9         39 my $old_metaclass = Class::MOP::class_of($instance);
842 9 50       60 my $old_class
843             = $old_metaclass ? $old_metaclass->name : blessed($instance);
844 9 100       92 $old_class->isa( $self->name )
845             || $self->_throw_exception( CanReblessOnlyIntoASuperclass => class_name => $self->name,
846             instance => $instance,
847             instance_class => blessed( $instance ),
848             );
849              
850 6         24 $self->_force_rebless_instance($_[1]);
851              
852 6         24 return $instance;
853             }
854              
855       126 0   sub rebless_instance_away {
856             # this intentionally does nothing, it is just a hook
857             }
858              
859             sub _fixup_attributes_after_rebless {
860 126     126   240 my $self = shift;
861 126         666 my ($instance, $rebless_from, %params) = @_;
862 126         311 my $meta_instance = $self->get_meta_instance;
863              
864 126         444 for my $attr ( $rebless_from->get_all_attributes ) {
865 1337 100       3650 next if $self->find_attribute_by_name( $attr->name );
866 3         11 $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
867             }
868              
869 126         528 foreach my $attr ( $self->get_all_attributes ) {
870 1404 100       3084 if ( $attr->has_value($instance) ) {
871 1167 100       3154 if ( defined( my $init_arg = $attr->init_arg ) ) {
872             $params{$init_arg} = $attr->get_value($instance)
873 915 100       2709 unless exists $params{$init_arg};
874             }
875             else {
876 252         576 $attr->set_value($instance, $attr->get_value($instance));
877             }
878             }
879             }
880              
881 126         524 foreach my $attr ($self->get_all_attributes) {
882 1399         3334 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
883             }
884             }
885              
886             sub _attach_attribute {
887 56782     56782   103533 my ($self, $attribute) = @_;
888 56782         145373 $attribute->attach_to_class($self);
889             }
890              
891             sub _post_add_attribute {
892 56782     56782   96611 my ( $self, $attribute ) = @_;
893              
894 56782         146927 $self->invalidate_meta_instances;
895              
896             # invalidate package flag here
897             try {
898 56782     56782   2479538 local $SIG{__DIE__};
899 56782         163935 $attribute->install_accessors;
900             }
901             catch {
902 22     22   727 $self->remove_attribute( $attribute->name );
903 5         69 die $_;
904 56782         367617 };
905             }
906              
907             sub remove_attribute {
908 47     47 1 1762 my $self = shift;
909              
910 47 100       330 my $removed_attribute = $self->SUPER::remove_attribute(@_)
911             or return;
912              
913 43         168 $self->invalidate_meta_instances;
914              
915 43         285 $removed_attribute->remove_accessors;
916 26         147 $removed_attribute->detach_from_class;
917              
918 26         350 return$removed_attribute;
919             }
920              
921             sub find_attribute_by_name {
922 24148     24148 1 54156 my ( $self, $attr_name ) = @_;
923              
924 24148         63913 foreach my $class ( $self->linearized_isa ) {
925             # fetch the meta-class ...
926 30438         67507 my $meta = Class::MOP::Class->initialize($class);
927 30438 100       86724 return $meta->get_attribute($attr_name)
928             if $meta->has_attribute($attr_name);
929             }
930              
931 75         682 return;
932             }
933              
934             sub get_all_attributes {
935 63395     63395 1 98294 my $self = shift;
936 63395         134708 my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
  262669         373599  
  262669         472811  
937             reverse $self->linearized_isa;
938 63395         425669 return values %attrs;
939             }
940              
941             # Inheritance
942              
943             sub superclasses {
944 45419     45419   70532 my $self = shift;
945              
946 45419         138735 my $isa = $self->get_or_add_package_symbol('@ISA');
947              
948 45418 100       141020 if (@_) {
949 3526         12323 my @supers = @_;
950 3526         7672 @{$isa} = @supers;
  3526         91300  
951              
952             # NOTE:
953             # on 5.8 and below, we need to call
954             # a method to get Perl to detect
955             # a cycle in the class hierarchy
956 3524         29291 my $class = $self->name;
957 3524         34590 $class->isa($class);
958              
959             # NOTE:
960             # we need to check the metaclass
961             # compatibility here so that we can
962             # be sure that the superclass is
963             # not potentially creating an issues
964             # we don't know about
965              
966 3524         11922 $self->_check_metaclass_compatibility();
967 3504         19521 $self->_superclasses_updated();
968             }
969              
970 45396         64916 return @{$isa};
  45396         192735  
971             }
972              
973             sub _superclasses_updated {
974 3504     3504   7361 my $self = shift;
975 3504         14270 $self->update_meta_instance_dependencies();
976             # keep strong references to all our parents, so they don't disappear if
977             # they are anon classes and don't have any direct instances
978             $self->_superclass_metas(
979 3504         12824 map { Class::MOP::class_of($_) } $self->superclasses
  3850         13484  
980             );
981             }
982              
983             sub _superclass_metas {
984 3504     3504   7587 my $self = shift;
985 3504         14101 $self->{_superclass_metas} = [@_];
986             }
987              
988             sub subclasses {
989 12     12 1 19 my $self = shift;
990 12         41 my $super_class = $self->name;
991              
992 12         20 return @{ $super_class->mro::get_isarev() };
  12         110  
993             }
994              
995             sub direct_subclasses {
996 6     6 1 11 my $self = shift;
997 6         20 my $super_class = $self->name;
998              
999             return grep {
1000 6         10 grep {
1001 8         18 $_ eq $super_class
  8         54  
1002             } Class::MOP::Class->initialize($_)->superclasses
1003             } $self->subclasses;
1004             }
1005              
1006             sub linearized_isa {
1007 135758     135758 1 189196 return @{ mro::get_linear_isa( (shift)->name ) };
  135758         854881  
1008             }
1009              
1010             sub class_precedence_list {
1011 3770     3770 1 7185 my $self = shift;
1012 3770         12795 my $name = $self->name;
1013              
1014 3770 50       10646 unless (Class::MOP::IS_RUNNING_ON_5_10()) {
1015             # NOTE:
1016             # We need to check for circular inheritance here
1017             # if we are not on 5.10, cause 5.8 detects it late.
1018             # This will do nothing if all is well, and blow up
1019             # otherwise. Yes, it's an ugly hack, better
1020             # suggestions are welcome.
1021             # - SL
1022 0   0     0 ($name || return)->isa('This is a test for circular inheritance')
1023             }
1024              
1025             # if our mro is c3, we can
1026             # just grab the linear_isa
1027 3770 100       16554 if (mro::get_mro($name) eq 'c3') {
1028 1         3 return @{ mro::get_linear_isa($name) }
  1         14  
1029             }
1030             else {
1031             # NOTE:
1032             # we can't grab the linear_isa for dfs
1033             # since it has all the duplicates
1034             # already removed.
1035             return (
1036             $name,
1037             map {
1038 3769         11222 Class::MOP::Class->initialize($_)->class_precedence_list()
  3595         11073  
1039             } $self->superclasses()
1040             );
1041             }
1042             }
1043              
1044             sub _method_lookup_order {
1045 69517     69517   143216 return (shift->linearized_isa, 'UNIVERSAL');
1046             }
1047              
1048             ## Methods
1049              
1050             {
1051             my $fetch_and_prepare_method = sub {
1052             my ($self, $method_name) = @_;
1053             my $wrapped_metaclass = $self->wrapped_method_metaclass;
1054             # fetch it locally
1055             my $method = $self->get_method($method_name);
1056             # if we don't have local ...
1057             unless ($method) {
1058             # try to find the next method
1059             $method = $self->find_next_method_by_name($method_name);
1060             # die if it does not exist
1061             (defined $method)
1062             || $self->_throw_exception( MethodNameNotFoundInInheritanceHierarchy => class_name => $self->name,
1063             method_name => $method_name
1064             );
1065             # and now make sure to wrap it
1066             # even if it is already wrapped
1067             # because we need a new sub ref
1068             $method = $wrapped_metaclass->wrap($method,
1069             package_name => $self->name,
1070             name => $method_name,
1071             );
1072             }
1073             else {
1074             # now make sure we wrap it properly
1075             $method = $wrapped_metaclass->wrap($method,
1076             package_name => $self->name,
1077             name => $method_name,
1078             ) unless $method->isa($wrapped_metaclass);
1079             }
1080             $self->add_method($method_name => $method);
1081             return $method;
1082             };
1083              
1084             sub add_before_method_modifier {
1085 153     153 1 630 my ($self, $method_name, $method_modifier) = @_;
1086 153 100 66     923 (defined $method_name && length $method_name)
1087             || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name );
1088 152         616 my $method = $fetch_and_prepare_method->($self, $method_name);
1089 150         1372 $method->add_before_modifier(
1090             set_subname(':before' => $method_modifier)
1091             );
1092             }
1093              
1094             sub add_after_method_modifier {
1095 51     51 1 260 my ($self, $method_name, $method_modifier) = @_;
1096 51 100 66     345 (defined $method_name && length $method_name)
1097             || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name );
1098 50         224 my $method = $fetch_and_prepare_method->($self, $method_name);
1099 50         567 $method->add_after_modifier(
1100             set_subname(':after' => $method_modifier)
1101             );
1102             }
1103              
1104             sub add_around_method_modifier {
1105 15332     15332 1 35099 my ($self, $method_name, $method_modifier) = @_;
1106 15332 100 66     57014 (defined $method_name && length $method_name)
1107             || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name );
1108 15331         36418 my $method = $fetch_and_prepare_method->($self, $method_name);
1109 15331         107479 $method->add_around_modifier(
1110             set_subname(':around' => $method_modifier)
1111             );
1112             }
1113              
1114             # NOTE:
1115             # the methods above used to be named like this:
1116             # ${pkg}::${method}:(before|after|around)
1117             # but this proved problematic when using one modifier
1118             # to wrap multiple methods (something which is likely
1119             # to happen pretty regularly IMO). So instead of naming
1120             # it like this, I have chosen to just name them purely
1121             # with their modifier names, like so:
1122             # :(before|after|around)
1123             # The fact is that in a stack trace, it will be fairly
1124             # evident from the context what method they are attached
1125             # to, and so don't need the fully qualified name.
1126             }
1127              
1128             sub find_method_by_name {
1129 35187     35187 1 98785 my ($self, $method_name) = @_;
1130 35187 100 66     135037 (defined $method_name && length $method_name)
1131             || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name );
1132 35186         78775 foreach my $class ($self->_method_lookup_order) {
1133 127800         261106 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1134 127800 100       328134 return $method if defined $method;
1135             }
1136 18079         51953 return;
1137             }
1138              
1139             sub get_all_methods {
1140 2624     2624 1 6042 my $self = shift;
1141              
1142 2624         4928 my %methods;
1143 2624         7644 for my $class ( reverse $self->_method_lookup_order ) {
1144 5502         15350 my $meta = Class::MOP::Class->initialize($class);
1145              
1146 5502         24775 $methods{ $_->name } = $_ for $meta->_get_local_methods;
1147             }
1148              
1149 2624         16785 return values %methods;
1150             }
1151              
1152             sub get_all_method_names {
1153 4     4 1 40 my $self = shift;
1154 4         12 map { $_->name } $self->get_all_methods;
  47         105  
1155             }
1156              
1157             sub find_all_methods_by_name {
1158 1526     1526 1 4698 my ($self, $method_name) = @_;
1159 1526 100 100     7687 (defined $method_name && length $method_name)
1160             || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name );
1161 1523         2875 my @methods;
1162 1523         4307 foreach my $class ($self->_method_lookup_order) {
1163             # fetch the meta-class ...
1164 5494         13671 my $meta = Class::MOP::Class->initialize($class);
1165 5494 100       18091 push @methods => {
1166             name => $method_name,
1167             class => $class,
1168             code => $meta->get_method($method_name)
1169             } if $meta->has_method($method_name);
1170             }
1171 1523         6996 return @methods;
1172             }
1173              
1174             sub find_next_method_by_name {
1175 30185     30185 1 62561 my ($self, $method_name) = @_;
1176 30185 100 66     117868 (defined $method_name && length $method_name)
1177             || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name );
1178 30184         66639 my @cpl = ($self->_method_lookup_order);
1179 30184         55836 shift @cpl; # discard ourselves
1180 30184         65336 foreach my $class (@cpl) {
1181 55833         123010 my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
1182 55833 100       177412 return $method if defined $method;
1183             }
1184 799         3094 return;
1185             }
1186              
1187             sub update_meta_instance_dependencies {
1188 3504     3504 0 6874 my $self = shift;
1189              
1190 3504 50       11601 if ( $self->{meta_instance_dependencies} ) {
1191 0         0 return $self->add_meta_instance_dependencies;
1192             }
1193             }
1194              
1195             sub add_meta_instance_dependencies {
1196 4     4 0 20 my $self = shift;
1197              
1198 4         12 $self->remove_meta_instance_dependencies;
1199              
1200 4         11 my @attrs = $self->get_all_attributes();
1201              
1202 4         8 my %seen;
1203 14         45 my @classes = grep { not $seen{ $_->name }++ }
1204 4         8 map { $_->associated_class } @attrs;
  14         33  
1205              
1206 4         13 foreach my $class (@classes) {
1207 9         16 $class->add_dependent_meta_instance($self);
1208             }
1209              
1210 4         14 $self->{meta_instance_dependencies} = \@classes;
1211             }
1212              
1213             sub remove_meta_instance_dependencies {
1214 4     4 0 8 my $self = shift;
1215              
1216 4 100       12 if ( my $classes = delete $self->{meta_instance_dependencies} ) {
1217 1         4 foreach my $class (@$classes) {
1218 3         8 $class->remove_dependent_meta_instance($self);
1219             }
1220              
1221 1         2 return $classes;
1222             }
1223              
1224 3         6 return;
1225              
1226             }
1227              
1228             sub add_dependent_meta_instance {
1229 9     9 0 17 my ( $self, $metaclass ) = @_;
1230 9         14 push @{ $self->{dependent_meta_instances} }, $metaclass;
  9         19  
1231             }
1232              
1233             sub remove_dependent_meta_instance {
1234 3     3 0 6 my ( $self, $metaclass ) = @_;
1235 3         7 my $name = $metaclass->name;
1236 6         20 @$_ = grep { $_->name ne $name } @$_
1237 3         8 for $self->{dependent_meta_instances};
1238             }
1239              
1240             sub invalidate_meta_instances {
1241 56825     56825 0 86325 my $self = shift;
1242             $_->invalidate_meta_instance()
1243 56825         80061 for $self, @{ $self->{dependent_meta_instances} };
  56825         182108  
1244             }
1245              
1246             sub invalidate_meta_instance {
1247 56828     56828 0 83658 my $self = shift;
1248 56828         139280 undef $self->{_meta_instance};
1249             }
1250              
1251             # check if we can reinitialize
1252             sub is_pristine {
1253 204     204 1 346 my $self = shift;
1254              
1255             # if any local attr is defined
1256 204 100       770 return if $self->get_attribute_list;
1257              
1258             # or any non-declared methods
1259 198         842 for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
  119         349  
1260 119 50       656 return if $method->isa("Class::MOP::Method::Generated");
1261             # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
1262             }
1263              
1264 198         564 return 1;
1265             }
1266              
1267             ## Class closing
1268              
1269 35157     35157 1 77713 sub is_mutable { 1 }
1270 19496     19496 1 93822 sub is_immutable { 0 }
1271              
1272 16 100   16 1 45 sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
  16         190  
1273              
1274             sub _immutable_options {
1275 22585     22585   48665 my ( $self, @args ) = @_;
1276              
1277             return (
1278 22585         217950 inline_accessors => 1,
1279             inline_constructor => 1,
1280             inline_destructor => 0,
1281             debug => 0,
1282             immutable_trait => $self->immutable_trait,
1283             constructor_name => $self->constructor_name,
1284             constructor_class => $self->constructor_class,
1285             destructor_class => $self->destructor_class,
1286             @args,
1287             );
1288             }
1289              
1290             sub make_immutable {
1291 22593     22593 1 89174 my ( $self, @args ) = @_;
1292              
1293 22593 100       50469 return $self unless $self->is_mutable;
1294              
1295 22585         99397 my ($file, $line) = (caller)[1..2];
1296              
1297 22585         58174 $self->_initialize_immutable(
1298             file => $file,
1299             line => $line,
1300             $self->_immutable_options(@args),
1301             );
1302 22583         99828 $self->_rebless_as_immutable(@args);
1303              
1304 22582         128640 return $self;
1305             }
1306              
1307             sub make_mutable {
1308 15     15 1 4822 my $self = shift;
1309              
1310 15 100       71 if ( $self->is_immutable ) {
1311 13         70 my @args = $self->immutable_options;
1312 13         86 $self->_rebless_as_mutable();
1313 13         72 $self->_remove_inlined_code(@args);
1314 13         85 delete $self->{__immutable};
1315 13         71 return $self;
1316             }
1317             else {
1318 2         13 return;
1319             }
1320             }
1321              
1322             sub _rebless_as_immutable {
1323 22583     22583   57234 my ( $self, @args ) = @_;
1324              
1325 22583         50455 $self->{__immutable}{original_class} = ref $self;
1326              
1327 22583         49912 bless $self => $self->_immutable_metaclass(@args);
1328             }
1329              
1330             sub _immutable_metaclass {
1331 22583     22583   63436 my ( $self, %args ) = @_;
1332              
1333 22583 50       59104 if ( my $class = $args{immutable_metaclass} ) {
1334 0         0 return $class;
1335             }
1336              
1337 22583   66     102337 my $trait = $args{immutable_trait} = $self->immutable_trait
1338             || $self->_throw_exception( NoImmutableTraitSpecifiedForClass => class_name => $self->name,
1339             params => \%args
1340             );
1341              
1342 22582         64388 my $meta = $self->meta;
1343 22582         66713 my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
1344              
1345 22582         37901 my $class_name;
1346              
1347 22582 100 66     80531 if ( $meta_attr and $trait eq $meta_attr->default ) {
1348             # if the trait is the same as the default we try and pick a
1349             # predictable name for the immutable metaclass
1350 22580         60543 $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
1351             }
1352             else {
1353 2         15 $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
1354             $trait, 'ForMetaClass', ref($self);
1355             }
1356              
1357 22582 100       57167 return $class_name
1358             if Class::MOP::does_metaclass_exist($class_name);
1359              
1360             # If the metaclass is a subclass of CMOP::Class which has had
1361             # metaclass roles applied (via Moose), then we want to make sure
1362             # that we preserve that anonymous class (see Fey::ORM for an
1363             # example of where this matters).
1364 681         3078 my $meta_name = $meta->_real_ref_name;
1365              
1366 681         4546 my $immutable_meta = $meta_name->create(
1367             $class_name,
1368             superclasses => [ ref $self ],
1369             );
1370              
1371 681         4618 Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
1372              
1373 681         6430 $immutable_meta->make_immutable(
1374             inline_constructor => 0,
1375             inline_accessors => 0,
1376             );
1377              
1378 681         2518 return $class_name;
1379             }
1380              
1381             sub _remove_inlined_code {
1382 13     13   32 my $self = shift;
1383              
1384 13         60 $self->remove_method( $_->name ) for $self->_inlined_methods;
1385              
1386 13         620 delete $self->{__immutable}{inlined_methods};
1387             }
1388              
1389 14 50   14   28 sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
  14         239  
1390              
1391             sub _add_inlined_method {
1392 12957     12957   27231 my ( $self, $method ) = @_;
1393              
1394 12957   100     19350 push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
  12957         80250  
1395             }
1396              
1397             sub _initialize_immutable {
1398 22585     22585   159212 my ( $self, %args ) = @_;
1399              
1400 22585         74215 $self->{__immutable}{options} = \%args;
1401 22585         106651 $self->_install_inlined_code(%args);
1402             }
1403              
1404             sub _install_inlined_code {
1405 22585     22585   98839 my ( $self, %args ) = @_;
1406              
1407             # FIXME
1408 22585 100       86382 $self->_inline_accessors(%args) if $args{inline_accessors};
1409 22585 100       96400 $self->_inline_constructor(%args) if $args{inline_constructor};
1410 22584 100       98610 $self->_inline_destructor(%args) if $args{inline_destructor};
1411             }
1412              
1413             sub _rebless_as_mutable {
1414 13     13   35 my $self = shift;
1415              
1416 13         58 bless $self, $self->_get_mutable_metaclass_name;
1417              
1418 13         29 return $self;
1419             }
1420              
1421             sub _inline_accessors {
1422 12603     12603   20938 my $self = shift;
1423              
1424 12603         40658 foreach my $attr_name ( $self->get_attribute_list ) {
1425 29353         86048 $self->get_attribute($attr_name)->install_accessors(1);
1426             }
1427             }
1428              
1429             sub _inline_constructor {
1430 12219     12219   73799 my ( $self, %args ) = @_;
1431              
1432 12219         26347 my $name = $args{constructor_name};
1433             # A class may not even have a constructor, and that's okay.
1434 12219 50       29448 return unless defined $name;
1435              
1436 12219 100 66     37671 if ( $self->has_method($name) && !$args{replace_constructor} ) {
1437 1         5 my $class = $self->name;
1438 1         18 warn "Not inlining a constructor for $class since it defines"
1439             . " its own constructor.\n"
1440             . "If you are certain you don't need to inline your"
1441             . " constructor, specify inline_constructor => 0 in your"
1442             . " call to $class->meta->make_immutable\n";
1443 1         8 return;
1444             }
1445              
1446 12218         23678 my $constructor_class = $args{constructor_class};
1447              
1448             {
1449 12218         18032 local $@;
  12218         18677  
1450 12218         38205 use_package_optimistically($constructor_class);
1451             }
1452              
1453             my $constructor = $constructor_class->new(
1454             options => \%args,
1455             metaclass => $self,
1456             is_inline => 1,
1457             package_name => $self->name,
1458             name => $name,
1459             definition_context => {
1460             description => "constructor " . $self->name . "::" . $name,
1461             file => $args{file},
1462             line => $args{line},
1463             },
1464 12218         838484 );
1465              
1466 12217 100 66     69350 if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
1467 12215         41302 $self->add_method( $name => $constructor );
1468 12215         39306 $self->_add_inlined_method($constructor);
1469             }
1470             }
1471              
1472             sub _inline_destructor {
1473 760     760   6428 my ( $self, %args ) = @_;
1474              
1475             ( exists $args{destructor_class} && defined $args{destructor_class} )
1476 760 100 66     6321 || $self->_throw_exception( NoDestructorClassSpecified => class_name => $self->name,
1477             params => \%args,
1478             );
1479              
1480 759 100 66     4386 if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
1481 1         5 my $class = $self->name;
1482 1         15 warn "Not inlining a destructor for $class since it defines"
1483             . " its own destructor.\n";
1484 1         10 return;
1485             }
1486              
1487 758         3060 my $destructor_class = $args{destructor_class};
1488              
1489             {
1490 758         2801 local $@;
  758         2818  
1491 758         3541 use_package_optimistically($destructor_class);
1492             }
1493              
1494 758 100       55130 return unless $destructor_class->is_needed($self);
1495              
1496             my $destructor = $destructor_class->new(
1497             options => \%args,
1498             metaclass => $self,
1499             package_name => $self->name,
1500             name => 'DESTROY',
1501             definition_context => {
1502             description => "destructor " . $self->name . "::DESTROY",
1503             file => $args{file},
1504             line => $args{line},
1505             },
1506 742         12233 );
1507              
1508 742 50 33     6567 if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
1509 742         3875 $self->add_method( 'DESTROY' => $destructor );
1510 742         3446 $self->_add_inlined_method($destructor);
1511             }
1512             }
1513              
1514             1;
1515              
1516             # ABSTRACT: Class Meta Object
1517              
1518             __END__
1519              
1520             =pod
1521              
1522             =encoding UTF-8
1523              
1524             =head1 NAME
1525              
1526             Class::MOP::Class - Class Meta Object
1527              
1528             =head1 VERSION
1529              
1530             version 2.2206
1531              
1532             =head1 SYNOPSIS
1533              
1534             # assuming that class Foo
1535             # has been defined, you can
1536              
1537             # use this for introspection ...
1538              
1539             # add a method to Foo ...
1540             Foo->meta->add_method( 'bar' => sub {...} )
1541              
1542             # get a list of all the classes searched
1543             # the method dispatcher in the correct order
1544             Foo->meta->class_precedence_list()
1545              
1546             # remove a method from Foo
1547             Foo->meta->remove_method('bar');
1548              
1549             # or use this to actually create classes ...
1550              
1551             Class::MOP::Class->create(
1552             'Bar' => (
1553             version => '0.01',
1554             superclasses => ['Foo'],
1555             attributes => [
1556             Class::MOP::Attribute->new('$bar'),
1557             Class::MOP::Attribute->new('$baz'),
1558             ],
1559             methods => {
1560             calculate_bar => sub {...},
1561             construct_baz => sub {...}
1562             }
1563             )
1564             );
1565              
1566             =head1 DESCRIPTION
1567              
1568             The Class Protocol is the largest and most complex part of the
1569             Class::MOP meta-object protocol. It controls the introspection and
1570             manipulation of Perl 5 classes, and it can create them as well. The
1571             best way to understand what this module can do is to read the
1572             documentation for each of its methods.
1573              
1574             =head1 INHERITANCE
1575              
1576             C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
1577              
1578             =head1 METHODS
1579              
1580             =head2 Class construction
1581              
1582             These methods all create new C<Class::MOP::Class> objects. These
1583             objects can represent existing classes or they can be used to create
1584             new classes from scratch.
1585              
1586             The metaclass object for a given class is a singleton. If you attempt
1587             to create a metaclass for the same class twice, you will just get the
1588             existing object.
1589              
1590             =over 4
1591              
1592             =item B<< Class::MOP::Class->create($package_name, %options) >>
1593              
1594             This method creates a new C<Class::MOP::Class> object with the given
1595             package name. It accepts a number of options:
1596              
1597             =over 8
1598              
1599             =item * version
1600              
1601             An optional version number for the newly created package.
1602              
1603             =item * authority
1604              
1605             An optional authority for the newly created package.
1606             See L<Class::MOP::Module/authority> for more details.
1607              
1608             =item * superclasses
1609              
1610             An optional array reference of superclass names.
1611              
1612             =item * methods
1613              
1614             An optional hash reference of methods for the class. The keys of the
1615             hash reference are method names and values are subroutine references.
1616              
1617             =item * attributes
1618              
1619             An optional array reference of L<Class::MOP::Attribute> objects.
1620              
1621             =item * meta_name
1622              
1623             Specifies the name to install the C<meta> method for this class under.
1624             If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
1625             given, no meta method will be installed.
1626              
1627             =item * weaken
1628              
1629             If true, the metaclass that is stored in the global cache will be a
1630             weak reference.
1631              
1632             Classes created in this way are destroyed once the metaclass they are
1633             attached to goes out of scope, and will be removed from Perl's internal
1634             symbol table.
1635              
1636             All instances of a class with a weakened metaclass keep a special
1637             reference to the metaclass object, which prevents the metaclass from
1638             going out of scope while any instances exist.
1639              
1640             This only works if the instance is based on a hash reference, however.
1641              
1642             =back
1643              
1644             =item B<< Class::MOP::Class->create_anon_class(%options) >>
1645              
1646             This method works just like C<< Class::MOP::Class->create >> but it
1647             creates an "anonymous" class. In fact, the class does have a name, but
1648             that name is a unique name generated internally by this module.
1649              
1650             It accepts the same C<superclasses>, C<methods>, and C<attributes>
1651             parameters that C<create> accepts.
1652              
1653             It also accepts a C<cache> option. If this is C<true>, then the anonymous class
1654             will be cached based on its superclasses and roles. If an existing anonymous
1655             class in the cache has the same superclasses and roles, it will be reused.
1656              
1657             Anonymous classes default to C<< weaken => 1 >> if cache is C<false>, although
1658             this can be overridden.
1659              
1660             =item B<< Class::MOP::Class->initialize($package_name, %options) >>
1661              
1662             This method will initialize a C<Class::MOP::Class> object for the
1663             named package. Unlike C<create>, this method I<will not> create a new
1664             class.
1665              
1666             The purpose of this method is to retrieve a C<Class::MOP::Class>
1667             object for introspecting an existing class.
1668              
1669             If an existing C<Class::MOP::Class> object exists for the named
1670             package, it will be returned, and any options provided will be
1671             ignored!
1672              
1673             If the object does not yet exist, it will be created.
1674              
1675             The valid options that can be passed to this method are
1676             C<attribute_metaclass>, C<method_metaclass>,
1677             C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
1678             optional, and default to the appropriate class in the C<Class::MOP>
1679             distribution.
1680              
1681             =back
1682              
1683             =head2 Object instance construction and cloning
1684              
1685             These methods are all related to creating and/or cloning object
1686             instances.
1687              
1688             =over 4
1689              
1690             =item B<< $metaclass->clone_object($instance, %params) >>
1691              
1692             This method clones an existing object instance. Any parameters you
1693             provide are will override existing attribute values in the object.
1694              
1695             This is a convenience method for cloning an object instance, then
1696             blessing it into the appropriate package.
1697              
1698             You could implement a clone method in your class, using this method:
1699              
1700             sub clone {
1701             my ($self, %params) = @_;
1702             $self->meta->clone_object($self, %params);
1703             }
1704              
1705             =item B<< $metaclass->rebless_instance($instance, %params) >>
1706              
1707             This method changes the class of C<$instance> to the metaclass's class.
1708              
1709             You can only rebless an instance into a subclass of its current
1710             class. If you pass any additional parameters, these will be treated
1711             like constructor parameters and used to initialize the object's
1712             attributes. Any existing attributes that are already set will be
1713             overwritten.
1714              
1715             Before reblessing the instance, this method will call
1716             C<rebless_instance_away> on the instance's current metaclass. This method
1717             will be passed the instance, the new metaclass, and any parameters
1718             specified to C<rebless_instance>. By default, C<rebless_instance_away>
1719             does nothing; it is merely a hook.
1720              
1721             =item B<< $metaclass->rebless_instance_back($instance) >>
1722              
1723             Does the same thing as C<rebless_instance>, except that you can only
1724             rebless an instance into one of its superclasses. Any attributes that
1725             do not exist in the superclass will be deinitialized.
1726              
1727             This is a much more dangerous operation than C<rebless_instance>,
1728             especially when multiple inheritance is involved, so use this carefully!
1729              
1730             =item B<< $metaclass->new_object(%params) >>
1731              
1732             This method is used to create a new object of the metaclass's
1733             class. Any parameters you provide are used to initialize the
1734             instance's attributes. A special C<__INSTANCE__> key can be passed to
1735             provide an already generated instance, rather than having Class::MOP
1736             generate it for you. This is mostly useful for using Class::MOP with
1737             foreign classes which generate instances using their own constructors.
1738              
1739             =item B<< $metaclass->instance_metaclass >>
1740              
1741             Returns the class name of the instance metaclass. See
1742             L<Class::MOP::Instance> for more information on the instance
1743             metaclass.
1744              
1745             =item B<< $metaclass->get_meta_instance >>
1746              
1747             Returns an instance of the C<instance_metaclass> to be used in the
1748             construction of a new instance of the class.
1749              
1750             =back
1751              
1752             =head2 Informational predicates
1753              
1754             These are a few predicate methods for asking information about the
1755             class itself.
1756              
1757             =over 4
1758              
1759             =item B<< $metaclass->is_anon_class >>
1760              
1761             This returns true if the class was created by calling C<<
1762             Class::MOP::Class->create_anon_class >>.
1763              
1764             =item B<< $metaclass->is_mutable >>
1765              
1766             This returns true if the class is still mutable.
1767              
1768             =item B<< $metaclass->is_immutable >>
1769              
1770             This returns true if the class has been made immutable.
1771              
1772             =item B<< $metaclass->is_pristine >>
1773              
1774             A class is I<not> pristine if it has non-inherited attributes or if it
1775             has any generated methods.
1776              
1777             =back
1778              
1779             =head2 Inheritance Relationships
1780              
1781             =over 4
1782              
1783             =item B<< $metaclass->superclasses(@superclasses) >>
1784              
1785             This is a read-write accessor which represents the superclass
1786             relationships of the metaclass's class.
1787              
1788             This is basically sugar around getting and setting C<@ISA>.
1789              
1790             =item B<< $metaclass->class_precedence_list >>
1791              
1792             This returns a list of all of the class's ancestor classes. The
1793             classes are returned in method dispatch order.
1794              
1795             =item B<< $metaclass->linearized_isa >>
1796              
1797             This returns a list based on C<class_precedence_list> but with all
1798             duplicates removed.
1799              
1800             =item B<< $metaclass->subclasses >>
1801              
1802             This returns a list of all subclasses for this class, even indirect
1803             subclasses.
1804              
1805             =item B<< $metaclass->direct_subclasses >>
1806              
1807             This returns a list of immediate subclasses for this class, which does not
1808             include indirect subclasses.
1809              
1810             =back
1811              
1812             =head2 Method introspection and creation
1813              
1814             These methods allow you to introspect a class's methods, as well as
1815             add, remove, or change methods.
1816              
1817             Determining what is truly a method in a Perl 5 class requires some
1818             heuristics (aka guessing).
1819              
1820             Methods defined outside the package with a fully qualified name (C<sub
1821             Package::name { ... }>) will be included. Similarly, methods named with a
1822             fully qualified name using L<Sub::Util> are also included.
1823              
1824             However, we attempt to ignore imported functions.
1825              
1826             Ultimately, we are using heuristics to determine what truly is a
1827             method in a class, and these heuristics may get the wrong answer in
1828             some edge cases. However, for most "normal" cases the heuristics work
1829             correctly.
1830              
1831             =over 4
1832              
1833             =item B<< $metaclass->get_method($method_name) >>
1834              
1835             This will return a L<Class::MOP::Method> for the specified
1836             C<$method_name>. If the class does not have the specified method, it
1837             returns C<undef>
1838              
1839             =item B<< $metaclass->has_method($method_name) >>
1840              
1841             Returns a boolean indicating whether or not the class defines the
1842             named method. It does not include methods inherited from parent
1843             classes.
1844              
1845             =item B<< $metaclass->get_method_list >>
1846              
1847             This will return a list of method I<names> for all methods defined in
1848             this class.
1849              
1850             =item B<< $metaclass->add_method($method_name, $method) >>
1851              
1852             This method takes a method name and a subroutine reference, and adds
1853             the method to the class.
1854              
1855             The subroutine reference can be a L<Class::MOP::Method>, and you are
1856             strongly encouraged to pass a meta method object instead of a code
1857             reference. If you do so, that object gets stored as part of the
1858             class's method map directly. If not, the meta information will have to
1859             be recreated later, and may be incorrect.
1860              
1861             If you provide a method object, this method will clone that object if
1862             the object's package name does not match the class name. This lets us
1863             track the original source of any methods added from other classes
1864             (notably Moose roles).
1865              
1866             =item B<< $metaclass->remove_method($method_name) >>
1867              
1868             Remove the named method from the class. This method returns the
1869             L<Class::MOP::Method> object for the method.
1870              
1871             =item B<< $metaclass->method_metaclass >>
1872              
1873             Returns the class name of the method metaclass, see
1874             L<Class::MOP::Method> for more information on the method metaclass.
1875              
1876             =item B<< $metaclass->wrapped_method_metaclass >>
1877              
1878             Returns the class name of the wrapped method metaclass, see
1879             L<Class::MOP::Method::Wrapped> for more information on the wrapped
1880             method metaclass.
1881              
1882             =item B<< $metaclass->get_all_methods >>
1883              
1884             This will traverse the inheritance hierarchy and return a list of all
1885             the L<Class::MOP::Method> objects for this class and its parents.
1886              
1887             =item B<< $metaclass->find_method_by_name($method_name) >>
1888              
1889             This will return a L<Class::MOP::Method> for the specified
1890             C<$method_name>. If the class does not have the specified method, it
1891             returns C<undef>
1892              
1893             Unlike C<get_method>, this method I<will> look for the named method in
1894             superclasses.
1895              
1896             =item B<< $metaclass->get_all_method_names >>
1897              
1898             This will return a list of method I<names> for all of this class's
1899             methods, including inherited methods.
1900              
1901             =item B<< $metaclass->find_all_methods_by_name($method_name) >>
1902              
1903             This method looks for the named method in the class and all of its
1904             parents. It returns every matching method it finds in the inheritance
1905             tree, so it returns a list of methods.
1906              
1907             Each method is returned as a hash reference with three keys. The keys
1908             are C<name>, C<class>, and C<code>. The C<code> key has a
1909             L<Class::MOP::Method> object as its value.
1910              
1911             The list of methods is distinct.
1912              
1913             =item B<< $metaclass->find_next_method_by_name($method_name) >>
1914              
1915             This method returns the first method in any superclass matching the
1916             given name. It is effectively the method that C<SUPER::$method_name>
1917             would dispatch to.
1918              
1919             =back
1920              
1921             =head2 Attribute introspection and creation
1922              
1923             Because Perl 5 does not have a core concept of attributes in classes,
1924             we can only return information about attributes which have been added
1925             via this class's methods. We cannot discover information about
1926             attributes which are defined in terms of "regular" Perl 5 methods.
1927              
1928             =over 4
1929              
1930             =item B<< $metaclass->get_attribute($attribute_name) >>
1931              
1932             This will return a L<Class::MOP::Attribute> for the specified
1933             C<$attribute_name>. If the class does not have the specified
1934             attribute, it returns C<undef>.
1935              
1936             NOTE that get_attribute does not search superclasses, for that you
1937             need to use C<find_attribute_by_name>.
1938              
1939             =item B<< $metaclass->has_attribute($attribute_name) >>
1940              
1941             Returns a boolean indicating whether or not the class defines the
1942             named attribute. It does not include attributes inherited from parent
1943             classes.
1944              
1945             =item B<< $metaclass->get_attribute_list >>
1946              
1947             This will return a list of attributes I<names> for all attributes
1948             defined in this class. Note that this operates on the current class
1949             only, it does not traverse the inheritance hierarchy.
1950              
1951             =item B<< $metaclass->get_all_attributes >>
1952              
1953             This will traverse the inheritance hierarchy and return a list of all
1954             the L<Class::MOP::Attribute> objects for this class and its parents.
1955              
1956             =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
1957              
1958             This will return a L<Class::MOP::Attribute> for the specified
1959             C<$attribute_name>. If the class does not have the specified
1960             attribute, it returns C<undef>.
1961              
1962             Unlike C<get_attribute>, this attribute I<will> look for the named
1963             attribute in superclasses.
1964              
1965             =item B<< $metaclass->add_attribute(...) >>
1966              
1967             This method accepts either an existing L<Class::MOP::Attribute>
1968             object or parameters suitable for passing to that class's C<new>
1969             method.
1970              
1971             The attribute provided will be added to the class.
1972              
1973             Any accessor methods defined by the attribute will be added to the
1974             class when the attribute is added.
1975              
1976             If an attribute of the same name already exists, the old attribute
1977             will be removed first.
1978              
1979             =item B<< $metaclass->remove_attribute($attribute_name) >>
1980              
1981             This will remove the named attribute from the class, and
1982             L<Class::MOP::Attribute> object.
1983              
1984             Removing an attribute also removes any accessor methods defined by the
1985             attribute.
1986              
1987             However, note that removing an attribute will only affect I<future>
1988             object instances created for this class, not existing instances.
1989              
1990             =item B<< $metaclass->attribute_metaclass >>
1991              
1992             Returns the class name of the attribute metaclass for this class. By
1993             default, this is L<Class::MOP::Attribute>.
1994              
1995             =back
1996              
1997             =head2 Overload introspection and creation
1998              
1999             These methods provide an API to the core L<overload> functionality.
2000              
2001             =over 4
2002              
2003             =item B<< $metaclass->is_overloaded >>
2004              
2005             Returns true if overloading is enabled for this class. Corresponds to
2006             L<Devel::OverloadInfo/is_overloaded>.
2007              
2008             =item B<< $metaclass->get_overloaded_operator($op) >>
2009              
2010             Returns the L<Class::MOP::Overload> object corresponding to the operator named
2011             C<$op>, if one exists for this class.
2012              
2013             =item B<< $metaclass->has_overloaded_operator($op) >>
2014              
2015             Returns whether or not the operator C<$op> is overloaded for this class.
2016              
2017             =item B<< $metaclass->get_overload_list >>
2018              
2019             Returns a list of operator names which have been overloaded (see
2020             L<overload/Overloadable Operations> for the list of valid operator names).
2021              
2022             =item B<< $metaclass->get_all_overloaded_operators >>
2023              
2024             Returns a list of L<Class::MOP::Overload> objects corresponding to the
2025             operators that have been overloaded.
2026              
2027             =item B<< $metaclass->add_overloaded_operator($op, $impl) >>
2028              
2029             Overloads the operator C<$op> for this class. The C<$impl> can be a coderef, a
2030             method name, or a L<Class::MOP::Overload> object. Corresponds to
2031             C<< use overload $op => $impl; >>
2032              
2033             =item B<< $metaclass->remove_overloaded_operator($op) >>
2034              
2035             Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >>
2036              
2037             =item B<< $metaclass->get_overload_fallback_value >>
2038              
2039             Returns the overload C<fallback> setting for the package.
2040              
2041             =item B<< $metaclass->set_overload_fallback_value($fallback) >>
2042              
2043             Sets the overload C<fallback> setting for the package.
2044              
2045             =back
2046              
2047             =head2 Class Immutability
2048              
2049             Making a class immutable "freezes" the class definition. You can no
2050             longer call methods which alter the class, such as adding or removing
2051             methods or attributes.
2052              
2053             Making a class immutable lets us optimize the class by inlining some
2054             methods, and also allows us to optimize some methods on the metaclass
2055             object itself.
2056              
2057             After immutabilization, the metaclass object will cache most informational
2058             methods that returns information about methods or attributes. Methods which
2059             would alter the class, such as C<add_attribute> and C<add_method>, will
2060             throw an error on an immutable metaclass object.
2061              
2062             The immutabilization system in L<Moose> takes much greater advantage
2063             of the inlining features than Class::MOP itself does.
2064              
2065             =over 4
2066              
2067             =item B<< $metaclass->make_immutable(%options) >>
2068              
2069             This method will create an immutable transformer and use it to make
2070             the class and its metaclass object immutable, and returns true
2071             (you should not rely on the details of this value apart from its truth).
2072              
2073             This method accepts the following options:
2074              
2075             =over 8
2076              
2077             =item * inline_accessors
2078              
2079             =item * inline_constructor
2080              
2081             =item * inline_destructor
2082              
2083             These are all booleans indicating whether the specified method(s)
2084             should be inlined.
2085              
2086             By default, accessors and the constructor are inlined, but not the
2087             destructor.
2088              
2089             =item * immutable_trait
2090              
2091             The name of a class which will be used as a parent class for the
2092             metaclass object being made immutable. This "trait" implements the
2093             post-immutability functionality of the metaclass (but not the
2094             transformation itself).
2095              
2096             This defaults to L<Class::MOP::Class::Immutable::Trait>.
2097              
2098             =item * constructor_name
2099              
2100             This is the constructor method name. This defaults to "new".
2101              
2102             =item * constructor_class
2103              
2104             The name of the method metaclass for constructors. It will be used to
2105             generate the inlined constructor. This defaults to
2106             "Class::MOP::Method::Constructor".
2107              
2108             =item * replace_constructor
2109              
2110             This is a boolean indicating whether an existing constructor should be
2111             replaced when inlining a constructor. This defaults to false.
2112              
2113             =item * destructor_class
2114              
2115             The name of the method metaclass for destructors. It will be used to
2116             generate the inlined destructor. This defaults to
2117             "Class::MOP::Method::Denstructor".
2118              
2119             =item * replace_destructor
2120              
2121             This is a boolean indicating whether an existing destructor should be
2122             replaced when inlining a destructor. This defaults to false.
2123              
2124             =back
2125              
2126             =item B<< $metaclass->immutable_options >>
2127              
2128             Returns a hash of the options used when making the class immutable, including
2129             both defaults and anything supplied by the user in the call to C<<
2130             $metaclass->make_immutable >>. This is useful if you need to temporarily make
2131             a class mutable and then restore immutability as it was before.
2132              
2133             =item B<< $metaclass->make_mutable >>
2134              
2135             Calling this method reverse the immutabilization transformation.
2136              
2137             =back
2138              
2139             =head2 Method Modifiers
2140              
2141             Method modifiers are hooks which allow a method to be wrapped with
2142             I<before>, I<after> and I<around> method modifiers. Every time a
2143             method is called, its modifiers are also called.
2144              
2145             A class can modify its own methods, as well as methods defined in
2146             parent classes.
2147              
2148             =head3 How method modifiers work?
2149              
2150             Method modifiers work by wrapping the original method and then
2151             replacing it in the class's symbol table. The wrappers will handle
2152             calling all the modifiers in the appropriate order and preserving the
2153             calling context for the original method.
2154              
2155             The return values of C<before> and C<after> modifiers are
2156             ignored. This is because their purpose is B<not> to filter the input
2157             and output of the primary method (this is done with an I<around>
2158             modifier).
2159              
2160             This may seem like an odd restriction to some, but doing this allows
2161             for simple code to be added at the beginning or end of a method call
2162             without altering the function of the wrapped method or placing any
2163             extra responsibility on the code of the modifier.
2164              
2165             Of course if you have more complex needs, you can use the C<around>
2166             modifier which allows you to change both the parameters passed to the
2167             wrapped method, as well as its return value.
2168              
2169             Before and around modifiers are called in last-defined-first-called
2170             order, while after modifiers are called in first-defined-first-called
2171             order. So the call tree might looks something like this:
2172              
2173             before 2
2174             before 1
2175             around 2
2176             around 1
2177             primary
2178             around 1
2179             around 2
2180             after 1
2181             after 2
2182              
2183             =head3 What is the performance impact?
2184              
2185             Of course there is a performance cost associated with method
2186             modifiers, but we have made every effort to make that cost directly
2187             proportional to the number of modifier features you use.
2188              
2189             The wrapping method does its best to B<only> do as much work as it
2190             absolutely needs to. In order to do this we have moved some of the
2191             performance costs to set-up time, where they are easier to amortize.
2192              
2193             All this said, our benchmarks have indicated the following:
2194              
2195             simple wrapper with no modifiers 100% slower
2196             simple wrapper with simple before modifier 400% slower
2197             simple wrapper with simple after modifier 450% slower
2198             simple wrapper with simple around modifier 500-550% slower
2199             simple wrapper with all 3 modifiers 1100% slower
2200              
2201             These numbers may seem daunting, but you must remember, every feature
2202             comes with some cost. To put things in perspective, just doing a
2203             simple C<AUTOLOAD> which does nothing but extract the name of the
2204             method called and return it costs about 400% over a normal method
2205             call.
2206              
2207             =over 4
2208              
2209             =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
2210              
2211             This wraps the specified method with the supplied subroutine
2212             reference. The modifier will be called as a method itself, and will
2213             receive the same arguments as are passed to the method.
2214              
2215             When the modifier exits, the wrapped method will be called.
2216              
2217             The return value of the modifier will be ignored.
2218              
2219             =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
2220              
2221             This wraps the specified method with the supplied subroutine
2222             reference. The modifier will be called as a method itself, and will
2223             receive the same arguments as are passed to the method.
2224              
2225             When the wrapped methods exits, the modifier will be called.
2226              
2227             The return value of the modifier will be ignored.
2228              
2229             =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
2230              
2231             This wraps the specified method with the supplied subroutine
2232             reference.
2233              
2234             The first argument passed to the modifier will be a subroutine
2235             reference to the wrapped method. The second argument is the object,
2236             and after that come any arguments passed when the method is called.
2237              
2238             The around modifier can choose to call the original method, as well as
2239             what arguments to pass if it does so.
2240              
2241             The return value of the modifier is what will be seen by the caller.
2242              
2243             =back
2244              
2245             =head2 Introspection
2246              
2247             =over 4
2248              
2249             =item B<< Class::MOP::Class->meta >>
2250              
2251             This will return a L<Class::MOP::Class> instance for this class.
2252              
2253             It should also be noted that L<Class::MOP> will actually bootstrap
2254             this module by installing a number of attribute meta-objects into its
2255             metaclass.
2256              
2257             =back
2258              
2259             =head1 AUTHORS
2260              
2261             =over 4
2262              
2263             =item *
2264              
2265             Stevan Little <stevan@cpan.org>
2266              
2267             =item *
2268              
2269             Dave Rolsky <autarch@urth.org>
2270              
2271             =item *
2272              
2273             Jesse Luehrs <doy@cpan.org>
2274              
2275             =item *
2276              
2277             Shawn M Moore <sartak@cpan.org>
2278              
2279             =item *
2280              
2281             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
2282              
2283             =item *
2284              
2285             Karen Etheridge <ether@cpan.org>
2286              
2287             =item *
2288              
2289             Florian Ragwitz <rafl@debian.org>
2290              
2291             =item *
2292              
2293             Hans Dieter Pearcey <hdp@cpan.org>
2294              
2295             =item *
2296              
2297             Chris Prather <chris@prather.org>
2298              
2299             =item *
2300              
2301             Matt S Trout <mstrout@cpan.org>
2302              
2303             =back
2304              
2305             =head1 COPYRIGHT AND LICENSE
2306              
2307             This software is copyright (c) 2006 by Infinity Interactive, Inc.
2308              
2309             This is free software; you can redistribute it and/or modify it under
2310             the same terms as the Perl 5 programming language system itself.
2311              
2312             =cut