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