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