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