Version 0.40_01
[gitmo/Mouse.git] / lib / Mouse / Meta / Class.pm
CommitLineData
306290e8 1package Mouse::Meta::Class;
bc69ee88 2use Mouse::Util qw/:meta get_linear_isa not_supported/; # enables strict and warnings
c3398f5b 3
cecfb973 4use Scalar::Util qw/blessed weaken/;
6d28c5cf 5
6d28c5cf 6use Mouse::Meta::Method::Constructor;
7use Mouse::Meta::Method::Destructor;
8use Mouse::Meta::Module;
f3bb863f 9our @ISA = qw(Mouse::Meta::Module);
3a63a2e7 10
deb9a0f3 11sub method_metaclass() { 'Mouse::Meta::Method' }
12sub attribute_metaclass() { 'Mouse::Meta::Attribute' }
3a63a2e7 13
380e1cd7 14sub constructor_class() { 'Mouse::Meta::Method::Constructor' }
15sub destructor_class() { 'Mouse::Meta::Method::Destructor' }
16
8e64d0fa 17sub _construct_meta {
88ed7189 18 my($class, %args) = @_;
c3398f5b 19
8536d351 20 $args{attributes} ||= {};
21 $args{methods} ||= {};
22 $args{roles} ||= [];
23
c3398f5b 24 $args{superclasses} = do {
25 no strict 'refs';
88ed7189 26 \@{ $args{package} . '::ISA' };
c3398f5b 27 };
28
8d40c3b8 29 my $self = bless \%args, ref($class) || $class;
7eb3a8d5 30 if(ref($self) ne __PACKAGE__){
9009aca1 31 $self->meta->_initialize_object($self, \%args);
8d40c3b8 32 }
33 return $self;
7a50b450 34}
35
36sub create_anon_class{
37 my $self = shift;
38 return $self->create(undef, @_);
39}
40
43165725 41sub is_anon_class;
c3398f5b 42
43165725 43sub roles;
c3398f5b 44
e7264861 45sub calculate_all_roles {
46 my $self = shift;
47 my %seen;
48 return grep { !$seen{ $_->name }++ }
49 map { $_->calculate_all_roles } @{ $self->roles };
50}
51
c3398f5b 52sub superclasses {
53 my $self = shift;
54
55 if (@_) {
9d0686b2 56 foreach my $super(@_){
57 Mouse::Util::load_class($super);
58 my $meta = Mouse::Util::get_metaclass_by_name($super);
59 if($meta && $meta->isa('Mouse::Meta::Role')){
60 $self->throw_error("You cannot inherit from a Mouse Role ($super)");
61 }
62 }
c3398f5b 63 @{ $self->{superclasses} } = @_;
64 }
65
8e64d0fa 66 return @{ $self->{superclasses} };
67}
68
69sub find_method_by_name{
70 my($self, $method_name) = @_;
71 defined($method_name)
72 or $self->throw_error('You must define a method name to find');
0126c27c 73
8e64d0fa 74 foreach my $class( $self->linearized_isa ){
75 my $method = $self->initialize($class)->get_method($method_name);
76 return $method if defined $method;
77 }
78 return undef;
79}
80
81sub get_all_methods {
82 my($self) = @_;
612d3e1a 83 return map{ $self->find_method_by_name($_) } $self->get_all_method_names;
c3398f5b 84}
85
60cfc6ad 86sub get_all_method_names {
87 my $self = shift;
88 my %uniq;
89 return grep { $uniq{$_}++ == 0 }
3a63a2e7 90 map { Mouse::Meta::Class->initialize($_)->get_method_list() }
60cfc6ad 91 $self->linearized_isa;
92}
93
2b908b79 94sub find_attribute_by_name{
95 my($self, $name) = @_;
96 my $attr;
97 foreach my $class($self->linearized_isa){
98 my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
99 $attr = $meta->get_attribute($name) and last;
100 }
101 return $attr;
102}
103
87ca293b 104sub add_attribute {
c3398f5b 105 my $self = shift;
60f6eba9 106
87ca293b 107 my($attr, $name);
1b9e472d 108
87ca293b 109 if(blessed $_[0]){
110 $attr = $_[0];
1b9e472d 111
87ca293b 112 $attr->isa('Mouse::Meta::Attribute')
113 || $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)");
1b9e472d 114
87ca293b 115 $name = $attr->name;
1b9e472d 116 }
117 else{
87ca293b 118 # _process_attribute
119 $name = shift;
1b9e472d 120
87ca293b 121 my %args = (@_ == 1) ? %{$_[0]} : @_;
1b9e472d 122
87ca293b 123 defined($name)
124 or $self->throw_error('You must provide a name for the attribute');
1b9e472d 125
87ca293b 126 if ($name =~ s/^\+//) { # inherited attributes
2b908b79 127 my $inherited_attr = $self->find_attribute_by_name($name)
87ca293b 128 or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name);
129
8cf51b82 130 $attr = $inherited_attr->clone_and_inherit_options(%args);
87ca293b 131 }
132 else{
8cf51b82 133 my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args);
87ca293b 134 $args{traits} = \@traits if @traits;
135
2a464664 136 $attr = $attribute_class->new($name, %args);
87ca293b 137 }
138 }
1b9e472d 139
140 weaken( $attr->{associated_class} = $self );
141
142 $self->{attributes}{$attr->name} = $attr;
143 $attr->install_accessors();
144
04493075 145 if(_MOUSE_VERBOSE && !$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){
1b9e472d 146 Carp::cluck(qq{Attribute (}.$attr->name.qq{) of class }.$self->name.qq{ has no associated methods (did you mean to provide an "is" argument?)});
60f6eba9 147 }
1b9e472d 148 return $attr;
c3398f5b 149}
150
3a683350 151sub compute_all_applicable_attributes {
0126c27c 152 Carp::cluck('compute_all_applicable_attributes() has been deprecated')
153 if _MOUSE_VERBOSE;
3a683350 154 return shift->get_all_attributes(@_)
155}
156
d60824af 157sub get_all_attributes {
72b88a88 158 my $self = shift;
159 my (@attr, %seen);
160
161 for my $class ($self->linearized_isa) {
3a683350 162 my $meta = Mouse::Util::get_metaclass_by_name($class)
72b88a88 163 or next;
164
3a683350 165 for my $name ($meta->get_attribute_list) {
72b88a88 166 next if $seen{$name}++;
167 push @attr, $meta->get_attribute($name);
168 }
169 }
170
171 return @attr;
172}
173
cccb83de 174sub linearized_isa;
8536d351 175
176sub new_object {
c68b4110 177 my $self = shift;
7a50b450 178 my %args = (@_ == 1 ? %{$_[0]} : @_);
c3398f5b 179
926290ac 180 my $object = bless {}, $self->name;
fce211ae 181
926290ac 182 $self->_initialize_object($object, \%args);
183 return $object;
1b9e472d 184}
185
926290ac 186sub _initialize_object{
187 my($self, $object, $args) = @_;
1b9e472d 188
53c495ce 189 my @triggers_queue;
190
fce211ae 191 foreach my $attribute ($self->get_all_attributes) {
8536d351 192 my $from = $attribute->init_arg;
193 my $key = $attribute->name;
194
1b9e472d 195 if (defined($from) && exists($args->{$from})) {
4331a3f9 196 $object->{$key} = $attribute->_coerce_and_verify($args->{$from}, $object);
8536d351 197
926290ac 198 weaken($object->{$key})
199 if ref($object->{$key}) && $attribute->is_weak_ref;
8536d351 200
201 if ($attribute->has_trigger) {
926290ac 202 push @triggers_queue, [ $attribute->trigger, $object->{$key} ];
8536d351 203 }
204 }
205 else {
206 if ($attribute->has_default || $attribute->has_builder) {
207 unless ($attribute->is_lazy) {
208 my $default = $attribute->default;
209 my $builder = $attribute->builder;
926290ac 210 my $value = $builder ? $object->$builder()
211 : ref($default) eq 'CODE' ? $object->$default()
8215d725 212 : $default;
8536d351 213
4331a3f9 214 $object->{$key} = $attribute->_coerce_and_verify($value, $object);
8536d351 215
926290ac 216 weaken($object->{$key})
217 if ref($object->{$key}) && $attribute->is_weak_ref;
8536d351 218 }
219 }
220 else {
221 if ($attribute->is_required) {
fce211ae 222 $self->throw_error("Attribute (".$attribute->name.") is required");
8536d351 223 }
224 }
225 }
226 }
53c495ce 227
228 foreach my $trigger_and_value(@triggers_queue){
229 my($trigger, $value) = @{$trigger_and_value};
926290ac 230 $trigger->($object, $value);
53c495ce 231 }
232
2efc0af1 233 if($self->is_anon_class){
926290ac 234 $object->{__METACLASS__} = $self;
2efc0af1 235 }
236
926290ac 237 return $object;
8536d351 238}
c3398f5b 239
7a59f4e8 240sub clone_object {
926290ac 241 my $class = shift;
242 my $object = shift;
243 my %params = (@_ == 1) ? %{$_[0]} : @_;
7a59f4e8 244
926290ac 245 (blessed($object) && $object->isa($class->name))
246 || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
7a59f4e8 247
926290ac 248 my $cloned = bless { %$object }, ref $object;
249 $class->_initialize_object($cloned, \%params);
7a59f4e8 250
926290ac 251 return $cloned;
2cea7a5f 252}
7a59f4e8 253
2cea7a5f 254sub clone_instance {
255 my ($class, $instance, %params) = @_;
256
04493075 257 Carp::cluck('clone_instance has been deprecated. Use clone_object instead')
258 if _MOUSE_VERBOSE;
2cea7a5f 259 return $class->clone_object($instance, %params);
7a59f4e8 260}
261
fc1d8369 262sub make_immutable {
263 my $self = shift;
6a1d1835 264 my %args = (
265 inline_constructor => 1,
e578d610 266 inline_destructor => 1,
2a464664 267 constructor_name => 'new',
6a1d1835 268 @_,
269 );
270
fc1d8369 271 $self->{is_immutable}++;
c7a6403f 272
6a1d1835 273 if ($args{inline_constructor}) {
380e1cd7 274 $self->add_method($args{constructor_name} =>
275 $self->constructor_class->_generate_constructor($self, \%args));
c7a6403f 276 }
277
8632b6fe 278 if ($args{inline_destructor}) {
380e1cd7 279 $self->add_method(DESTROY =>
280 $self->destructor_class->_generate_destructor($self, \%args));
8632b6fe 281 }
2276cb14 282
283 # Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
284 # at the end of a source file.
285 return 1;
fc1d8369 286}
ad958001 287
fce211ae 288sub make_mutable { not_supported }
ad958001 289
6cfa1e5e 290sub is_immutable { $_[0]->{is_immutable} }
291sub is_mutable { !$_[0]->{is_immutable} }
84ef660f 292
3fbade18 293sub _install_modifier_pp{
8d59c723 294 my( $self, $type, $name, $code ) = @_;
295 my $into = $self->name;
3fbade18 296
297 my $original = $into->can($name)
298 or $self->throw_error("The method '$name' is not found in the inheritance hierarchy for class $into");
299
300 my $modifier_table = $self->{modifiers}{$name};
301
302 if(!$modifier_table){
303 my(@before, @after, @around, $cache, $modified);
304
305 $cache = $original;
306
307 $modified = sub {
308 for my $c (@before) { $c->(@_) }
309
310 if(wantarray){ # list context
311 my @rval = $cache->(@_);
312
313 for my $c(@after){ $c->(@_) }
314 return @rval;
315 }
316 elsif(defined wantarray){ # scalar context
317 my $rval = $cache->(@_);
318
319 for my $c(@after){ $c->(@_) }
320 return $rval;
321 }
322 else{ # void context
323 $cache->(@_);
324
325 for my $c(@after){ $c->(@_) }
326 return;
327 }
328 };
329
330 $self->{modifiers}{$name} = $modifier_table = {
331 original => $original,
332
333 before => \@before,
334 after => \@after,
335 around => \@around,
336
337 cache => \$cache, # cache for around modifiers
338 };
339
340 $self->add_method($name => $modified);
341 }
342
343 if($type eq 'before'){
344 unshift @{$modifier_table->{before}}, $code;
345 }
346 elsif($type eq 'after'){
347 push @{$modifier_table->{after}}, $code;
348 }
349 else{ # around
350 push @{$modifier_table->{around}}, $code;
351
352 my $next = ${ $modifier_table->{cache} };
353 ${ $modifier_table->{cache} } = sub{ $code->($next, @_) };
354 }
355
356 return;
357}
358
4859d490 359sub _install_modifier {
8d59c723 360 my ( $self, $type, $name, $code ) = @_;
4f5b44a0 361
3fbade18 362 # load Class::Method::Modifiers first
7ca5c5fb 363 my $no_cmm_fast = do{
3fbade18 364 local $@;
365 eval q{ require Class::Method::Modifiers::Fast };
366 $@;
4f5b44a0 367 };
4f5b44a0 368
3fbade18 369 my $impl;
370 if($no_cmm_fast){
371 $impl = \&_install_modifier_pp;
372 }
373 else{
374 my $install_modifier = Class::Method::Modifiers::Fast->can('_install_modifier');
375 $impl = sub {
8d59c723 376 my ( $self, $type, $name, $code ) = @_;
377 my $into = $self->name;
95ecd6f1 378 $install_modifier->($into, $type, $name, $code);
379
8d59c723 380 $self->add_method($name => do{
381 no strict 'refs';
382 \&{ $into . '::' . $name };
383 });
6cfa1e5e 384 return;
4f5b44a0 385 };
1b79a118 386 }
4f5b44a0 387
3fbade18 388 # replace this method itself :)
389 {
390 no warnings 'redefine';
391 *_install_modifier = $impl;
392 }
393
8d59c723 394 $self->$impl( $type, $name, $code );
4859d490 395}
396
50dc6ee5 397sub add_before_method_modifier {
4859d490 398 my ( $self, $name, $code ) = @_;
8d59c723 399 $self->_install_modifier( 'before', $name, $code );
50dc6ee5 400}
401
402sub add_around_method_modifier {
4859d490 403 my ( $self, $name, $code ) = @_;
8d59c723 404 $self->_install_modifier( 'around', $name, $code );
50dc6ee5 405}
406
407sub add_after_method_modifier {
4859d490 408 my ( $self, $name, $code ) = @_;
8d59c723 409 $self->_install_modifier( 'after', $name, $code );
50dc6ee5 410}
411
67199842 412sub add_override_method_modifier {
413 my ($self, $name, $code) = @_;
414
768804c0 415 if($self->has_method($name)){
416 $self->throw_error("Cannot add an override method if a local method is already present");
85bd3f44 417 }
418
6cfa1e5e 419 my $package = $self->name;
67199842 420
85bd3f44 421 my $super_body = $package->can($name)
6cfa1e5e 422 or $self->throw_error("You cannot override '$name' because it has no super method");
67199842 423
85bd3f44 424 $self->add_method($name => sub {
425 local $Mouse::SUPER_PACKAGE = $package;
426 local $Mouse::SUPER_BODY = $super_body;
427 local @Mouse::SUPER_ARGS = @_;
428
429 $code->(@_);
430 });
431 return;
67199842 432}
433
768804c0 434sub add_augment_method_modifier {
435 my ($self, $name, $code) = @_;
436 if($self->has_method($name)){
437 $self->throw_error("Cannot add an augment method if a local method is already present");
438 }
439
440 my $super = $self->find_method_by_name($name)
441 or $self->throw_error("You cannot augment '$name' because it has no super method");
442
443 my $super_package = $super->package_name;
444 my $super_body = $super->body;
445
446 $self->add_method($name => sub{
447 local $Mouse::INNER_BODY{$super_package} = $code;
448 local $Mouse::INNER_ARGS{$super_package} = [@_];
449 $super_body->(@_);
450 });
451 return;
452}
453
47f36c05 454sub does_role {
455 my ($self, $role_name) = @_;
ad958001 456
47f36c05 457 (defined $role_name)
fce211ae 458 || $self->throw_error("You must supply a role name to look for");
ad958001 459
f7fec86c 460 for my $class ($self->linearized_isa) {
95ecd6f1 461 my $meta = Mouse::Util::get_metaclass_by_name($class)
462 or next;
3a63a2e7 463
464 for my $role (@{ $meta->roles }) {
ff687069 465
3a63a2e7 466 return 1 if $role->does_role($role_name);
f7fec86c 467 }
47f36c05 468 }
ad958001 469
47f36c05 470 return 0;
471}
472
c3398f5b 4731;
c3398f5b 474__END__
475
476=head1 NAME
477
1820fffe 478Mouse::Meta::Class - The Mouse class metaclass
c3398f5b 479
a25ca8d6 480=head1 VERSION
481
b06ce1f5 482This document describes Mouse version 0.40_01
a25ca8d6 483
c3398f5b 484=head1 METHODS
485
612d3e1a 486=head2 C<< initialize(ClassName) -> Mouse::Meta::Class >>
c3398f5b 487
31c5194b 488Finds or creates a C<Mouse::Meta::Class> instance for the given ClassName. Only
306290e8 489one instance should exist for a given class.
c3398f5b 490
612d3e1a 491=head2 C<< name -> ClassName >>
c3398f5b 492
493Returns the name of the owner class.
494
612d3e1a 495=head2 C<< superclasses -> ClassNames >> C<< superclass(ClassNames) >>
c3398f5b 496
497Gets (or sets) the list of superclasses of the owner class.
498
31c5194b 499=head2 C<< add_method(name => CodeRef) >>
c3398f5b 500
31c5194b 501Adds a method to the owner class.
c3398f5b 502
31c5194b 503=head2 C<< has_method(name) -> Bool >>
72b88a88 504
31c5194b 505Returns whether we have a method with the given name.
72b88a88 506
31c5194b 507=head2 C<< get_method(name) -> Mouse::Meta::Method | undef >>
c68b4110 508
31c5194b 509Returns a L<Mouse::Meta::Method> with the given name.
510
511Note that you can also use C<< $metaclass->name->can($name) >> for a method body.
512
513=head2 C<< get_method_list -> Names >>
514
515Returns a list of method names which are defined in the local class.
516If you want a list of all applicable methods for a class, use the
517C<get_all_methods> method.
518
519=head2 C<< get_all_methods -> (Mouse::Meta::Method) >>
520
521Return the list of all L<Mouse::Meta::Method> instances associated with
522the class and its superclasses.
523
524=head2 C<< add_attribute(name => spec | Mouse::Meta::Attribute) >>
525
526Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
527class.
c68b4110 528
612d3e1a 529=head2 C<< has_attribute(Name) -> Bool >>
66eea168 530
531Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
532
31c5194b 533=head2 C<< get_attribute Name -> Mouse::Meta::Attribute | undef >>
c3398f5b 534
306290e8 535Returns the L<Mouse::Meta::Attribute> with the given name.
c3398f5b 536
31c5194b 537=head2 C<< get_attribute_list -> Names >>
538
539Returns a list of attribute names which are defined in the local
540class. If you want a list of all applicable attributes for a class,
541use the C<get_all_attributes> method.
542
543=head2 C<< get_all_attributes -> (Mouse::Meta::Attribute) >>
544
545Returns the list of all L<Mouse::Meta::Attribute> instances associated with
546this class and its superclasses.
547
612d3e1a 548=head2 C<< linearized_isa -> [ClassNames] >>
c3398f5b 549
550Returns the list of classes in method dispatch order, with duplicates removed.
551
612d3e1a 552=head2 C<< new_object(Parameters) -> Instance >>
2cea7a5f 553
612d3e1a 554Creates a new instance.
2cea7a5f 555
612d3e1a 556=head2 C<< clone_object(Instance, Parameters) -> Instance >>
f7b11a21 557
31c5194b 558Clones the given instance which must be an instance governed by this
f7b11a21 559metaclass.
560
31c5194b 561=head2 C<< throw_error(Message, Parameters) >>
562
563Throws an error with the given message.
564
1820fffe 565=head1 SEE ALSO
f7b11a21 566
1820fffe 567L<Moose::Meta::Class>
f7b11a21 568
31c5194b 569L<Class::MOP::Class>
570
c3398f5b 571=cut
572