File Coverage

blib/lib/Moose/Meta/Attribute.pm
Criterion Covered Total %
statement 485 513 94.5
branch 253 302 83.7
condition 112 166 67.4
subroutine 76 77 98.7
pod 16 17 94.1
total 942 1075 87.6


line stmt bran cond sub pod time code
1 390     390   4083 use strict;
  390         928  
  390         11896  
2 390     390   2022 use warnings;
  390         889  
  390         19921  
3             package Moose::Meta::Attribute;
4             our $VERSION = '2.2206';
5              
6 390     390   2697 use B ();
  390         2122  
  390         10479  
7 390     390   2250 use Scalar::Util 'blessed';
  390         4624  
  390         27867  
8 390     390   4122 use List::Util 1.33 'any';
  390         11603  
  390         25886  
9 390     390   2918 use Try::Tiny;
  390         1100  
  390         21140  
10 390     390   4224 use overload ();
  390         1058  
  390         10534  
11              
12 390     390   2288 use Moose::Deprecated;
  390         970  
  390         5815  
13 390     390   201187 use Moose::Meta::Method::Accessor;
  390         1087  
  390         14944  
14 390     390   181824 use Moose::Meta::Method::Delegation;
  390         1103  
  390         15728  
15 390     390   4024 use Moose::Util 'throw_exception';
  390         1030  
  390         2047  
16 390     390   302819 use Moose::Util::TypeConstraints ();
  390         1459  
  390         14870  
17 390     390   3285 use Class::MOP::MiniTrait;
  390         913  
  390         11712  
18              
19 390     390   2387 use parent 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
  390         924  
  390         3459  
20              
21 390     390   27362 use Carp 'confess';
  390         1037  
  390         2843697  
22              
23             Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
24              
25             __PACKAGE__->meta->add_attribute('traits' => (
26             reader => 'applied_traits',
27             predicate => 'has_applied_traits',
28             Class::MOP::_definition_context(),
29             ));
30              
31             __PACKAGE__->meta->add_attribute('role_attribute' => (
32             reader => 'role_attribute',
33             predicate => 'has_role_attribute',
34             Class::MOP::_definition_context(),
35             ));
36              
37             # we need to have a ->does method in here to
38             # more easily support traits, and the introspection
39             # of those traits. We extend the does check to look
40             # for metatrait aliases.
41             sub does {
42 214     214 1 778 my ($self, $role_name) = @_;
43             my $name = try {
44 214     214   6884 Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
45 214         1710 };
46 214 100       3742 return 0 if !defined($name); # failed to load class
47 212         1654 return $self->Moose::Object::does($name);
48             }
49              
50             sub _inline_throw_exception {
51 4055     4055   11223 my ( $self, $exception_type, $throw_args ) = @_;
52 4055   50     51631 return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')';
53             }
54              
55             sub new {
56 2723     2723 1 13153 my ($class, $name, %options) = @_;
57 2723 100       15932 $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
58              
59 2699         6293 delete $options{__hack_no_process_options};
60              
61             my %attrs =
62 78469         140994 ( map { $_ => 1 }
63 78469         116353 grep { defined }
64 2699         13284 map { $_->init_arg() }
  78469         179428  
65             $class->meta()->get_all_attributes()
66             );
67              
68 2699         16955 my @bad = sort grep { ! $attrs{$_} } keys %options;
  16391         33463  
69              
70 2699 100       10077 if (@bad)
71             {
72 1 50       10 my $s = @bad > 1 ? 's' : '';
73 1         4 my $list = join "', '", @bad;
74              
75 1         3 my $package = $options{definition_context}{package};
76             my $context = $options{definition_context}{context}
77 1   50     4 || 'attribute constructor';
78 1   50     4 my $type = $options{definition_context}{type} || 'class';
79              
80 1         2 my $location = '';
81 1 50       4 if (defined($package)) {
82 1         3 $location = " in ";
83 1 50       4 $location .= "$type " if $type;
84 1         2 $location .= $package;
85             }
86              
87 1         245 Carp::cluck "Found unknown argument$s '$list' in the $context for '$name'$location";
88             }
89              
90 2699         18379 return $class->SUPER::new($name, %options);
91             }
92              
93             sub interpolate_class_and_new {
94 2300     2300 1 5088 my $class = shift;
95 2300         4185 my $name = shift;
96              
97 2300 100       7654 throw_exception( MustPassEvenNumberOfAttributeOptions => attribute_name => $name,
98             options => \@_
99             )
100             if @_ % 2 == 1;
101              
102 2298         11355 my %args = @_;
103              
104 2298         9229 my ( $new_class, @traits ) = $class->interpolate_class(\%args);
105 2296 100       14892 $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
106             }
107              
108             sub interpolate_class {
109 2338     2338 0 5721 my ($class, $options) = @_;
110              
111 2338   66     9737 $class = ref($class) || $class;
112              
113 2338 100       7702 if ( my $metaclass_name = delete $options->{metaclass} ) {
114 10         57 my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
115              
116 10 50       57 if ( $class ne $new_class ) {
117 10 100       163 if ( $new_class->can("interpolate_class") ) {
118 9         63 return $new_class->interpolate_class($options);
119             } else {
120 1         4 $class = $new_class;
121             }
122             }
123             }
124              
125 2329         4082 my @traits;
126              
127 2329 100       7205 if (my $traits = $options->{traits}) {
128 200         565 my $i = 0;
129 200         565 my $has_foreign_options = 0;
130              
131 200         885 while ($i < @$traits) {
132 209         617 my $trait = $traits->[$i++];
133 209 50       735 next if ref($trait); # options to a trait we discarded
134              
135 209   33     1038 $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
136             || $trait;
137              
138 207 50       1368 next if $class->does($trait);
139              
140 207         646 push @traits, $trait;
141              
142             # are there options?
143 207 100 100     1380 if ($traits->[$i] && ref($traits->[$i])) {
144             $has_foreign_options = 1
145 2 100   3   7 if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] };
  3 50       15  
  2         11  
146              
147 2         11 push @traits, $traits->[$i++];
148             }
149             }
150              
151 198 50       795 if (@traits) {
152 198         1094 my %options = (
153             superclasses => [ $class ],
154             roles => [ @traits ],
155             );
156              
157 198 50       686 if ($has_foreign_options) {
158 0         0 $options{weaken} = 0;
159             }
160             else {
161 198         595 $options{cache} = 1;
162             }
163              
164 198         1700 my $anon_class = Moose::Meta::Class->create_anon_class(%options);
165 198         1362 $class = $anon_class->name;
166             }
167             }
168              
169 2327 50       10441 return ( wantarray ? ( $class, @traits ) : $class );
170             }
171              
172             # ...
173              
174             # method-generating options shouldn't be overridden
175             sub illegal_options_for_inheritance {
176 38     38 1 166 qw(reader writer accessor clearer predicate)
177             }
178              
179             # NOTE/TODO
180             # This method *must* be able to handle
181             # Class::MOP::Attribute instances as
182             # well. Yes, I know that is wrong, but
183             # apparently we didn't realize it was
184             # doing that and now we have some code
185             # which is dependent on it. The real
186             # solution of course is to push this
187             # feature back up into Class::MOP::Attribute
188             # but I not right now, I am too lazy.
189             # However if you are reading this and
190             # looking for something to do,.. please
191             # be my guest.
192             # - stevan
193             sub clone_and_inherit_options {
194 37     37 1 147 my ($self, %options) = @_;
195              
196             # NOTE:
197             # we may want to extends a Class::MOP::Attribute
198             # in which case we need to be able to use the
199             # core set of legal options that have always
200             # been here. But we allows Moose::Meta::Attribute
201             # instances to changes them.
202             # - SL
203 37 50       224 my @illegal_options = $self->can('illegal_options_for_inheritance')
204             ? $self->illegal_options_for_inheritance
205             : ();
206              
207 37 100 100     98 my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
  188         553  
208 37 100       183 (scalar @found_illegal_options == 0)
209             || throw_exception( IllegalInheritedOptions => illegal_options => \@found_illegal_options,
210             params => \%options
211             );
212              
213 31         192 $self->_process_isa_option( $self->name, \%options );
214 31         175 $self->_process_does_option( $self->name, \%options );
215              
216             # NOTE:
217             # this doesn't apply to Class::MOP::Attributes,
218             # so we can ignore it for them.
219             # - SL
220 31 50       156 if ($self->can('interpolate_class')) {
221 31         105 ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
222              
223 31         79 my %seen;
224 31 100       59 my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
  3         14  
  31         1207  
225 31 50       121 $options{traits} = \@all_traits if @all_traits;
226             }
227              
228             # This method can be called on a CMOP::Attribute object, so we need to
229             # make sure we can call this method.
230 31 50       231 $self->_process_lazy_build_option( $self->name, \%options )
231             if $self->can('_process_lazy_build_option');
232              
233 31         160 $self->clone(%options);
234             }
235              
236             sub clone {
237 31     31 1 151 my ( $self, %params ) = @_;
238              
239 31   33     125 my $class = delete $params{metaclass} || ref $self;
240              
241 31         73 my ( @init, @non_init );
242              
243 31         106 foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
  902         1985  
244 309 50       474 push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
  309         650  
245             }
246              
247 31         138 my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
  309         831  
