Use dzil Authority plugin - remove $AUTHORITY from code
[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor / Native / Collection.pm
1 package Moose::Meta::Method::Accessor::Native::Collection;
2
3 use strict;
4 use warnings;
5
6 use Moose::Role;
7
8 requires qw( _adds_members );
9
10 sub _inline_coerce_new_values {
11     my $self = shift;
12
13     return unless $self->associated_attribute->should_coerce;
14
15     return unless $self->_tc_member_type_can_coerce;
16
17     return (
18         '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
19                                              $self->_new_members . ';',
20     );
21 }
22
23 sub _tc_member_type_can_coerce {
24     my $self = shift;
25
26     my $member_tc = $self->_tc_member_type;
27
28     return $member_tc && $member_tc->has_coercion;
29 }
30
31 sub _tc_member_type {
32     my $self = shift;
33
34     my $tc = $self->associated_attribute->type_constraint;
35     while ($tc) {
36         return $tc->type_parameter
37             if $tc->can('type_parameter');
38         $tc = $tc->parent;
39     }
40
41     return;
42 }
43
44 sub _writer_value_needs_copy {
45     my $self = shift;
46
47     return $self->_constraint_must_be_checked
48         && !$self->_check_new_members_only;
49 }
50
51 sub _inline_tc_code {
52     my $self = shift;
53
54     return unless $self->_constraint_must_be_checked;
55
56     if ($self->_check_new_members_only) {
57         return unless $self->_adds_members;
58
59         return $self->_inline_check_member_constraint($self->_new_members);
60     }
61     else {
62         return (
63             $self->_inline_check_coercion(@_),
64             $self->_inline_check_constraint(@_),
65         );
66     }
67 }
68
69 sub _check_new_members_only {
70     my $self = shift;
71
72     my $attr = $self->associated_attribute;
73
74     my $tc = $attr->type_constraint;
75
76     # If we have a coercion, we could come up with an entirely new value after
77     # coercing, so we need to check everything,
78     return 0 if $attr->should_coerce && $tc->has_coercion;
79
80     # If the parent is our root type (ArrayRef, HashRef, etc), that means we
81     # can just check the new members of the collection, because we know that
82     # we will always be generating an appropriate collection type.
83     #
84     # However, if this type has its own constraint (it's Parameteriz_able_,
85     # not Paramet_erized_), we don't know what is being checked by the
86     # constraint, so we need to check the whole value, not just the members.
87     return 1
88         if $self->_is_root_type( $tc->parent )
89             && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
90
91     return 0;
92 }
93
94 sub _inline_check_member_constraint {
95     my $self = shift;
96     my ($new_value) = @_;
97
98     my $attr_name = $self->associated_attribute->name;
99
100     return (
101         'for (' . $new_value . ') {',
102             'if (!$member_tc->($_)) {',
103                 $self->_inline_throw_error(
104                     '"A new member value for ' . $attr_name
105                   . ' does not pass its type constraint because: "'
106                   . ' . $member_tc_obj->get_message($_)',
107                     'data => $_',
108                 ) . ';',
109             '}',
110         '}',
111     );
112 }
113
114 sub _inline_get_old_value_for_trigger {
115     my $self = shift;
116     my ($instance, $old) = @_;
117
118     my $attr = $self->associated_attribute;
119     return unless $attr->has_trigger;
120
121     return (
122         'my ' . $old . ' = ' . $self->_has_value($instance),
123             '? ' . $self->_copy_old_value($self->_get_value($instance)),
124             ': ();',
125     );
126 }
127
128 around _eval_environment => sub {
129     my $orig = shift;
130     my $self = shift;
131
132     my $env = $self->$orig(@_);
133
134     my $member_tc = $self->_tc_member_type;
135
136     return $env unless $member_tc;
137
138     $env->{'$member_tc_obj'} = \($member_tc);
139
140     $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
141
142     return $env;
143 };
144
145 no Moose::Role;
146
147 1;