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