File Coverage

blib/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
Criterion Covered Total %
statement 48 50 96.0
branch 18 20 90.0
condition 9 15 60.0
subroutine 11 12 91.6
pod n/a
total 86 97 88.6


line stmt bran cond sub pod time code
1             package Moose::Meta::Method::Accessor::Native::Collection;
2             our $VERSION = '2.2206';
3              
4 17     17   9959 use strict;
  17         44  
  17         541  
5 17     17   118 use warnings;
  17         46  
  17         472  
6              
7 17     17   98 use Moose::Role;
  17         38  
  17         132  
8              
9             requires qw( _adds_members _new_members );
10              
11             sub _inline_coerce_new_values {
12 208     208   433 my $self = shift;
13              
14 208 100       568 return unless $self->associated_attribute->should_coerce;
15              
16 21 100       77 return unless $self->_tc_member_type_can_coerce;
17              
18             return (
19 2         9 '(' . $self->_new_members . ') = map { $member_coercion->($_) }',
20             $self->_new_members . ';',
21             );
22             }
23              
24             sub _tc_member_type_can_coerce {
25 47     47   114 my $self = shift;
26              
27 47         145 my $member_tc = $self->_tc_member_type;
28              
29 47   100     267 return $member_tc && $member_tc->has_coercion;
30             }
31              
32             sub _tc_member_type {
33 686     686   1486 my $self = shift;
34              
35 686         1645 my $tc = $self->associated_attribute->type_constraint;
36 686         2392 while ($tc) {
37 1436 100       20168 return $tc->type_parameter
38             if $tc->can('type_parameter');
39 904         23866 $tc = $tc->parent;
40             }
41              
42 154         377 return;
43             }
44              
45             sub _writer_value_needs_copy {
46 0     0   0 my $self = shift;
47              
48 0   0     0 return $self->_constraint_must_be_checked
49             && !$self->_check_new_members_only;
50             }
51              
52             sub _inline_tc_code {
53 271     271   540 my $self = shift;
54 271         768 my ($value, $tc, $coercion, $message, $is_lazy) = @_;
55              
56 271 50       724 return unless $self->_constraint_must_be_checked;
57              
58 271 100       1223 if ($self->_check_new_members_only) {
59 174 100       1132 return unless $self->_adds_members;
60              
61 141         613 return $self->_inline_check_member_constraint($self->_new_members);
62             }
63             else {
64             return (
65 97         627 $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
66             $self->_inline_check_constraint($value, $tc, $message, $is_lazy),
67             );
68             }
69             }
70              
71             sub _check_new_members_only {
72 253     253   545 my $self = shift;
73              
74 253         707 my $attr = $self->associated_attribute;
75              
76 253         8182 my $tc = $attr->type_constraint;
77              
78             # If we have a coercion, we could come up with an entirely new value after
79             # coercing, so we need to check everything,
80 253 100 66     8163 return 0 if $attr->should_coerce && $tc->has_coercion;
81              
82             # If the parent is our root type (ArrayRef, HashRef, etc), that means we
83             # can just check the new members of the collection, because we know that
84             # we will always be generating an appropriate collection type.
85             #
86             # However, if this type has its own constraint (it's Parameteriz_able_,
87             # not Paramet_erized_), we don't know what is being checked by the
88             # constraint, so we need to check the whole value, not just the members.
89 206 100 66     5338 return 1
      66        
90             if $self->_is_root_type( $tc->parent )
91             && ( $tc->isa('Moose::Meta::TypeConstraint::Parameterized')
92             || !$tc->can('parameterize') );
93              
94 32         123 return 0;
95             }
96              
97             sub _inline_check_member_constraint {
98 141     141   267 my $self = shift;
99 141         382 my ($new_value) = @_;
100              
101 141         414 my $attr_name = $self->associated_attribute->name;
102              
103 141 50       538 my $check
104             = $self->_tc_member_type->can_be_inlined
105             ? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')'
106             : ' !$member_tc->($new_val) ';
107              
108             return (
109 141         1763 'for my $new_val (' . $new_value . ') {',
110             "if ($check) {",
111             'my $msg = do { local $_ = $new_val; $member_message->($new_val) };'.
112             $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint =>
113             "attribute_name => '".$attr_name."',".
114             'type_constraint_message => $msg,'.
115             'class_name => $class_name,'.
116             'value => $new_val,'.
117             'new_member => 1',
118             ) . ';',
119             '}',
120             '}',
121             );
122             }
123              
124             sub _inline_get_old_value_for_trigger {
125 357     357   769 my $self = shift;
126 357         838 my ($instance, $old) = @_;
127              
128 357         1062 my $attr = $self->associated_attribute;
129 357 100       12503 return unless $attr->has_trigger;
130              
131             return (
132 35         334 'my ' . $old . ' = ' . $self->_has_value($instance),
133             '? ' . $self->_copy_old_value($self->_get_value($instance)),
134             ': ();',
135             );
136             }
137              
138             around _eval_environment => sub {
139             my $orig = shift;
140             my $self = shift;
141              
142             my $env = $self->$orig(@_);
143              
144             my $member_tc = $self->_tc_member_type;
145              
146             return $env unless $member_tc;
147              
148             $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
149             $env->{'$member_coercion'} = \(
150             $member_tc->coercion->_compiled_type_coercion
151             ) if $member_tc->has_coercion;
152             $env->{'$member_message'} = \(
153             $member_tc->has_message
154             ? $member_tc->message
155             : $member_tc->_default_message
156             );
157              
158             my $tc_env = $member_tc->inline_environment();
159              
160             $env = { %{$env}, %{$tc_env} };
161              
162             return $env;
163             };
164              
165 17     17   167 no Moose::Role;
  17         48  
  17         116  
166              
167             1;