248              
249 31         135 my $name = delete $new_params{name};
250              
251 31         188 my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
252              
253 31         151 foreach my $attr ( @non_init ) {
254 0         0 $attr->set_value($clone, $attr->get_value($self));
255             }
256              
257 31         276 return $clone;
258             }
259              
260             sub _process_options {
261 2691     2691   6737 my ( $class, $name, $options ) = @_;
262              
263 2691         9822 $class->_process_is_option( $name, $options );
264 2688         9815 $class->_process_isa_option( $name, $options );
265 2683         13181 $class->_process_does_option( $name, $options );
266 2683         9332 $class->_process_coerce_option( $name, $options );
267 2677         8762 $class->_process_trigger_option( $name, $options );
268 2674         8585 $class->_process_auto_deref_option( $name, $options );
269 2672         8911 $class->_process_lazy_build_option( $name, $options );
270 2671         8861 $class->_process_lazy_option( $name, $options );
271 2669         7917 $class->_process_required_option( $name, $options );
272             }
273              
274             sub _process_is_option {
275 2691     2691   5967 my ( $class, $name, $options ) = @_;
276              
277 2691 100       7695 return unless $options->{is};
278              
279             ### -------------------------
280             ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
281             ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
282             ## is => rw, accessor => _foo # turns into (accessor => _foo)
283             ## is => ro, accessor => _foo # error, accesor is rw
284             ### -------------------------
285              
286 2185 100       7328 if ( $options->{is} eq 'ro' ) {
    100          
    100          
287             throw_exception("AccessorMustReadWrite" => attribute_name => $name,
288             params => $options,
289             )
290 1889 100       5392 if exists $options->{accessor};
291 1887   66     8978 $options->{reader} ||= $name;
292             }
293             elsif ( $options->{is} eq 'rw' ) {
294 269 100       992 if ( ! $options->{accessor} ) {
295 267 100       839 if ( $options->{writer}) {
296 1   33     18 $options->{reader} ||= $name;
297             }
298             else {
299 266         827 $options->{accessor} = $name;
300             }
301             }
302             }
303             elsif ( $options->{is} eq 'bare' ) {
304 26         66 return;
305             # do nothing, but don't complain (later) about missing methods
306             }
307             else {
308 1         10 throw_exception( InvalidValueForIs => attribute_name => $name,
309             params => $options,
310             );
311             }
312             }
313              
314             sub _process_isa_option {
315 2719     2719   6455 my ( $class, $name, $options ) = @_;
316              
317 2719 100       7917 return unless exists $options->{isa};
318              
319 2035 100       5582 if ( exists $options->{does} ) {
320 5 100   5   47 if ( try { $options->{isa}->can('does') } ) {
  5         171  
321 3 100       55 ( $options->{isa}->does( $options->{does} ) )
322             || throw_exception( IsaDoesNotDoTheRole => attribute_name => $name,
323             params => $options,
324             );
325             }
326             else {
327 2         34 throw_exception( IsaLacksDoesMethod => attribute_name => $name,
328             params => $options,
329             );
330             }
331             }
332              
333             # allow for anon-subtypes here ...
334             #
335             # There are a _lot_ of methods that we expect from TC objects, but
336             # checking for a specific parent class via ->isa is gross, so we'll check
337             # for at least one method.
338 2031 100 66     9817 if ( blessed( $options->{isa} )
339             && $options->{isa}->can('has_coercion') ) {
340              
341 84         324 $options->{type_constraint} = $options->{isa};
342             }
343             else {
344             $options->{type_constraint}
345             = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
346             $options->{isa},
347             { package_defined_in => $options->{definition_context}->{package} }
348 1947         11337 );
349             }
350             }
351              
352             sub _process_does_option {
353 2714     2714   6750 my ( $class, $name, $options ) = @_;
354              
355 2714 100 100     10175 return unless exists $options->{does} && ! exists $options->{isa};
356              
357             # allow for anon-subtypes here ...
358 18 100 66     139 if ( blessed( $options->{does} )
359             && $options->{does}->can('has_coercion') ) {
360              
361 1         3 $options->{type_constraint} = $options->{does};
362             }
363             else {
364             $options->{type_constraint}
365             = Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
366             $options->{does},
367             { package_defined_in => $options->{definition_context}->{package} }
368 17         120 );
369             }
370             }
371              
372             sub _process_coerce_option {
373 2683     2683   6616 my ( $class, $name, $options ) = @_;
374              
375 2683 100       7821 return unless $options->{coerce};
376              
377             ( exists $options->{type_constraint} )
378 41 100       195 || throw_exception( CoercionNeedsTypeConstraint => attribute_name => $name,
379             params => $options,
380             );
381              
382             throw_exception( CannotCoerceAWeakRef => attribute_name => $name,
383             params => $options,
384             )
385 40 100       188 if $options->{weak_ref};
386              
387 39 100       1347 unless ( $options->{type_constraint}->has_coercion ) {
388 4         120 my $type = $options->{type_constraint}->name;
389              
390 4         27 throw_exception( CannotCoerceAttributeWhichHasNoCoercion => attribute_name => $name,
391             type_name => $type,
392             params => $options
393             );
394             }
395             }
396              
397             sub _process_trigger_option {
398 2677     2677   5864 my ( $class, $name, $options ) = @_;
399              
400 2677 100       7650 return unless exists $options->{trigger};
401              
402             ( 'CODE' eq ref $options->{trigger} )
403 29 100       187 || throw_exception( TriggerMustBeACodeRef => attribute_name => $name,
404             params => $options,
405             );
406             }
407              
408             sub _process_auto_deref_option {
409 2674     2674   5897 my ( $class, $name, $options ) = @_;
410              
411 2674 100       7922 return unless $options->{auto_deref};
412              
413             ( exists $options->{type_constraint} )
414 13 100       63 || throw_exception( CannotAutoDerefWithoutIsa => attribute_name => $name,
415             params => $options,
416             );
417              
418             ( $options->{type_constraint}->is_a_type_of('ArrayRef')
419 12 100 100     58 || $options->{type_constraint}->is_a_type_of('HashRef') )
420             || throw_exception( AutoDeRefNeedsArrayRefOrHashRef => attribute_name => $name,
421             params => $options,
422             );
423             }
424              
425             sub _process_lazy_build_option {
426 2703     2703   5881 my ( $class, $name, $options ) = @_;
427              
428 2703 100       7917 return unless $options->{lazy_build};
429              
430             throw_exception( CannotUseLazyBuildAndDefaultSimultaneously => attribute_name => $name,
431             params => $options,
432             )
433 24 100       121 if exists $options->{default};
434              
435 23         96 $options->{lazy} = 1;
436 23   33     211 $options->{builder} ||= "_build_${name}";
437              
438 23 100       128 if ( $name =~ /^_/ ) {
439 1   33     11 $options->{clearer} ||= "_clear${name}";
440 1   33     6 $options->{predicate} ||= "_has${name}";
441             }
442             else {
443 22   33     203 $options->{clearer} ||= "clear_${name}";
444 22   33     156 $options->{predicate} ||= "has_${name}";
445             }
446             }
447              
448             sub _process_lazy_option {
449 2671     2671   5845 my ( $class, $name, $options ) = @_;
450              
451 2671 100       8069 return unless $options->{lazy};
452              
453             ( exists $options->{default} || defined $options->{builder} )
454 523 100 100     3356 || throw_exception( LazyAttributeNeedsADefault => params => $options,
455             attribute_name => $name,
456             );
457             }
458              
459             sub _process_required_option {
460 2669     2669   6038 my ( $class, $name, $options ) = @_;
461              
462 2669 100 33     14294 if (
      100        
463             $options->{required}
464             && !(
465             ( !exists $options->{init_arg} || defined $options->{init_arg} )
466             || exists $options->{default}
467             || defined $options->{builder}
468             )
469             ) {
470 1         7 throw_exception( RequiredAttributeNeedsADefault => params => $options,
471             attribute_name => $name,
472             );
473             }
474             }
475              
476             sub initialize_instance_slot {
477 6182     6182 1 13946 my ($self, $meta_instance, $instance, $params) = @_;
478 6182         16303 my $init_arg = $self->init_arg();
479             # try to fetch the init arg from the %params ...
480              
481 6182         9635 my $val;
482             my $value_is_set;
483 6182 100 100     22321 if ( defined($init_arg) and exists $params->{$init_arg}) {
484 1939         3642 $val = $params->{$init_arg};
485 1939         2850 $value_is_set = 1;
486             }
487             else {
488             # skip it if it's lazy
489 4243 100       144678 return if $self->is_lazy;
490             # and die if it's required and doesn't have a default value
491 3937         12616 my $class_name = blessed( $instance );
492 3937 50 100     117801 throw_exception(
    100 100        
493             'AttributeIsRequired',
494             attribute_name => $self->name,
495             ( defined $init_arg ? ( attribute_init_arg => $init_arg ) : () ),
496             class_name => $class_name,
497             params => $params,
498             )
499             if $self->is_required
500             && !$self->has_default
501             && !$self->has_builder;
502              
503             # if nothing was in the %params, we can use the
504             # attribute's default value (if it has one)
505 3885 100       10500 if ($self->has_default) {
    100          
506 2285         5301 $val = $self->default($instance);
507 2285         9039 $value_is_set = 1;
508             }
509             elsif ($self->has_builder) {
510 14         57 $val = $self->_call_builder($instance);
511 12         64 $value_is_set = 1;
512             }
513             }
514              
515 5822 100       13554 return unless $value_is_set;
516              
517 4236         9053 $val = $self->_coerce_and_verify( $val, $instance );
518              
519 3292         11745 $self->set_initial_value($instance, $val);
520              
521 3292 100 100     92666 if ( ref $val && $self->is_weak_ref ) {
522 47         211 $self->_weaken_value($instance);
523             }
524             }
525              
526             sub _call_builder {
527 14     14   43 my ( $self, $instance ) = @_;
528              
529 14         54 my $builder = $self->builder();
530              
531 14 100       175 return $instance->$builder()
532             if $instance->can( $self->builder );
533              
534 2         10 throw_exception( BuilderDoesNotExist => instance => $instance,
535             attribute => $self,
536             );
537             }
538              
539             ## Slot management
540              
541             sub _make_initializer_writer_callback {
542 9     9   19 my $self = shift;
543 9         26 my ($meta_instance, $instance, $slot_name) = @_;
544 9         39 my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
545             return sub {
546 9     9   9713 $old_callback->($self->_coerce_and_verify($_[0], $instance));
547 9         42 };
548             }
549              
550             sub set_value {
551 53     53 1 1202 my ($self, $instance, @args) = @_;
552 53         97 my $value = $args[0];
553              
554 53         166 my $class_name = blessed( $instance );
555 53 100 66     2094 if ($self->is_required and not @args) {
556 1 50       13 throw_exception(
557             'AttributeIsRequired',
558             attribute_name => $self->name,
559             (
560             defined $self->init_arg
561             ? ( attribute_init_arg => $self->init_arg )
562             : ()
563             ),
564             class_name => $class_name,
565             );
566             }
567              
568 52         156 $value = $self->_coerce_and_verify( $value, $instance );
569              
570 52         96 my @old;
571 52 100 100     1705 if ( $self->has_trigger && $self->has_value($instance) ) {
572 1         5 @old = $self->get_value($instance, 'for trigger');
573             }
574              
575 52         249 $self->SUPER::set_value($instance, $value);
576              
577 52 50 33     138 if ( ref $value && $self->is_weak_ref ) {
578 0         0 $self->_weaken_value($instance);
579             }
580              
581 52 100       1890 if ($self->has_trigger) {
582 2         58 $self->trigger->($instance, $value, @old);
583             }
584             }
585              
586             sub _inline_set_value {
587 3605     3605   7583 my $self = shift;
588 3605         9757 my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_;
589              
590 3605         6551 my $old = '@old';
591 3605         6114 my $copy = '$val';
592 3605   100     11546 $tc ||= '$type_constraint';
593 3605   100     10095 $coercion ||= '$type_coercion';
594 3605   100     9787 $message ||= '$type_message';
595              
596 3605         6359 my @code;
597 3605 100       9774 if ($self->_writer_value_needs_copy) {
598 42         250 push @code, $self->_inline_copy_value($value, $copy);
599 42         99 $value = $copy;
600             }
601              
602             # constructors already handle required checks
603 3605 100       12092 push @code, $self->_inline_check_required
604             unless $for_constructor;
605              
606 3605         11928 push @code, $self->_inline_tc_code($value, $tc, $coercion, $message);
607              
608             # constructors do triggers all at once at the end
609 3605 100       13332 push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
610             unless $for_constructor;
611              
612 3605         16273 push @code, (
613             $self->SUPER::_inline_set_value($instance, $value),
614             $self->_inline_weaken_value($instance, $value),
615             );
616              
617             # constructors do triggers all at once at the end
618 3605 100       13150 push @code, $self->_inline_trigger($instance, $value, $old)
619             unless $for_constructor;
620              
621 3605         15834 return @code;
622             }
623              
624             sub _writer_value_needs_copy {
625 4319     4319   7312 my $self = shift;
626 4319         133027 return $self->should_coerce;
627             }
628              
629             sub _inline_copy_value {
630 42     42   101 my $self = shift;
631 42         122 my ($value, $copy) = @_;
632              
633 42         184 return 'my ' . $copy . ' = ' . $value . ';'
634             }
635              
636             sub _inline_check_required {
637 1048     1048   2312 my $self = shift;
638              
639 1048 100       14797 return unless $self->is_required;
640              
641 13         126 my $throw_params = sprintf( <<'EOF', quotemeta( $self->name ) );
642             attribute_name => "%s",
643             class_name => $class_name,
644             EOF
645 13 50       140 $throw_params .= sprintf(
646             'attribute_init_arg => "%s",',
647             quotemeta( $self->init_arg )
648             ) if defined $self->init_arg;
649              
650 13         102 my $throw = $self->_inline_throw_exception(
651             'AttributeIsRequired',
652             $throw_params
653             );
654              
655 13         68 return sprintf( <<'EOF', $throw );
656             if ( @_ < 2 ) {
657             %s;
658             }
659             EOF
660             }
661              
662             sub _inline_tc_code {
663 3719     3719   6666 my $self = shift;
664 3719         9484 my ($value, $tc, $coercion, $message, $is_lazy) = @_;
665             return (
666 3719         10393 $self->_inline_check_coercion(
667             $value, $tc, $coercion, $is_lazy,
668             ),
669             $self->_inline_check_constraint(
670             $value, $tc, $message, $is_lazy,
671             ),
672             );
673             }
674              
675             sub _inline_check_coercion {
676 4453     4453   7645 my $self = shift;
677 4453         9375 my ($value, $tc, $coercion) = @_;
678              
679 4453 100 66     124109 return unless $self->should_coerce && $self->type_constraint->has_coercion;
680              
681 146 100       4285 if ( $self->type_constraint->can_be_inlined ) {
682             return (
683 38         1082 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
684             $value . ' = ' . $coercion . '->(' . $value . ');',
685             '}',
686             );
687             }
688             else {
689             return (
690 108         961 'if (!' . $tc . '->(' . $value . ')) {',
691             $value . ' = ' . $coercion . '->(' . $value . ');',
692             '}',
693             );
694             }
695             }
696              
697             sub _inline_check_constraint {
698 4453     4453   9021 my $self = shift;
699 4453         9790 my ($value, $tc, $message) = @_;
700              
701 4453 100       134048 return unless $self->has_type_constraint;
702              
703 3575         13776 my $attr_name = quotemeta($self->name);
704              
705 3575 100       107556 if ( $self->type_constraint->can_be_inlined ) {
706             return (
707 3362         99612 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
708             'my $msg = do { local $_ = ' . $value . '; '
709             . $message . '->(' . $value . ');'
710             . '};'.
711             $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint =>
712             'type_constraint_message => $msg , '.
713             'class_name => $class_name, '.
714             'attribute_name => "'.$attr_name.'",'.
715             'value => '.$value
716             ).';',
717             '}',
718             );
719             }
720             else {
721             return (
722 213         1620 'if (!' . $tc . '->(' . $value . ')) {',
723             'my $msg = do { local $_ = ' . $value . '; '
724             . $message . '->(' . $value . ');'
725             . '};'.
726             $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint =>
727             'type_constraint_message => $msg , '.
728             'class_name => $class_name, '.
729             'attribute_name => "'.$attr_name.'",'.
730             'value => '.$value
731             ).';',
732             '}',
733             );
734             }
735             }
736              
737             sub _inline_get_old_value_for_trigger {
738 1304     1304   2909 my $self = shift;
739 1304         3360 my ($instance, $old) = @_;
740              
741 1304 100       22717 return unless $self->has_trigger;
742              
743             return (
744 58         368 'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
745             '? ' . $self->_inline_instance_get($instance),
746             ': ();',
747             );
748             }
749              
750             sub _inline_weaken_value {
751 4265     4265   9113 my $self = shift;
752 4265         9436 my ($instance, $value) = @_;
753              
754 4265 100       136983 return unless $self->is_weak_ref;
755              
756 761         4279 my $mi = $self->associated_class->get_meta_instance;
757             return (
758 761         4523 $mi->inline_weaken_slot_value($instance, $self->name),
759             'if ref ' . $value . ';',
760             );
761             }
762              
763             sub _inline_trigger {
764 1661     1661   3779 my $self = shift;
765 1661         4359 my ($instance, $value, $old) = @_;
766              
767 1661 100       34839 return unless $self->has_trigger;
768              
769 93         570 return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
770             }
771              
772             sub _eval_environment {
773 4243     4243   8361 my $self = shift;
774              
775 4243         8563 my $env = { };
776              
777 4243 100       142163 $env->{'$trigger'} = \($self->trigger)
778             if $self->has_trigger;
779 4243 100       21314 $env->{'$attr_default'} = \($self->default)
780             if $self->has_default;
781              
782 4243 100       131295 if ($self->has_type_constraint) {
783 3204         96498 my $tc_obj = $self->type_constraint;
784              
785 3204 100       12854 $env->{'$type_constraint'} = \(
786             $tc_obj->_compiled_type_constraint
787             ) unless $tc_obj->can_be_inlined;
788             # these two could probably get inlined versions too
789 3204 100       104977 $env->{'$type_coercion'} = \(
790             $tc_obj->coercion->_compiled_type_coercion
791             ) if $tc_obj->has_coercion;
792 3204 100       99554 $env->{'$type_message'} = \(
793             $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message
794             );
795              
796 3204         12116 $env = { %$env, %{ $tc_obj->inline_environment } };
  3204         9647  
797             }
798              
799 4243         28317 $env->{'$class_name'} = \($self->associated_class->name);
800              
801             # XXX ugh, fix these
802 4243 100 100     15430 $env->{'$attr'} = \$self
803             if $self->has_initializer && $self->is_lazy;
804             # pretty sure this is only going to be closed over if you use a custom
805             # error class at this point, but we should still get rid of this
806             # at some point
807 4243         14502 $env->{'$meta'} = \($self->associated_class);
808              
809 4243         13767 return $env;
810             }
811              
812             sub _weaken_value {
813 48     48   194 my ( $self, $instance ) = @_;
814              
815 48         316 my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
816             ->get_meta_instance;
817              
818 48         504 $meta_instance->weaken_slot_value( $instance, $self->name );
819             }
820              
821             sub get_value {
822 71     71 1 687 my ($self, $instance, $for_trigger) = @_;
823              
824 71 100       2612 if ($self->is_lazy) {
825 7 100       43 unless ($self->has_value($instance)) {
826 3         9 my $value;
827 3 50       11 if ($self->has_default) {
    0          
828 3         18 $value = $self->default($instance);
829             } elsif ( $self->has_builder ) {
830 0         0 $value = $self->_call_builder($instance);
831             }
832              
833 3         19 $value = $self->_coerce_and_verify( $value, $instance );
834              
835 3         31 $self->set_initial_value($instance, $value);
836              
837 3 100 66     48 if ( ref $value && $self->is_weak_ref ) {
838 1         6 $self->_weaken_value($instance);
839             }
840             }
841             }
842              
843 71 100 66     2641 if ( $self->should_auto_deref && ! $for_trigger ) {
844              
845 1         40 my $type_constraint = $self->type_constraint;
846              
847 1 50       7 if ($type_constraint->is_a_type_of('ArrayRef')) {
    50          
848 0         0 my $rv = $self->SUPER::get_value($instance);
849 0 0       0 return unless defined $rv;
850 0 0       0 return wantarray ? @{ $rv } : $rv;
  0         0  
851             }
852             elsif ($type_constraint->is_a_type_of('HashRef')) {
853 0         0 my $rv = $self->SUPER::get_value($instance);
854 0 0       0 return unless defined $rv;
855 0 0       0 return wantarray ? %{ $rv } : $rv;
  0         0  
856             }
857             else {
858 1         31 throw_exception( CannotAutoDereferenceTypeConstraint => type_name => $type_constraint->name,
859             instance => $instance,
860             attribute => $self
861             );
862             }
863              
864             }
865             else {
866              
867 70         296 return $self->SUPER::get_value($instance);
868             }
869             }
870              
871             sub _inline_get_value {
872 2961     2961   7062 my $self = shift;
873 2961         8154 my ($instance, $tc, $coercion, $message) = @_;
874              
875 2961         13154 my $slot_access = $self->_inline_instance_get($instance);
876 2961   50     17575 $tc ||= '$type_constraint';
877 2961   50     13329 $coercion ||= '$type_coercion';
878 2961   50     12894 $message ||= '$type_message';
879              
880             return (
881 2961         10251 $self->_inline_check_lazy($instance, $tc, $coercion, $message),
882             $self->_inline_return_auto_deref($slot_access),
883             );
884             }
885              
886             sub _inline_check_lazy {
887 4077     4077   8437 my $self = shift;
888 4077         10230 my ($instance, $tc, $coercion, $message) = @_;
889              
890 4077 100       134098 return unless $self->is_lazy;
891              
892 660         3870 my $slot_exists = $self->_inline_instance_has($instance);
893              
894             return (
895 660         4817 'if (!' . $slot_exists . ') {',
896             $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'),
897             '}',
898             );
899             }
900              
901             sub _inline_init_from_default {
902 660     660   1509 my $self = shift;
903 660         2128 my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_;
904              
905 660 50 66     2945 if (!($self->has_default || $self->has_builder)) {
906 0         0 throw_exception( LazyAttributeNeedsADefault => attribute => $self );
907             }
908              
909             return (
910 660 100       2743 $self->_inline_generate_default($instance, $default),
911             # intentionally not using _inline_tc_code, since that can be overridden
912             # to do things like possibly only do member tc checks, which isn't
913             # appropriate for checking the result of a default
914             $self->has_type_constraint
915             ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
916             $self->_inline_check_constraint($default, $tc, $message, $for_lazy))
917             : (),
918             $self->_inline_init_slot($instance, $default),
919             $self->_inline_weaken_value($instance, $default),
920             );
921             }
922              
923             sub _inline_generate_default {
924 676     676   1891 my $self = shift;
925 676         1690 my ($instance, $default) = @_;
926              
927 676 100       2640 if ($self->has_default) {
    50          
928 209         583 my $source = 'my ' . $default . ' = $attr_default';
929 209 100       654 $source .= '->(' . $instance . ')'
930             if $self->is_default_a_coderef;
931 209         8292 return $source . ';';
932             }
933             elsif ($self->has_builder) {
934 467         4014 my $builder = B::perlstring($self->builder);
935 467         2016 my $builder_str = quotemeta($self->builder);
936 467         1921 my $attr_name_str = quotemeta($self->name);
937             return (
938 467         5286 'my ' . $default . ';',
939             'if (my $builder = ' . $instance . '->can(' . $builder . ')) {',
940             $default . ' = ' . $instance . '->$builder;',
941             '}',
942             'else {',
943             'my $class = ref(' . $instance . ') || ' . $instance . ';',
944             $self->_inline_throw_exception(
945             BuilderMethodNotSupportedForInlineAttribute =>
946             'class_name => $class,'.
947             'attribute_name => "'.$attr_name_str.'",'.
948             'instance => '.$instance.','.
949             'builder => "'.$builder_str.'"'
950             ) . ';',
951             '}',
952             );
953             }
954             else {
955 0         0 confess(
956             "Can't generate a default for " . $self->name
957             . " since no default or builder was specified"
958             );
959             }
960             }
961              
962             sub _inline_init_slot {
963 660     660   1672 my $self = shift;
964 660         1732 my ($inv, $value) = @_;
965              
966 660 100       3082 if ($self->has_initializer) {
967 2         12 return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
968             }
969             else {
970 658         3262 return $self->_inline_instance_set($inv, $value) . ';';
971             }
972             }
973              
974             sub _inline_return_auto_deref {
975 2961     2961   6471 my $self = shift;
976              
977 2961         9518 return 'return ' . $self->_auto_deref(@_) . ';';
978             }
979              
980             sub _auto_deref {
981 2961     2961   5322 my $self = shift;
982 2961         6808 my ($ref_value) = @_;
983              
984 2961 100       83849 return $ref_value unless $self->should_auto_deref;
985              
986 10         350 my $type_constraint = $self->type_constraint;
987              
988 10         28 my $sigil;
989 10 100       39 if ($type_constraint->is_a_type_of('ArrayRef')) {
    50          
990 7         26 $sigil = '@';
991             }
992             elsif ($type_constraint->is_a_type_of('HashRef')) {
993 3         8 $sigil = '%';
994             }
995             else {
996 0         0 confess(
997             'Can not auto de-reference the type constraint \''
998             . $type_constraint->name
999             . '\''
1000             );
1001             }
1002              
1003 10         128 return 'wantarray '
1004             . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
1005             . ': (' . $ref_value . ')';
1006             }
1007              
1008             ## installing accessors
1009              
1010 5276     5276 1 37902 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
1011              
1012             sub install_accessors {
1013 3074     3074 1 7244 my $self = shift;
1014 3074         15580 $self->SUPER::install_accessors(@_);
1015 3074 100       99983 $self->install_delegation if $self->has_handles;
1016 3056         15868 return;
1017             }
1018              
1019             sub _check_associated_methods {
1020 2289     2289   4776 my $self = shift;
1021 2289 100 100     3802 unless (
      100        
1022 2289         15164 @{ $self->associated_methods }
1023             || ($self->_is_metadata || '') eq 'bare'
1024             ) {
1025 2         348 Carp::cluck(
1026             'Attribute (' . $self->name . ') of class '
1027             . $self->associated_class->name
1028             . ' has no associated methods'
1029             . ' (did you mean to provide an "is" argument?)'
1030             . "\n"
1031             )
1032             }
1033             }
1034              
1035             sub _process_accessors {
1036 3214     3214   7306 my $self = shift;
1037 3214         9189 my ($type, $accessor, $generate_as_inline_methods) = @_;
1038              
1039 3214 50 50     17312 $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH';
1040 3214         15009 my $method = $self->associated_class->get_method($accessor);
1041              
1042 3214 100 100     12684 if ( $method
1043             && $method->isa('Class::MOP::Method::Accessor') ) {
1044              
1045             # This is a special case that is very unlikely to occur outside of the
1046             # Moose bootstrapping process. We do not want to warn if the method
1047             # we're about to replace is for this same attribute, _and_ we're
1048             # replacing a non-inline method with an inlined version.
1049             #
1050             # This would never occur in normal user code because Moose inlines all
1051             # accessors. However, Moose metaclasses are instances of
1052             # Class::MOP::Class, which _does not_ inline accessors by
1053             # default. However, in Class::MOP & Moose.pm, we iterate over all of
1054             # our internal metaclasses and make them immutable after they're fully
1055             # defined. This ends up replacing the attribute accessors.
1056 377 50 33     2237 unless ( $method->associated_attribute->name eq $self->name
      33        
1057             && ( $generate_as_inline_methods && !$method->is_inline ) ) {
1058              
1059 0         0 my $other_attr = $method->associated_attribute;
1060              
1061 0         0 my $msg = sprintf(
1062             'You are overwriting a %s (%s) for the %s attribute',
1063             $method->accessor_type,
1064             $accessor,
1065             $other_attr->name,
1066             );
1067              
1068 0 0       0 if ( my $method_context = $method->definition_context ) {
1069             $msg .= sprintf(
1070             ' (defined at %s line %s)',
1071             $method_context->{file},
1072             $method_context->{line},
1073             )
1074             if defined $method_context->{file}
1075 0 0 0     0 && $method_context->{line};
1076             }
1077              
1078 0         0 $msg .= sprintf(
1079             ' with a new %s method for the %s attribute',
1080             $type,
1081             $self->name,
1082             );
1083              
1084 0 0       0 if ( my $self_context = $self->definition_context ) {
1085             $msg .= sprintf(
1086             ' (defined at %s line %s)',
1087             $self_context->{file},
1088             $self_context->{line},
1089             )
1090             if defined $self_context->{file}
1091 0 0 0     0 && $self_context->{line};
1092             }
1093              
1094 0         0 Carp::cluck($msg);
1095             }
1096             }
1097              
1098 3214 50 66     10811 if (
      100        
      33        
      66        
1099             $method
1100             && !$method->is_stub
1101             && !$method->isa('Class::MOP::Method::Accessor')
1102             && ( !$self->definition_context
1103             || $method->package_name eq $self->definition_context->{package} )
1104             ) {
1105              
1106 0         0 Carp::cluck(
1107             "You are overwriting a locally defined method ($accessor) with "
1108             . "an accessor" );
1109             }
1110              
1111 3214 50 66     17401 if ( !$self->associated_class->has_method($accessor)
1112             && $self->associated_class->has_package_symbol( '&' . $accessor ) ) {
1113              
1114 0         0 Carp::cluck(
1115             "You are overwriting a locally defined function ($accessor) with "
1116             . "an accessor" );
1117             }
1118              
1119 3214         15648 $self->SUPER::_process_accessors(@_);
1120             }
1121              
1122             sub remove_accessors {
1123 54     54 1 171 my $self = shift;
1124 54         346 $self->SUPER::remove_accessors(@_);
1125 54 100       2354 $self->remove_delegation if $self->has_handles;
1126 37         134 return;
1127             }
1128              
1129             sub install_delegation {
1130 230     230 1 579 my $self = shift;
1131              
1132             # NOTE:
1133             # Here we canonicalize the 'handles' option
1134             # this will sort out any details and always
1135             # return an hash of methods which we want
1136             # to delegate to, see that method for details
1137 230         1011 my %handles = $self->_canonicalize_handles;
1138              
1139             # install the delegation ...
1140 216         1214 my $associated_class = $self->associated_class;
1141 216         892 my $class_name = $associated_class->name;
1142              
1143 216         1476 foreach my $handle ( sort keys %handles ) {
1144 1119         2712 my $method_to_call = $handles{$handle};
1145 1119         2748 my $name = "${class_name}::${handle}";
1146              
1147 1119 100       3055 if ( my $method = $associated_class->get_method($handle) ) {
1148 6 100       331 throw_exception(
1149             CannotDelegateLocalMethodIsPresent => attribute => $self,
1150             method => $method,
1151             ) unless $method->is_stub;
1152             }
1153              
1154             # NOTE:
1155             # handles is not allowed to delegate
1156             # any of these methods, as they will
1157             # override the ones in your class, which
1158             # is almost certainly not what you want.
1159              
1160             # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
1161             #cluck("Not delegating method '$handle' because it is a core method") and
1162             next
1163 1115 100 100     17263 if $class_name->isa("Moose::Object")
      100        
1164             and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
1165              
1166 1082         4236 my $method = $self->_make_delegation_method($handle, $method_to_call);
1167              
1168 1082         10643 $self->associated_class->add_method($method->name, $method);
1169 1082         4234 $self->associate_method($method);
1170             }
1171             }
1172              
1173             sub remove_delegation {
1174 24     24 1 52 my $self = shift;
1175 24         109 my %handles = $self->_canonicalize_handles;
1176 7         89 my $associated_class = $self->associated_class;
1177 7         35 foreach my $handle (keys %handles) {
1178 41     41   90 next unless any { $handle eq $_ }
1179 44         136 map { $_->name }
1180 22 100       76 @{ $self->associated_methods };
  22         93  
1181 5         33 $self->associated_class->remove_method($handle);
1182             }
1183             }
1184              
1185             # private methods to help delegation ...
1186              
1187             sub _canonicalize_handles {
1188 73     73   135 my $self = shift;
1189 73         2324 my $handles = $self->handles;
1190 73 100       289 if (my $handle_type = ref($handles)) {
1191 68 100 100     430 if ($handle_type eq 'HASH') {
    100 66        
    100          
    100          
    100          
    100          
1192 7         17 return %{$handles};
  7         40  
1193             }
1194             elsif ($handle_type eq 'ARRAY') {
1195 20         51 return map { $_ => $_ } @{$handles};
  23         126  
  20         55  
1196             }
1197             elsif ($handle_type eq 'Regexp') {
1198 29 100       1131 ($self->has_type_constraint)
1199             || throw_exception( CannotDelegateWithoutIsa => attribute => $self );
1200 25         70 return map { ($_ => $_) }
1201 23         98 grep { /$handles/ } $self->_get_delegate_method_list;
  43         158  
1202             }
1203             elsif ($handle_type eq 'CODE') {
1204 8         28 return $handles->($self, $self->_find_delegate_metaclass);
1205             }
1206             elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
1207 1         3 return map { $_ => $_ } @{ $handles->methods };
  2         10  
  1         33  
1208             }
1209             elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
1210 1         35 $handles = $handles->role;
1211             }
1212             else {
1213 2         8 throw_exception( UnableToCanonicalizeHandles => attribute => $self,
1214             handles => $handles
1215             );
1216             }
1217             }
1218              
1219 6         33 Moose::Util::_load_user_class($handles);
1220 6         383 my $role_meta = Class::MOP::class_of($handles);
1221              
1222 6 100 66     77 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
1223             || throw_exception( UnableToCanonicalizeNonRolePackage => attribute => $self,
1224             handles => $handles
1225             );
1226              
1227 6         28 return map { $_ => $_ }
1228 6         203 map { $_->name }
1229 4         24 grep { !$_->isa('Class::MOP::Method::Meta') } (
  10         62  
1230             $role_meta->_get_local_methods,
1231             $role_meta->get_required_method_list,
1232             );
1233             }
1234              
1235             sub _get_delegate_method_list {
1236 23     23   47 my $self = shift;
1237 23         64 my $meta = $self->_find_delegate_metaclass;
1238 9 100       63 if ($meta->isa('Class::MOP::Class')) {
    50          
1239 43         108 return map { $_->name } # NOTE: !never! delegate &meta
1240 7 100       32 grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
  88         358  
1241             $meta->get_all_methods;
1242             }
1243             elsif ($meta->isa('Moose::Meta::Role')) {
1244 0         0 return $meta->get_method_list;
1245             }
1246             else {
1247 2         9 throw_exception( UnableToRecognizeDelegateMetaclass => attribute => $self,
1248             delegate_metaclass => $meta
1249             );
1250             }
1251             }
1252              
1253             sub _find_delegate_metaclass {
1254 31     31   59 my $self = shift;
1255 31         1069 my $class = $self->_isa_metadata;
1256 31         1060 my $role = $self->_does_metadata;
1257              
1258 31 100       86 if ( $class ) {
    100          
1259             # make sure isa is actually a class
1260 23 100       709 unless ( $self->type_constraint->isa("Moose::Meta::TypeConstraint::Class") ) {
1261 4         16 throw_exception( DelegationToATypeWhichIsNotAClass => attribute => $self );
1262             }
1263              
1264             # make sure the class is loaded
1265 19 100       79 unless ( Moose::Util::_is_package_loaded($class) ) {
1266 4         134 throw_exception( DelegationToAClassWhichIsNotLoaded => attribute => $self,
1267             class_name => $class
1268             );
1269             }
1270             # we might be dealing with a non-Moose class,
1271             # and need to make our own metaclass. if there's
1272             # already a metaclass, it will be returned
1273 15         413 return Class::MOP::Class->initialize($class);
1274             }
1275             elsif ( $role ) {
1276 4 50       21 unless ( Moose::Util::_is_package_loaded($role) ) {
1277 4         118 throw_exception( DelegationToARoleWhichIsNotLoaded => attribute => $self,
1278             role_name => $role
1279             );
1280             }
1281              
1282 0         0 return Class::MOP::class_of($role);
1283             }
1284             else {
1285 4         14 throw_exception( CannotFindDelegateMetaclass => attribute => $self );
1286             }
1287             }
1288              
1289 2114     2114 1 12583 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
1290              
1291             sub _make_delegation_method {
1292 50     50   143 my ( $self, $handle_name, $method_to_call ) = @_;
1293              
1294 50         93 my @curried_arguments;
1295              
1296 50 100       147 ($method_to_call, @curried_arguments) = @$method_to_call
1297             if 'ARRAY' eq ref($method_to_call);
1298              
1299 50         133 return $self->delegation_metaclass->new(
1300             name => $handle_name,
1301             package_name => $self->associated_class->name,
1302             attribute => $self,
1303             delegate_to_method => $method_to_call,
1304             curried_arguments => \@curried_arguments,
1305             );
1306             }
1307              
1308             sub _coerce_and_verify {
1309 4300     4300   6641 my $self = shift;
1310 4300         6038 my $val = shift;
1311 4300         5844 my $instance = shift;
1312              
1313 4300 100       153246 return $val unless $self->has_type_constraint;
1314              
1315 4047 100 66     120252 $val = $self->type_constraint->coerce($val)
1316             if $self->should_coerce && $self->type_constraint->has_coercion;
1317              
1318 4047         11800 $self->verify_against_type_constraint($val, instance => $instance);
1319              
1320 3102         69318 return $val;
1321             }
1322              
1323             sub verify_against_type_constraint {
1324 4050     4050 1 5968 my $self = shift;
1325 4050         5107 my $val = shift;
1326              
1327 4050 100       129188 return 1 if !$self->has_type_constraint;
1328              
1329 4049         108085 my $type_constraint = $self->type_constraint;
1330              
1331 4049 100       13011 $type_constraint->check($val)
1332             || throw_exception( ValidationFailedForTypeConstraint => type => $type_constraint,
1333             value => $val,
1334             attribute => $self,
1335             );
1336             }
1337              
1338             package # hide from PAUSE
1339             Moose::Meta::Attribute::Custom::Moose;
1340              
1341 0     0     sub register_implementation { 'Moose::Meta::Attribute' }
1342             1;
1343              
1344             # ABSTRACT: The Moose attribute metaclass
1345              
1346             __END__
1347              
1348             =pod
1349              
1350             =encoding UTF-8
1351              
1352             =head1 NAME
1353              
1354             Moose::Meta::Attribute - The Moose attribute metaclass
1355              
1356             =head1 VERSION
1357              
1358             version 2.2206
1359              
1360             =head1 DESCRIPTION
1361              
1362             This class is a subclass of L<Class::MOP::Attribute> that provides
1363             additional Moose-specific functionality.
1364              
1365             To really understand this class, you will need to start with the
1366             L<Class::MOP::Attribute> documentation. This class can be understood
1367             as a set of additional features on top of the basic feature provided
1368             by that parent class.
1369              
1370             =head1 INHERITANCE
1371              
1372             C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
1373              
1374             =head1 METHODS
1375              
1376             Many of the documented below override methods in
1377             L<Class::MOP::Attribute> and add Moose specific features.
1378              
1379             =head2 Creation
1380              
1381             =over 4
1382              
1383             =item B<< Moose::Meta::Attribute->new($name, %options) >>
1384              
1385             This method overrides the L<Class::MOP::Attribute> constructor.
1386              
1387             Many of the options below are described in more detail in the
1388             L<Moose::Manual::Attributes> document.
1389              
1390             It adds the following options to the constructor:
1391              
1392             =over 8
1393              
1394             =item * is => 'ro', 'rw', 'bare'
1395              
1396             This provides a shorthand for specifying the C<reader>, C<writer>, or
1397             C<accessor> names. If the attribute is read-only ('ro') then it will
1398             have a C<reader> method with the same attribute as the name.
1399              
1400             If it is read-write ('rw') then it will have an C<accessor> method
1401             with the same name. If you provide an explicit C<writer> for a
1402             read-write attribute, then you will have a C<reader> with the same
1403             name as the attribute, and a C<writer> with the name you provided.
1404              
1405             Use 'bare' when you are deliberately not installing any methods
1406             (accessor, reader, etc.) associated with this attribute; otherwise,
1407             Moose will issue a warning when this attribute is added to a
1408             metaclass.
1409              
1410             =item * isa => $type
1411              
1412             This option accepts a type. The type can be a string, which should be
1413             a type name. If the type name is unknown, it is assumed to be a class
1414             name.
1415              
1416             This option can also accept a L<Moose::Meta::TypeConstraint> object.
1417              
1418             If you I<also> provide a C<does> option, then your C<isa> option must
1419             be a class name, and that class must do the role specified with
1420             C<does>.
1421              
1422             =item * does => $role
1423              
1424             This is short-hand for saying that the attribute's type must be an
1425             object which does the named role.
1426              
1427             =item * coerce => $bool
1428              
1429             This option is only valid for objects with a type constraint
1430             (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
1431             this attribute is set.
1432              
1433             You cannot make both this and the C<weak_ref> option true.
1434              
1435             =item * trigger => $sub
1436              
1437             This option accepts a subroutine reference, which will be called after
1438             the attribute is set.
1439              
1440             =item * required => $bool
1441              
1442             An attribute which is required must be provided to the constructor. An
1443             attribute which is required can also have a C<default> or C<builder>,
1444             which will satisfy its required-ness.
1445              
1446             A required attribute must have a C<default>, C<builder> or a
1447             non-C<undef> C<init_arg>
1448              
1449             =item * lazy => $bool
1450              
1451             A lazy attribute must have a C<default> or C<builder>. When an
1452             attribute is lazy, the default value will not be calculated until the
1453             attribute is read.
1454              
1455             =item * weak_ref => $bool
1456              
1457             If this is true, the attribute's value will be stored as a weak
1458             reference.
1459              
1460             =item * documentation
1461              
1462             An arbitrary string that can be retrieved later by calling C<<
1463             $attr->documentation >>.
1464              
1465             =item * auto_deref => $bool
1466              
1467             B<Note that in cases where you want this feature you are often better served
1468             by using a L<Moose::Meta::Attribute::Native> trait instead>.
1469              
1470             If this is true, then the reader will dereference the value when it is
1471             called. The attribute must have a type constraint which defines the
1472             attribute as an array or hash reference.
1473              
1474             =item * lazy_build => $bool
1475              
1476             B<Note that use of this feature is strongly discouraged.> Some documentation
1477             used to encourage use of this feature as a best practice, but we have changed
1478             our minds.
1479              
1480             Setting this to true makes the attribute lazy and provides a number of
1481             default methods.
1482              
1483             has 'size' => (
1484             is => 'ro',
1485             lazy_build => 1,
1486             );
1487              
1488             is equivalent to this:
1489              
1490             has 'size' => (
1491             is => 'ro',
1492             lazy => 1,
1493             builder => '_build_size',
1494             clearer => 'clear_size',
1495             predicate => 'has_size',
1496             );
1497              
1498             If your attribute name starts with an underscore (C<_>), then the clearer
1499             and predicate will as well:
1500              
1501             has '_size' => (
1502             is => 'ro',
1503             lazy_build => 1,
1504             );
1505              
1506             becomes:
1507              
1508             has '_size' => (
1509             is => 'ro',
1510             lazy => 1,
1511             builder => '_build__size',
1512             clearer => '_clear_size',
1513             predicate => '_has_size',
1514             );
1515              
1516             Note the doubled underscore in the builder name. Internally, Moose
1517             simply prepends the attribute name with "_build_" to come up with the
1518             builder name.
1519              
1520             =item * role_attribute => $role_attribute
1521              
1522             If provided, this should be a L<Moose::Meta::Role::Attribute> object.
1523              
1524             =back
1525              
1526             =item B<< $attr->clone(%options) >>
1527              
1528             This creates a new attribute based on attribute being cloned. You must
1529             supply a C<name> option to provide a new name for the attribute.
1530              
1531             The C<%options> can only specify options handled by
1532             L<Class::MOP::Attribute>.
1533              
1534             =back
1535              
1536             =head2 Value management
1537              
1538             =over 4
1539              
1540             =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
1541              
1542             This method is used internally to initialize the attribute's slot in
1543             the object C<$instance>.
1544              
1545             This overrides the L<Class::MOP::Attribute> method to handle lazy
1546             attributes, weak references, and type constraints.
1547              
1548             =item B<get_value>
1549              
1550             =item B<set_value>
1551              
1552             eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
1553             if($@) {
1554             print "Oops: $@\n";
1555             }
1556              
1557             I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
1558              
1559             Before setting the value, a check is made on the type constraint of
1560             the attribute, if it has one, to see if the value passes it. If the
1561             value fails to pass, the set operation dies.
1562              
1563             Any coercion to convert values is done before checking the type constraint.
1564              
1565             To check a value against a type constraint before setting it, fetch the
1566             attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
1567             fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
1568             and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Company_Subtypes>
1569             for an example.
1570              
1571             =back
1572              
1573             =head2 Attribute Accessor generation
1574              
1575             =over 4
1576              
1577             =item B<< $attr->install_accessors >>
1578              
1579             This method overrides the parent to also install delegation methods.
1580              
1581             If, after installing all methods, the attribute object has no associated
1582             methods, it throws an error unless C<< is => 'bare' >> was passed to the
1583             attribute constructor. (Trying to add an attribute that has no associated
1584             methods is almost always an error.)
1585              
1586             =item B<< $attr->remove_accessors >>
1587              
1588             This method overrides the parent to also remove delegation methods.
1589              
1590             =item B<< $attr->inline_set($instance_var, $value_var) >>
1591              
1592             This method return a code snippet suitable for inlining the relevant
1593             operation. It expect strings containing variable names to be used in the
1594             inlining, like C<'$self'> or C<'$_[1]'>.
1595              
1596             =item B<< $attr->install_delegation >>
1597              
1598             This method adds its delegation methods to the attribute's associated
1599             class, if it has any to add.
1600              
1601             =item B<< $attr->remove_delegation >>
1602              
1603             This method remove its delegation methods from the attribute's
1604             associated class.
1605              
1606             =item B<< $attr->accessor_metaclass >>
1607              
1608             Returns the accessor metaclass name, which defaults to
1609             L<Moose::Meta::Method::Accessor>.
1610              
1611             =item B<< $attr->delegation_metaclass >>
1612              
1613             Returns the delegation metaclass name, which defaults to
1614             L<Moose::Meta::Method::Delegation>.
1615              
1616             =back
1617              
1618             =head2 Additional Moose features
1619              
1620             These methods are not found in the superclass. They support features
1621             provided by Moose.
1622              
1623             =over 4
1624              
1625             =item B<< $attr->does($role) >>
1626              
1627             This indicates whether the I<attribute itself> does the given
1628             role. The role can be given as a full class name, or as a resolvable
1629             trait name.
1630              
1631             Note that this checks the attribute itself, not its type constraint,
1632             so it is checking the attribute's metaclass and any traits applied to
1633             the attribute.
1634              
1635             =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1636              
1637             This is an alternate constructor that handles the C<metaclass> and
1638             C<traits> options.
1639              
1640             Effectively, this method is a factory that finds or creates the
1641             appropriate class for the given C<metaclass> and/or C<traits>.
1642              
1643             Once it has the appropriate class, it will call C<< $class->new($name,
1644             %options) >> on that class.
1645              
1646             =item B<< $attr->clone_and_inherit_options(%options) >>
1647              
1648             This method supports the C<has '+foo'> feature. It does various bits
1649             of processing on the supplied C<%options> before ultimately calling
1650             the C<clone> method.
1651              
1652             One of its main tasks is to make sure that the C<%options> provided
1653             does not include the options returned by the
1654             C<illegal_options_for_inheritance> method.
1655              
1656             =item B<< $attr->illegal_options_for_inheritance >>
1657              
1658             This returns a blacklist of options that can not be overridden in a
1659             subclass's attribute definition.
1660              
1661             This exists to allow a custom metaclass to change or add to the list
1662             of options which can not be changed.
1663              
1664             =item B<< $attr->type_constraint >>
1665              
1666             Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1667             if it has one.
1668              
1669             =item B<< $attr->has_type_constraint >>
1670              
1671             Returns true if this attribute has a type constraint.
1672              
1673             =item B<< $attr->verify_against_type_constraint($value) >>
1674              
1675             Given a value, this method returns true if the value is valid for the
1676             attribute's type constraint. If the value is not valid, it throws an
1677             error.
1678              
1679             =item B<< $attr->handles >>
1680              
1681             This returns the value of the C<handles> option passed to the
1682             constructor.
1683              
1684             =item B<< $attr->has_handles >>
1685              
1686             Returns true if this attribute performs delegation.
1687              
1688             =item B<< $attr->is_weak_ref >>
1689              
1690             Returns true if this attribute stores its value as a weak reference.
1691              
1692             =item B<< $attr->is_required >>
1693              
1694             Returns true if this attribute is required to have a value.
1695              
1696             =item B<< $attr->is_lazy >>
1697              
1698             Returns true if this attribute is lazy.
1699              
1700             =item B<< $attr->is_lazy_build >>
1701              
1702             Returns true if the C<lazy_build> option was true when passed to the
1703             constructor.
1704              
1705             =item B<< $attr->should_coerce >>
1706              
1707             Returns true if the C<coerce> option passed to the constructor was
1708             true.
1709              
1710             =item B<< $attr->should_auto_deref >>
1711              
1712             Returns true if the C<auto_deref> option passed to the constructor was
1713             true.
1714              
1715             =item B<< $attr->trigger >>
1716              
1717             This is the subroutine reference that was in the C<trigger> option
1718             passed to the constructor, if any.
1719              
1720             =item B<< $attr->has_trigger >>
1721              
1722             Returns true if this attribute has a trigger set.
1723              
1724             =item B<< $attr->documentation >>
1725              
1726             Returns the value that was in the C<documentation> option passed to
1727             the constructor, if any.
1728              
1729             =item B<< $attr->has_documentation >>
1730              
1731             Returns true if this attribute has any documentation.
1732              
1733             =item B<< $attr->role_attribute >>
1734              
1735             Returns the L<Moose::Meta::Role::Attribute> object from which this attribute
1736             was created, if any. This may return C<undef>.
1737              
1738             =item B<< $attr->has_role_attribute >>
1739              
1740             Returns true if this attribute has an associated role attribute.
1741              
1742             =item B<< $attr->applied_traits >>
1743              
1744             This returns an array reference of all the traits which were applied
1745             to this attribute. If none were applied, this returns C<undef>.
1746              
1747             =item B<< $attr->has_applied_traits >>
1748              
1749             Returns true if this attribute has any traits applied.
1750              
1751             =back
1752              
1753             =head1 BUGS
1754              
1755             See L<Moose/BUGS> for details on reporting bugs.
1756              
1757             =head1 AUTHORS
1758              
1759             =over 4
1760              
1761             =item *
1762              
1763             Stevan Little <stevan@cpan.org>
1764              
1765             =item *
1766              
1767             Dave Rolsky <autarch@urth.org>
1768              
1769             =item *
1770              
1771             Jesse Luehrs <doy@cpan.org>
1772              
1773             =item *
1774              
1775             Shawn M Moore <sartak@cpan.org>
1776              
1777             =item *
1778              
1779             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
1780              
1781             =item *
1782              
1783             Karen Etheridge <ether@cpan.org>
1784              
1785             =item *
1786              
1787             Florian Ragwitz <rafl@debian.org>
1788              
1789             =item *
1790              
1791             Hans Dieter Pearcey <hdp@cpan.org>
1792              
1793             =item *
1794              
1795             Chris Prather <chris@prather.org>
1796              
1797             =item *
1798              
1799             Matt S Trout <mstrout@cpan.org>
1800              
1801             =back
1802              
1803             =head1 COPYRIGHT AND LICENSE
1804              
1805             This software is copyright (c) 2006 by Infinity Interactive, Inc.
1806              
1807             This is free software; you can redistribute it and/or modify it under
1808             the same terms as the Perl 5 programming language system itself.
1809              
1810             =cut