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