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