Bump version to 1.9900 for new version numbering scheme
[gitmo/Moose.git] / lib / Moose / Meta / Attribute.pm
1
2 package Moose::Meta::Attribute;
3
4 use strict;
5 use warnings;
6
7 use Class::MOP ();
8 use Scalar::Util 'blessed', 'weaken';
9 use List::MoreUtils 'any';
10 use Try::Tiny;
11 use overload     ();
12
13 our $VERSION   = '1.9900';
14 our $AUTHORITY = 'cpan:STEVAN';
15
16 use Moose::Deprecated;
17 use Moose::Meta::Method::Accessor;
18 use Moose::Meta::Method::Delegation;
19 use Moose::Util ();
20 use Moose::Util::TypeConstraints ();
21 use Class::MOP::MiniTrait;
22
23 use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
24
25 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
26
27 __PACKAGE__->meta->add_attribute('traits' => (
28     reader    => 'applied_traits',
29     predicate => 'has_applied_traits',
30 ));
31
32 # we need to have a ->does method in here to
33 # more easily support traits, and the introspection
34 # of those traits. We extend the does check to look
35 # for metatrait aliases.
36 sub does {
37     my ($self, $role_name) = @_;
38     my $name = try {
39         Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
40     };
41     return 0 if !defined($name); # failed to load class
42     return $self->Moose::Object::does($name);
43 }
44
45 sub throw_error {
46     my $self = shift;
47     my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
48     unshift @_, "message" if @_ % 2 == 1;
49     unshift @_, attr => $self if ref $self;
50     unshift @_, $class;
51     my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
52     goto $handler;
53 }
54
55 sub _inline_throw_error {
56     my ( $self, $msg, $args ) = @_;
57     "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
58 }
59
60 sub new {
61     my ($class, $name, %options) = @_;
62     $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
63     
64     delete $options{__hack_no_process_options};
65
66     my %attrs =
67         ( map { $_ => 1 }
68           grep { defined }
69           map { $_->init_arg() }
70           $class->meta()->get_all_attributes()
71         );
72
73     my @bad = sort grep { ! $attrs{$_} }  keys %options;
74
75     if (@bad)
76     {
77         Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
78     }
79
80     return $class->SUPER::new($name, %options);
81 }
82
83 sub interpolate_class_and_new {
84     my ($class, $name, %args) = @_;
85
86     my ( $new_class, @traits ) = $class->interpolate_class(\%args);
87
88     $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
89 }
90
91 sub interpolate_class {
92     my ($class, $options) = @_;
93
94     $class = ref($class) || $class;
95
96     if ( my $metaclass_name = delete $options->{metaclass} ) {
97         my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
98
99         if ( $class ne $new_class ) {
100             if ( $new_class->can("interpolate_class") ) {
101                 return $new_class->interpolate_class($options);
102             } else {
103                 $class = $new_class;
104             }
105         }
106     }
107
108     my @traits;
109
110     if (my $traits = $options->{traits}) {
111         my $i = 0;
112         while ($i < @$traits) {
113             my $trait = $traits->[$i++];
114             next if ref($trait); # options to a trait we discarded
115
116             $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
117                   || $trait;
118
119             next if $class->does($trait);
120
121             push @traits, $trait;
122
123             # are there options?
124             push @traits, $traits->[$i++]
125                 if $traits->[$i] && ref($traits->[$i]);
126         }
127
128         if (@traits) {
129             my $anon_class = Moose::Meta::Class->create_anon_class(
130                 superclasses => [ $class ],
131                 roles        => [ @traits ],
132                 cache        => 1,
133             );
134
135             $class = $anon_class->name;
136         }
137     }
138
139     return ( wantarray ? ( $class, @traits ) : $class );
140 }
141
142 # ...
143
144 # method-generating options shouldn't be overridden
145 sub illegal_options_for_inheritance {
146     qw(reader writer accessor clearer predicate)
147 }
148
149 # NOTE/TODO
150 # This method *must* be able to handle
151 # Class::MOP::Attribute instances as
152 # well. Yes, I know that is wrong, but
153 # apparently we didn't realize it was
154 # doing that and now we have some code
155 # which is dependent on it. The real
156 # solution of course is to push this
157 # feature back up into Class::MOP::Attribute
158 # but I not right now, I am too lazy.
159 # However if you are reading this and
160 # looking for something to do,.. please
161 # be my guest.
162 # - stevan
163 sub clone_and_inherit_options {
164     my ($self, %options) = @_;
165
166     # NOTE:
167     # we may want to extends a Class::MOP::Attribute
168     # in which case we need to be able to use the
169     # core set of legal options that have always
170     # been here. But we allows Moose::Meta::Attribute
171     # instances to changes them.
172     # - SL
173     my @illegal_options = $self->can('illegal_options_for_inheritance')
174         ? $self->illegal_options_for_inheritance
175         : ();
176
177     my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
178     (scalar @found_illegal_options == 0)
179         || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
180
181     if ($options{isa}) {
182         my $type_constraint;
183         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
184             $type_constraint = $options{isa};
185         }
186         else {
187             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
188             (defined $type_constraint)
189                 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
190         }
191
192         $options{type_constraint} = $type_constraint;
193     }
194
195     if ($options{does}) {
196         my $type_constraint;
197         if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
198             $type_constraint = $options{does};
199         }
200         else {
201             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
202             (defined $type_constraint)
203                 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
204         }
205
206         $options{type_constraint} = $type_constraint;
207     }
208
209     # NOTE:
210     # this doesn't apply to Class::MOP::Attributes,
211     # so we can ignore it for them.
212     # - SL
213     if ($self->can('interpolate_class')) {
214         ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
215
216         my %seen;
217         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
218         $options{traits} = \@all_traits if @all_traits;
219     }
220
221     # This method can be called on a CMOP::Attribute object, so we need to
222     # make sure we can call this method.
223     $self->_process_lazy_build_option( $self->name, \%options )
224         if $self->can('_process_lazy_build_option');
225
226     $self->clone(%options);
227 }
228
229 sub clone {
230     my ( $self, %params ) = @_;
231
232     my $class = delete $params{metaclass} || ref $self;
233
234     my ( @init, @non_init );
235
236     foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
237         push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
238     }
239
240     my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
241
242     my $name = delete $new_params{name};
243
244     my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
245
246     foreach my $attr ( @non_init ) {
247         $attr->set_value($clone, $attr->get_value($self));
248     }
249
250     return $clone;
251 }
252
253 sub _process_options {
254     my ( $class, $name, $options ) = @_;
255
256     $class->_process_is_option( $name, $options );
257     $class->_process_isa_option( $name, $options );
258     $class->_process_does_option( $name, $options );
259     $class->_process_coerce_option( $name, $options );
260     $class->_process_trigger_option( $name, $options );
261     $class->_process_auto_deref_option( $name, $options );
262     $class->_process_lazy_build_option( $name, $options );
263     $class->_process_lazy_option( $name, $options );
264     $class->_process_required_option( $name, $options );
265 }
266
267 sub _process_is_option {
268     my ( $class, $name, $options ) = @_;
269
270     return unless $options->{is};
271
272     ### -------------------------
273     ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
274     ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
275     ## is => rw, accessor => _foo  # turns into (accessor => _foo)
276     ## is => ro, accessor => _foo  # error, accesor is rw
277     ### -------------------------
278
279     if ( $options->{is} eq 'ro' ) {
280         $class->throw_error(
281             "Cannot define an accessor name on a read-only attribute, accessors are read/write",
282             data => $options )
283             if exists $options->{accessor};
284         $options->{reader} ||= $name;
285     }
286     elsif ( $options->{is} eq 'rw' ) {
287         if ( $options->{writer} ) {
288             $options->{reader} ||= $name;
289         }
290         else {
291             $options->{accessor} ||= $name;
292         }
293     }
294     elsif ( $options->{is} eq 'bare' ) {
295         return;
296         # do nothing, but don't complain (later) about missing methods
297     }
298     else {
299         $class->throw_error( "I do not understand this option (is => "
300                 . $options->{is}
301                 . ") on attribute ($name)", data => $options->{is} );
302     }
303 }
304
305 sub _process_isa_option {
306     my ( $class, $name, $options ) = @_;
307
308     return unless exists $options->{isa};
309
310     if ( exists $options->{does} ) {
311         if ( try { $options->{isa}->can('does') } ) {
312             ( $options->{isa}->does( $options->{does} ) )
313                 || $class->throw_error(
314                 "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)",
315                 data => $options );
316         }
317         else {
318             $class->throw_error(
319                 "Cannot have an isa option which cannot ->does() on attribute ($name)",
320                 data => $options );
321         }
322     }
323
324     # allow for anon-subtypes here ...
325     if ( blessed( $options->{isa} )
326         && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) {
327         $options->{type_constraint} = $options->{isa};
328     }
329     else {
330         $options->{type_constraint}
331             = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
332             $options->{isa} );
333     }
334 }
335
336 sub _process_does_option {
337     my ( $class, $name, $options ) = @_;
338
339     return unless exists $options->{does} && ! exists $options->{isa};
340
341     # allow for anon-subtypes here ...
342     if ( blessed( $options->{does} )
343         && $options->{does}->isa('Moose::Meta::TypeConstraint') ) {
344         $options->{type_constraint} = $options->{does};
345     }
346     else {
347         $options->{type_constraint}
348             = Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
349             $options->{does} );
350     }
351 }
352
353 sub _process_coerce_option {
354     my ( $class, $name, $options ) = @_;
355
356     return unless $options->{coerce};
357
358     ( exists $options->{type_constraint} )
359         || $class->throw_error(
360         "You cannot have coercion without specifying a type constraint on attribute ($name)",
361         data => $options );
362
363     $class->throw_error(
364         "You cannot have a weak reference to a coerced value on attribute ($name)",
365         data => $options )
366         if $options->{weak_ref};
367
368     unless ( $options->{type_constraint}->has_coercion ) {
369         my $type = $options->{type_constraint}->name;
370
371         Moose::Deprecated::deprecated(
372             feature => 'coerce without coercion',
373             message =>
374                 "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
375         );
376     }
377 }
378
379 sub _process_trigger_option {
380     my ( $class, $name, $options ) = @_;
381
382     return unless exists $options->{trigger};
383
384     ( 'CODE' eq ref $options->{trigger} )
385         || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
386 }
387
388 sub _process_auto_deref_option {
389     my ( $class, $name, $options ) = @_;
390
391     return unless $options->{auto_deref};
392
393     ( exists $options->{type_constraint} )
394         || $class->throw_error(
395         "You cannot auto-dereference without specifying a type constraint on attribute ($name)",
396         data => $options );
397
398     ( $options->{type_constraint}->is_a_type_of('ArrayRef')
399       || $options->{type_constraint}->is_a_type_of('HashRef') )
400         || $class->throw_error(
401         "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)",
402         data => $options );
403 }
404
405 sub _process_lazy_build_option {
406     my ( $class, $name, $options ) = @_;
407
408     return unless $options->{lazy_build};
409
410     $class->throw_error(
411         "You can not use lazy_build and default for the same attribute ($name)",
412         data => $options )
413         if exists $options->{default};
414
415     $options->{lazy} = 1;
416     $options->{builder} ||= "_build_${name}";
417
418     if ( $name =~ /^_/ ) {
419         $options->{clearer}   ||= "_clear${name}";
420         $options->{predicate} ||= "_has${name}";
421     }
422     else {
423         $options->{clearer}   ||= "clear_${name}";
424         $options->{predicate} ||= "has_${name}";
425     }
426 }
427
428 sub _process_lazy_option {
429     my ( $class, $name, $options ) = @_;
430
431     return unless $options->{lazy};
432
433     ( exists $options->{default} || defined $options->{builder} )
434         || $class->throw_error(
435         "You cannot have a lazy attribute ($name) without specifying a default value for it",
436         data => $options );
437 }
438
439 sub _process_required_option {
440     my ( $class, $name, $options ) = @_;
441
442     if (
443         $options->{required}
444         && !(
445             ( !exists $options->{init_arg} || defined $options->{init_arg} )
446             || exists $options->{default}
447             || defined $options->{builder}
448         )
449         ) {
450         $class->throw_error(
451             "You cannot have a required attribute ($name) without a default, builder, or an init_arg",
452             data => $options );
453     }
454 }
455
456 sub initialize_instance_slot {
457     my ($self, $meta_instance, $instance, $params) = @_;
458     my $init_arg = $self->init_arg();
459     # try to fetch the init arg from the %params ...
460
461     my $val;
462     my $value_is_set;
463     if ( defined($init_arg) and exists $params->{$init_arg}) {
464         $val = $params->{$init_arg};
465         $value_is_set = 1;
466     }
467     else {
468         # skip it if it's lazy
469         return if $self->is_lazy;
470         # and die if it's required and doesn't have a default value
471         $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
472             if $self->is_required && !$self->has_default && !$self->has_builder;
473
474         # if nothing was in the %params, we can use the
475         # attribute's default value (if it has one)
476         if ($self->has_default) {
477             $val = $self->default($instance);
478             $value_is_set = 1;
479         }
480         elsif ($self->has_builder) {
481             $val = $self->_call_builder($instance);
482             $value_is_set = 1;
483         }
484     }
485
486     return unless $value_is_set;
487
488     $val = $self->_coerce_and_verify( $val, $instance );
489
490     $self->set_initial_value($instance, $val);
491
492     if ( ref $val && $self->is_weak_ref ) {
493         $self->_weaken_value($instance);
494     }
495 }
496
497 sub _call_builder {
498     my ( $self, $instance ) = @_;
499
500     my $builder = $self->builder();
501
502     return $instance->$builder()
503         if $instance->can( $self->builder );
504
505     $self->throw_error(  blessed($instance)
506             . " does not support builder method '"
507             . $self->builder
508             . "' for attribute '"
509             . $self->name
510             . "'",
511             object => $instance,
512      );
513 }
514
515 ## Slot management
516
517 sub _make_initializer_writer_callback {
518     my $self = shift;
519     my ($meta_instance, $instance, $slot_name) = @_;
520     my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
521     return sub {
522         $old_callback->($self->_coerce_and_verify($_[0], $instance));
523     };
524 }
525
526 sub set_value {
527     my ($self, $instance, @args) = @_;
528     my $value = $args[0];
529
530     my $attr_name = $self->name;
531
532     if ($self->is_required and not @args) {
533         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
534     }
535
536     $value = $self->_coerce_and_verify( $value, $instance );
537
538     my @old;
539     if ( $self->has_trigger && $self->has_value($instance) ) {
540         @old = $self->get_value($instance, 'for trigger');
541     }
542
543     $self->SUPER::set_value($instance, $value);
544
545     if ( ref $value && $self->is_weak_ref ) {
546         $self->_weaken_value($instance);
547     }
548
549     if ($self->has_trigger) {
550         $self->trigger->($instance, $value, @old);
551     }
552 }
553
554 sub _inline_set_value {
555     my $self = shift;
556     my ($instance, $value, $tc, $tc_obj, $for_constructor) = @_;
557
558     my $old   = '@old';
559     my $copy  = '$val';
560     $tc     ||= '$type_constraint';
561     $tc_obj ||= '$type_constraint_obj';
562
563     my @code;
564     if ($self->_writer_value_needs_copy) {
565         push @code, $self->_inline_copy_value($value, $copy);
566         $value = $copy;
567     }
568
569     # constructors already handle required checks
570     push @code, $self->_inline_check_required
571         unless $for_constructor;
572
573     push @code, $self->_inline_tc_code($value, $tc, $tc_obj);
574
575     # constructors do triggers all at once at the end
576     push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
577         unless $for_constructor;
578
579     push @code, (
580         $self->SUPER::_inline_set_value($instance, $value),
581         $self->_inline_weaken_value($instance, $value),
582     );
583
584     # constructors do triggers all at once at the end
585     push @code, $self->_inline_trigger($instance, $value, $old)
586         unless $for_constructor;
587
588     return @code;
589 }
590
591 sub _writer_value_needs_copy {
592     my $self = shift;
593     return $self->should_coerce;
594 }
595
596 sub _inline_copy_value {
597     my $self = shift;
598     my ($value, $copy) = @_;
599
600     return 'my ' . $copy . ' = ' . $value . ';'
601 }
602
603 sub _inline_check_required {
604     my $self = shift;
605
606     return unless $self->is_required;
607
608     my $attr_name = quotemeta($self->name);
609
610     return (
611         'if (@_ < 2) {',
612             $self->_inline_throw_error(
613                 '"Attribute (' . $attr_name . ') is required, so cannot '
614               . 'be set to undef"' # defined $_[1] is not good enough
615             ) . ';',
616         '}',
617     );
618 }
619
620 sub _inline_tc_code {
621     my $self = shift;
622     return (
623         $self->_inline_check_coercion(@_),
624         $self->_inline_check_constraint(@_),
625     );
626 }
627
628 sub _inline_check_coercion {
629     my $self = shift;
630     my ($value, $tc, $tc_obj) = @_;
631
632     return unless $self->should_coerce && $self->type_constraint->has_coercion;
633
634     return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
635 }
636
637 sub _inline_check_constraint {
638     my $self = shift;
639     my ($value, $tc, $tc_obj) = @_;
640
641     return unless $self->has_type_constraint;
642
643     my $attr_name = quotemeta($self->name);
644
645     return (
646         'if (!' . $tc . '->(' . $value . ')) {',
647             $self->_inline_throw_error(
648                 '"Attribute (' . $attr_name . ') does not pass the type '
649               . 'constraint because: " . '
650               . $tc_obj . '->get_message(' . $value . ')',
651                 'data => ' . $value
652             ) . ';',
653         '}',
654     );
655 }
656
657 sub _inline_get_old_value_for_trigger {
658     my $self = shift;
659     my ($instance, $old) = @_;
660
661     return unless $self->has_trigger;
662
663     return (
664         'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
665             '? ' . $self->_inline_instance_get($instance),
666             ': ();',
667     );
668 }
669
670 sub _inline_weaken_value {
671     my $self = shift;
672     my ($instance, $value) = @_;
673
674     return unless $self->is_weak_ref;
675
676     my $mi = $self->associated_class->get_meta_instance;
677     return (
678         $mi->inline_weaken_slot_value($instance, $self->name, $value),
679             'if ref ' . $value . ';',
680     );
681 }
682
683 sub _inline_trigger {
684     my $self = shift;
685     my ($instance, $value, $old) = @_;
686
687     return unless $self->has_trigger;
688
689     return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
690 }
691
692 sub _weaken_value {
693     my ( $self, $instance ) = @_;
694
695     my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
696         ->get_meta_instance;
697
698     $meta_instance->weaken_slot_value( $instance, $self->name );
699 }
700
701 sub get_value {
702     my ($self, $instance, $for_trigger) = @_;
703
704     if ($self->is_lazy) {
705         unless ($self->has_value($instance)) {
706             my $value;
707             if ($self->has_default) {
708                 $value = $self->default($instance);
709             } elsif ( $self->has_builder ) {
710                 $value = $self->_call_builder($instance);
711             }
712
713             $value = $self->_coerce_and_verify( $value, $instance );
714
715             $self->set_initial_value($instance, $value);
716         }
717     }
718
719     if ( $self->should_auto_deref && ! $for_trigger ) {
720
721         my $type_constraint = $self->type_constraint;
722
723         if ($type_constraint->is_a_type_of('ArrayRef')) {
724             my $rv = $self->SUPER::get_value($instance);
725             return unless defined $rv;
726             return wantarray ? @{ $rv } : $rv;
727         }
728         elsif ($type_constraint->is_a_type_of('HashRef')) {
729             my $rv = $self->SUPER::get_value($instance);
730             return unless defined $rv;
731             return wantarray ? %{ $rv } : $rv;
732         }
733         else {
734             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
735         }
736
737     }
738     else {
739
740         return $self->SUPER::get_value($instance);
741     }
742 }
743
744 sub _inline_get_value {
745     my $self = shift;
746     my ($instance, $tc, $tc_obj) = @_;
747
748     my $slot_access = $self->_inline_instance_get($instance);
749     $tc           ||= '$type_constraint';
750     $tc_obj       ||= '$type_constraint_obj';
751
752     return (
753         $self->_inline_check_lazy($instance, $tc, $tc_obj),
754         $self->_inline_return_auto_deref($slot_access),
755     );
756 }
757
758 sub _inline_check_lazy {
759     my $self = shift;
760     my ($instance, $tc, $tc_obj) = @_;
761
762     return unless $self->is_lazy;
763
764     my $slot_exists = $self->_inline_instance_has($instance);
765
766     return (
767         'if (!' . $slot_exists . ') {',
768             $self->_inline_init_from_default($instance, '$default', $tc, $tc_obj, 'lazy'),
769         '}',
770     );
771 }
772
773 sub _inline_init_from_default {
774     my $self = shift;
775     my ($instance, $default, $tc, $tc_obj, $for_lazy) = @_;
776
777     if (!($self->has_default || $self->has_builder)) {
778         $self->throw_error(
779             'You cannot have a lazy attribute '
780           . '(' . $self->name . ') '
781           . 'without specifying a default value for it',
782             attr => $self,
783         );
784     }
785
786     return (
787         $self->_inline_generate_default($instance, $default),
788         # intentionally not using _inline_tc_code, since that can be overridden
789         # to do things like possibly only do member tc checks, which isn't
790         # appropriate for checking the result of a default
791         $self->has_type_constraint
792             ? ($self->_inline_check_coercion($default, $tc, $tc_obj, $for_lazy),
793                $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy))
794             : (),
795         $self->_inline_init_slot($instance, $default),
796     );
797 }
798
799 sub _inline_generate_default {
800     my $self = shift;
801     my ($instance, $default) = @_;
802
803     if ($self->has_default) {
804         return 'my ' . $default . ' = $attr->default(' . $instance . ');';
805     }
806     elsif ($self->has_builder) {
807         return (
808             'my ' . $default . ';',
809             'if (my $builder = ' . $instance . '->can($attr->builder)) {',
810                 $default . ' = ' . $instance . '->$builder;',
811             '}',
812             'else {',
813                 'my $class = ref(' . $instance . ') || ' . $instance . ';',
814                 'my $builder_name = $attr->builder;',
815                 'my $attr_name = $attr->name;',
816                 $self->_inline_throw_error(
817                     '"$class does not support builder method '
818                   . '\'$builder_name\' for attribute \'$attr_name\'"'
819                 ) . ';',
820             '}',
821         );
822     }
823     else {
824         $self->throw_error(
825             "Can't generate a default for " . $self->name
826           . " since no default or builder was specified"
827         );
828     }
829 }
830
831 sub _inline_init_slot {
832     my $self = shift;
833     my ($inv, $value) = @_;
834
835     if ($self->has_initializer) {
836         return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
837     }
838     else {
839         return $self->_inline_instance_set($inv, $value) . ';';
840     }
841 }
842
843 sub _inline_return_auto_deref {
844     my $self = shift;
845
846     return 'return ' . $self->_auto_deref(@_) . ';';
847 }
848
849 sub _auto_deref {
850     my $self = shift;
851     my ($ref_value) = @_;
852
853     return $ref_value unless $self->should_auto_deref;
854
855     my $type_constraint = $self->type_constraint;
856
857     my $sigil;
858     if ($type_constraint->is_a_type_of('ArrayRef')) {
859         $sigil = '@';
860     }
861     elsif ($type_constraint->is_a_type_of('HashRef')) {
862         $sigil = '%';
863     }
864     else {
865         $self->throw_error(
866             'Can not auto de-reference the type constraint \''
867           . $type_constraint->name
868           . '\'',
869             type_constraint => $type_constraint,
870         );
871     }
872
873     return 'wantarray '
874              . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
875              . ': (' . $ref_value . ')';
876 }
877
878 ## installing accessors
879
880 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
881
882 sub install_accessors {
883     my $self = shift;
884     $self->SUPER::install_accessors(@_);
885     $self->install_delegation if $self->has_handles;
886     return;
887 }
888
889 sub _check_associated_methods {
890     my $self = shift;
891     unless (
892         @{ $self->associated_methods }
893         || ($self->_is_metadata || '') eq 'bare'
894     ) {
895         Carp::cluck(
896             'Attribute (' . $self->name . ') of class '
897             . $self->associated_class->name
898             . ' has no associated methods'
899             . ' (did you mean to provide an "is" argument?)'
900             . "\n"
901         )
902     }
903 }
904
905 sub _process_accessors {
906     my $self = shift;
907     my ($type, $accessor, $generate_as_inline_methods) = @_;
908
909     $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH';
910     my $method = $self->associated_class->get_method($accessor);
911
912     if (   $method
913         && $method->isa('Class::MOP::Method::Accessor')
914         && $method->associated_attribute->name ne $self->name ) {
915
916         my $other_attr_name = $method->associated_attribute->name;
917         my $name            = $self->name;
918
919         Carp::cluck(
920             "You are overwriting an accessor ($accessor) for the $other_attr_name attribute"
921                 . " with a new accessor method for the $name attribute" );
922     }
923
924     if (
925            $method
926         && !$method->isa('Class::MOP::Method::Accessor')
927         && (  !$self->definition_context
928             || $method->package_name eq $self->definition_context->{package} )
929         ) {
930
931         Carp::cluck(
932             "You are overwriting a locally defined method ($accessor) with "
933                 . "an accessor" );
934     }
935
936     if (  !$self->associated_class->has_method($accessor)
937         && $self->associated_class->has_package_symbol( '&' . $accessor ) ) {
938
939         Carp::cluck(
940             "You are overwriting a locally defined function ($accessor) with "
941                 . "an accessor" );
942     }
943
944     $self->SUPER::_process_accessors(@_);
945 }
946
947 sub remove_accessors {
948     my $self = shift;
949     $self->SUPER::remove_accessors(@_);
950     $self->remove_delegation if $self->has_handles;
951     return;
952 }
953
954 sub install_delegation {
955     my $self = shift;
956
957     # NOTE:
958     # Here we canonicalize the 'handles' option
959     # this will sort out any details and always
960     # return an hash of methods which we want
961     # to delagate to, see that method for details
962     my %handles = $self->_canonicalize_handles;
963
964
965     # install the delegation ...
966     my $associated_class = $self->associated_class;
967     foreach my $handle (keys %handles) {
968         my $method_to_call = $handles{$handle};
969         my $class_name = $associated_class->name;
970         my $name = "${class_name}::${handle}";
971
972             (!$associated_class->has_method($handle))
973                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
974
975         # NOTE:
976         # handles is not allowed to delegate
977         # any of these methods, as they will
978         # override the ones in your class, which
979         # is almost certainly not what you want.
980
981         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
982         #cluck("Not delegating method '$handle' because it is a core method") and
983         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
984
985         my $method = $self->_make_delegation_method($handle, $method_to_call);
986
987         $self->associated_class->add_method($method->name, $method);
988         $self->associate_method($method);
989     }
990 }
991
992 sub remove_delegation {
993     my $self = shift;
994     my %handles = $self->_canonicalize_handles;
995     my $associated_class = $self->associated_class;
996     foreach my $handle (keys %handles) {
997         next unless any { $handle eq $_ }
998                     map { $_->name }
999                     @{ $self->associated_methods };
1000         $self->associated_class->remove_method($handle);
1001     }
1002 }
1003
1004 # private methods to help delegation ...
1005
1006 sub _canonicalize_handles {
1007     my $self    = shift;
1008     my $handles = $self->handles;
1009     if (my $handle_type = ref($handles)) {
1010         if ($handle_type eq 'HASH') {
1011             return %{$handles};
1012         }
1013         elsif ($handle_type eq 'ARRAY') {
1014             return map { $_ => $_ } @{$handles};
1015         }
1016         elsif ($handle_type eq 'Regexp') {
1017             ($self->has_type_constraint)
1018                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
1019             return map  { ($_ => $_) }
1020                    grep { /$handles/ } $self->_get_delegate_method_list;
1021         }
1022         elsif ($handle_type eq 'CODE') {
1023             return $handles->($self, $self->_find_delegate_metaclass);
1024         }
1025         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
1026             return map { $_ => $_ } @{ $handles->methods };
1027         }
1028         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
1029             $handles = $handles->role;
1030         }
1031         else {
1032             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
1033         }
1034     }
1035
1036     Class::MOP::load_class($handles);
1037     my $role_meta = Class::MOP::class_of($handles);
1038
1039     (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
1040         || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
1041
1042     return map { $_ => $_ }
1043         map { $_->name }
1044         grep { !$_->isa('Class::MOP::Method::Meta') } (
1045         $role_meta->_get_local_methods,
1046         $role_meta->get_required_method_list,
1047         );
1048 }
1049
1050 sub _get_delegate_method_list {
1051     my $self = shift;
1052     my $meta = $self->_find_delegate_metaclass;
1053     if ($meta->isa('Class::MOP::Class')) {
1054         return map  { $_->name }  # NOTE: !never! delegate &meta
1055                grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
1056                     $meta->get_all_methods;
1057     }
1058     elsif ($meta->isa('Moose::Meta::Role')) {
1059         return $meta->get_method_list;
1060     }
1061     else {
1062         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
1063     }
1064 }
1065
1066 sub _find_delegate_metaclass {
1067     my $self = shift;
1068     if (my $class = $self->_isa_metadata) {
1069         unless ( Class::MOP::is_class_loaded($class) ) {
1070             $self->throw_error(
1071                 sprintf(
1072                     'The %s attribute is trying to delegate to a class which has not been loaded - %s',
1073                     $self->name, $class
1074                 )
1075             );
1076         }
1077         # we might be dealing with a non-Moose class,
1078         # and need to make our own metaclass. if there's
1079         # already a metaclass, it will be returned
1080         return Class::MOP::Class->initialize($class);
1081     }
1082     elsif (my $role = $self->_does_metadata) {
1083         unless ( Class::MOP::is_class_loaded($class) ) {
1084             $self->throw_error(
1085                 sprintf(
1086                     'The %s attribute is trying to delegate to a role which has not been loaded - %s',
1087                     $self->name, $role
1088                 )
1089             );
1090         }
1091
1092         return Class::MOP::class_of($role);
1093     }
1094     else {
1095         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
1096     }
1097 }
1098
1099 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
1100
1101 sub _make_delegation_method {
1102     my ( $self, $handle_name, $method_to_call ) = @_;
1103
1104     my @curried_arguments;
1105
1106     ($method_to_call, @curried_arguments) = @$method_to_call
1107         if 'ARRAY' eq ref($method_to_call);
1108
1109     return $self->delegation_metaclass->new(
1110         name               => $handle_name,
1111         package_name       => $self->associated_class->name,
1112         attribute          => $self,
1113         delegate_to_method => $method_to_call,
1114         curried_arguments  => \@curried_arguments,
1115     );
1116 }
1117
1118 sub _coerce_and_verify {
1119     my $self     = shift;
1120     my $val      = shift;
1121     my $instance = shift;
1122
1123     return $val unless $self->has_type_constraint;
1124
1125     $val = $self->type_constraint->coerce($val)
1126         if $self->should_coerce && $self->type_constraint->has_coercion;
1127
1128     $self->verify_against_type_constraint($val, instance => $instance);
1129
1130     return $val;
1131 }
1132
1133 sub verify_against_type_constraint {
1134     my $self = shift;
1135     my $val  = shift;
1136
1137     return 1 if !$self->has_type_constraint;
1138
1139     my $type_constraint = $self->type_constraint;
1140
1141     $type_constraint->check($val)
1142         || $self->throw_error("Attribute ("
1143                  . $self->name
1144                  . ") does not pass the type constraint because: "
1145                  . $type_constraint->get_message($val), data => $val, @_);
1146 }
1147
1148 package Moose::Meta::Attribute::Custom::Moose;
1149 sub register_implementation { 'Moose::Meta::Attribute' }
1150
1151 1;
1152
1153 __END__
1154
1155 =pod
1156
1157 =head1 NAME
1158
1159 Moose::Meta::Attribute - The Moose attribute metaclass
1160
1161 =head1 DESCRIPTION
1162
1163 This class is a subclass of L<Class::MOP::Attribute> that provides
1164 additional Moose-specific functionality.
1165
1166 To really understand this class, you will need to start with the
1167 L<Class::MOP::Attribute> documentation. This class can be understood
1168 as a set of additional features on top of the basic feature provided
1169 by that parent class.
1170
1171 =head1 INHERITANCE
1172
1173 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
1174
1175 =head1 METHODS
1176
1177 Many of the documented below override methods in
1178 L<Class::MOP::Attribute> and add Moose specific features.
1179
1180 =head2 Creation
1181
1182 =over 4
1183
1184 =item B<< Moose::Meta::Attribute->new(%options) >>
1185
1186 This method overrides the L<Class::MOP::Attribute> constructor.
1187
1188 Many of the options below are described in more detail in the
1189 L<Moose::Manual::Attributes> document.
1190
1191 It adds the following options to the constructor:
1192
1193 =over 8
1194
1195 =item * is => 'ro', 'rw', 'bare'
1196
1197 This provides a shorthand for specifying the C<reader>, C<writer>, or
1198 C<accessor> names. If the attribute is read-only ('ro') then it will
1199 have a C<reader> method with the same attribute as the name.
1200
1201 If it is read-write ('rw') then it will have an C<accessor> method
1202 with the same name. If you provide an explicit C<writer> for a
1203 read-write attribute, then you will have a C<reader> with the same
1204 name as the attribute, and a C<writer> with the name you provided.
1205
1206 Use 'bare' when you are deliberately not installing any methods
1207 (accessor, reader, etc.) associated with this attribute; otherwise,
1208 Moose will issue a deprecation warning when this attribute is added to a
1209 metaclass.
1210
1211 =item * isa => $type
1212
1213 This option accepts a type. The type can be a string, which should be
1214 a type name. If the type name is unknown, it is assumed to be a class
1215 name.
1216
1217 This option can also accept a L<Moose::Meta::TypeConstraint> object.
1218
1219 If you I<also> provide a C<does> option, then your C<isa> option must
1220 be a class name, and that class must do the role specified with
1221 C<does>.
1222
1223 =item * does => $role
1224
1225 This is short-hand for saying that the attribute's type must be an
1226 object which does the named role.
1227
1228 =item * coerce => $bool
1229
1230 This option is only valid for objects with a type constraint
1231 (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
1232 this attribute is set.
1233
1234 You can make both this and the C<weak_ref> option true.
1235
1236 =item * trigger => $sub
1237
1238 This option accepts a subroutine reference, which will be called after
1239 the attribute is set.
1240
1241 =item * required => $bool
1242
1243 An attribute which is required must be provided to the constructor. An
1244 attribute which is required can also have a C<default> or C<builder>,
1245 which will satisfy its required-ness.
1246
1247 A required attribute must have a C<default>, C<builder> or a
1248 non-C<undef> C<init_arg>
1249
1250 =item * lazy => $bool
1251
1252 A lazy attribute must have a C<default> or C<builder>. When an
1253 attribute is lazy, the default value will not be calculated until the
1254 attribute is read.
1255
1256 =item * weak_ref => $bool
1257
1258 If this is true, the attribute's value will be stored as a weak
1259 reference.
1260
1261 =item * auto_deref => $bool
1262
1263 If this is true, then the reader will dereference the value when it is
1264 called. The attribute must have a type constraint which defines the
1265 attribute as an array or hash reference.
1266
1267 =item * lazy_build => $bool
1268
1269 Setting this to true makes the attribute lazy and provides a number of
1270 default methods.
1271
1272   has 'size' => (
1273       is         => 'ro',
1274       lazy_build => 1,
1275   );
1276
1277 is equivalent to this:
1278
1279   has 'size' => (
1280       is        => 'ro',
1281       lazy      => 1,
1282       builder   => '_build_size',
1283       clearer   => 'clear_size',
1284       predicate => 'has_size',
1285   );
1286
1287
1288 If your attribute name starts with an underscore (C<_>), then the clearer
1289 and predicate will as well:
1290
1291   has '_size' => (
1292       is         => 'ro',
1293       lazy_build => 1,
1294   );
1295
1296 becomes:
1297
1298   has '_size' => (
1299       is        => 'ro',
1300       lazy      => 1,
1301       builder   => '_build__size',
1302       clearer   => '_clear_size',
1303       predicate => '_has_size',
1304   );
1305
1306 Note the doubled underscore in the builder name. Internally, Moose
1307 simply prepends the attribute name with "_build_" to come up with the
1308 builder name.
1309
1310 =item * documentation
1311
1312 An arbitrary string that can be retrieved later by calling C<<
1313 $attr->documentation >>.
1314
1315 =back
1316
1317 =item B<< $attr->clone(%options) >>
1318
1319 This creates a new attribute based on attribute being cloned. You must
1320 supply a C<name> option to provide a new name for the attribute.
1321
1322 The C<%options> can only specify options handled by
1323 L<Class::MOP::Attribute>.
1324
1325 =back
1326
1327 =head2 Value management
1328
1329 =over 4
1330
1331 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
1332
1333 This method is used internally to initialize the attribute's slot in
1334 the object C<$instance>.
1335
1336 This overrides the L<Class::MOP::Attribute> method to handle lazy
1337 attributes, weak references, and type constraints.
1338
1339 =item B<get_value>
1340
1341 =item B<set_value>
1342
1343   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
1344   if($@) {
1345     print "Oops: $@\n";
1346   }
1347
1348 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
1349
1350 Before setting the value, a check is made on the type constraint of
1351 the attribute, if it has one, to see if the value passes it. If the
1352 value fails to pass, the set operation dies with a L</throw_error>.
1353
1354 Any coercion to convert values is done before checking the type constraint.
1355
1356 To check a value against a type constraint before setting it, fetch the
1357 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
1358 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
1359 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
1360 for an example.
1361
1362 =back
1363
1364 =head2 Attribute Accessor generation
1365
1366 =over 4
1367
1368 =item B<< $attr->install_accessors >>
1369
1370 This method overrides the parent to also install delegation methods.
1371
1372 If, after installing all methods, the attribute object has no associated
1373 methods, it throws an error unless C<< is => 'bare' >> was passed to the
1374 attribute constructor.  (Trying to add an attribute that has no associated
1375 methods is almost always an error.)
1376
1377 =item B<< $attr->remove_accessors >>
1378
1379 This method overrides the parent to also remove delegation methods.
1380
1381 =item B<< $attr->inline_set($instance_var, $value_var) >>
1382
1383 This method return a code snippet suitable for inlining the relevant
1384 operation. It expect strings containing variable names to be used in the
1385 inlining, like C<'$self'> or C<'$_[1]'>.
1386
1387 =item B<< $attr->install_delegation >>
1388
1389 This method adds its delegation methods to the attribute's associated
1390 class, if it has any to add.
1391
1392 =item B<< $attr->remove_delegation >>
1393
1394 This method remove its delegation methods from the attribute's
1395 associated class.
1396
1397 =item B<< $attr->accessor_metaclass >>
1398
1399 Returns the accessor metaclass name, which defaults to
1400 L<Moose::Meta::Method::Accessor>.
1401
1402 =item B<< $attr->delegation_metaclass >>
1403
1404 Returns the delegation metaclass name, which defaults to
1405 L<Moose::Meta::Method::Delegation>.
1406
1407 =back
1408
1409 =head2 Additional Moose features
1410
1411 These methods are not found in the superclass. They support features
1412 provided by Moose.
1413
1414 =over 4
1415
1416 =item B<< $attr->does($role) >>
1417
1418 This indicates whether the I<attribute itself> does the given
1419 role. The role can be given as a full class name, or as a resolvable
1420 trait name.
1421
1422 Note that this checks the attribute itself, not its type constraint,
1423 so it is checking the attribute's metaclass and any traits applied to
1424 the attribute.
1425
1426 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1427
1428 This is an alternate constructor that handles the C<metaclass> and
1429 C<traits> options.
1430
1431 Effectively, this method is a factory that finds or creates the
1432 appropriate class for the given C<metaclass> and/or C<traits>.
1433
1434 Once it has the appropriate class, it will call C<< $class->new($name,
1435 %options) >> on that class.
1436
1437 =item B<< $attr->clone_and_inherit_options(%options) >>
1438
1439 This method supports the C<has '+foo'> feature. It does various bits
1440 of processing on the supplied C<%options> before ultimately calling
1441 the C<clone> method.
1442
1443 One of its main tasks is to make sure that the C<%options> provided
1444 does not include the options returned by the
1445 C<illegal_options_for_inheritance> method.
1446
1447 =item B<< $attr->illegal_options_for_inheritance >>
1448
1449 This returns a blacklist of options that can not be overridden in a
1450 subclass's attribute definition.
1451
1452 This exists to allow a custom metaclass to change or add to the list
1453 of options which can not be changed.
1454
1455 =item B<< $attr->type_constraint >>
1456
1457 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1458 if it has one.
1459
1460 =item B<< $attr->has_type_constraint >>
1461
1462 Returns true if this attribute has a type constraint.
1463
1464 =item B<< $attr->verify_against_type_constraint($value) >>
1465
1466 Given a value, this method returns true if the value is valid for the
1467 attribute's type constraint. If the value is not valid, it throws an
1468 error.
1469
1470 =item B<< $attr->handles >>
1471
1472 This returns the value of the C<handles> option passed to the
1473 constructor.
1474
1475 =item B<< $attr->has_handles >>
1476
1477 Returns true if this attribute performs delegation.
1478
1479 =item B<< $attr->is_weak_ref >>
1480
1481 Returns true if this attribute stores its value as a weak reference.
1482
1483 =item B<< $attr->is_required >>
1484
1485 Returns true if this attribute is required to have a value.
1486
1487 =item B<< $attr->is_lazy >>
1488
1489 Returns true if this attribute is lazy.
1490
1491 =item B<< $attr->is_lazy_build >>
1492
1493 Returns true if the C<lazy_build> option was true when passed to the
1494 constructor.
1495
1496 =item B<< $attr->should_coerce >>
1497
1498 Returns true if the C<coerce> option passed to the constructor was
1499 true.
1500
1501 =item B<< $attr->should_auto_deref >>
1502
1503 Returns true if the C<auto_deref> option passed to the constructor was
1504 true.
1505
1506 =item B<< $attr->trigger >>
1507
1508 This is the subroutine reference that was in the C<trigger> option
1509 passed to the constructor, if any.
1510
1511 =item B<< $attr->has_trigger >>
1512
1513 Returns true if this attribute has a trigger set.
1514
1515 =item B<< $attr->documentation >>
1516
1517 Returns the value that was in the C<documentation> option passed to
1518 the constructor, if any.
1519
1520 =item B<< $attr->has_documentation >>
1521
1522 Returns true if this attribute has any documentation.
1523
1524 =item B<< $attr->applied_traits >>
1525
1526 This returns an array reference of all the traits which were applied
1527 to this attribute. If none were applied, this returns C<undef>.
1528
1529 =item B<< $attr->has_applied_traits >>
1530
1531 Returns true if this attribute has any traits applied.
1532
1533 =back
1534
1535 =head1 BUGS
1536
1537 See L<Moose/BUGS> for details on reporting bugs.
1538
1539 =head1 AUTHOR
1540
1541 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1542
1543 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1544
1545 =head1 COPYRIGHT AND LICENSE
1546
1547 Copyright 2006-2010 by Infinity Interactive, Inc.
1548
1549 L<http://www.iinteractive.com>
1550
1551 This library is free software; you can redistribute it and/or modify
1552 it under the same terms as Perl itself.
1553
1554 =cut