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