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