Commit | Line | Data |
44babf1f |
1 | package Moose::Meta::Method::Accessor::Native::Collection; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
efa728b4 |
6 | our $VERSION = '1.15'; |
44babf1f |
7 | $VERSION = eval $VERSION; |
8 | our $AUTHORITY = 'cpan:STEVAN'; |
9 | |
8b9641b8 |
10 | use Moose::Role; |
11 | |
12 | requires qw( _adds_members ); |
13 | |
14 | around _value_needs_copy => sub { |
44babf1f |
15 | shift; |
16 | my $self = shift; |
17 | |
18 | return $self->_constraint_must_be_checked |
19 | && !$self->_check_new_members_only; |
8b9641b8 |
20 | }; |
44babf1f |
21 | |
8b9641b8 |
22 | around _inline_tc_code => sub { |
44babf1f |
23 | shift; |
24 | my ( $self, $potential_value ) = @_; |
25 | |
26 | return q{} unless $self->_constraint_must_be_checked; |
27 | |
28 | if ( $self->_check_new_members_only ) { |
29 | return q{} unless $self->_adds_members; |
30 | |
31 | return $self->_inline_check_member_constraint( $self->_new_members ); |
32 | } |
33 | else { |
34 | return $self->_inline_check_coercion($potential_value) . "\n" |
35 | . $self->_inline_check_constraint($potential_value); |
36 | } |
8b9641b8 |
37 | }; |
44babf1f |
38 | |
39 | sub _check_new_members_only { |
40 | my $self = shift; |
41 | |
42 | my $attr = $self->associated_attribute; |
43 | |
44 | my $tc = $attr->type_constraint; |
45 | |
46 | # If we have a coercion, we could come up with an entirely new value after |
47 | # coercing, so we need to check everything, |
48 | return 0 if $attr->should_coerce && $tc->has_coercion; |
49 | |
50 | # If the parent is our root type (ArrayRef, HashRef, etc), that means we |
51 | # can just check the new members of the collection, because we know that |
52 | # we will always be generating an appropriate collection type. |
53 | # |
54 | # However, if this type has its own constraint (it's Parameteriz_able_, |
55 | # not Paramet_erized_), we don't know what is being checked by the |
56 | # constraint, so we need to check the whole value, not just the members. |
57 | return 1 |
58 | if $self->_is_root_type( $tc->parent ) |
59 | && $tc->isa('Moose::Meta::TypeConstraint::Parameterized'); |
60 | |
61 | return 0; |
62 | } |
63 | |
64 | sub _inline_check_member_constraint { |
65 | my ( $self, $new_value ) = @_; |
66 | |
67 | my $attr_name = $self->associated_attribute->name; |
68 | |
69 | return '$member_tc->($_) || ' |
70 | . $self->_inline_throw_error( |
71 | qq{"A new member value for '$attr_name' does not pass its type constraint because: "} |
72 | . ' . $member_tc->get_message($_)', |
73 | "data => \$_" |
74 | ) . " for $new_value;"; |
75 | } |
76 | |
8b9641b8 |
77 | around _inline_check_constraint => sub { |
44babf1f |
78 | my $orig = shift; |
79 | my $self = shift; |
80 | |
81 | return q{} unless $self->_constraint_must_be_checked; |
82 | |
83 | return $self->$orig( $_[0] ); |
8b9641b8 |
84 | }; |
44babf1f |
85 | |
8b9641b8 |
86 | around _inline_get_old_value_for_trigger => sub { |
44babf1f |
87 | shift; |
88 | my ( $self, $instance ) = @_; |
89 | |
90 | my $attr = $self->associated_attribute; |
91 | return '' unless $attr->has_trigger; |
92 | |
44babf1f |
93 | return |
d67398ab |
94 | 'my @old = ' |
95 | . $self->_inline_has($instance) . q{ ? } |
44babf1f |
96 | . $self->_inline_copy_old_value( $self->_inline_get($instance) ) |
d67398ab |
97 | . ": ();\n"; |
8b9641b8 |
98 | }; |
44babf1f |
99 | |
8b9641b8 |
100 | around _eval_environment => sub { |
44babf1f |
101 | my $orig = shift; |
102 | my $self = shift; |
103 | |
104 | my $env = $self->$orig(@_); |
105 | |
106 | return $env |
107 | unless $self->_constraint_must_be_checked |
108 | && $self->_check_new_members_only; |
109 | |
110 | $env->{'$member_tc'} |
111 | = \( $self->associated_attribute->type_constraint->type_parameter |
112 | ->_compiled_type_constraint ); |
113 | |
114 | return $env; |
8b9641b8 |
115 | }; |
44babf1f |
116 | |
117 | no Moose::Role; |
118 | |
119 | 1; |