refactor constructor inlining to reuse attribute code
[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor / Native / Collection.pm
CommitLineData
44babf1f 1package Moose::Meta::Method::Accessor::Native::Collection;
2
3use strict;
4use warnings;
5
245478d5 6our $VERSION = '1.19';
44babf1f 7$VERSION = eval $VERSION;
8our $AUTHORITY = 'cpan:STEVAN';
9
8b9641b8 10use Moose::Role;
11
12requires qw( _adds_members );
13
53a4677c 14sub _inline_coerce_new_values {
7bf5e58d 15 my $self = shift;
16
53a4677c 17 return unless $self->associated_attribute->should_coerce;
7bf5e58d 18
53a4677c 19 return unless $self->_tc_member_type_can_coerce;
7bf5e58d 20
53a4677c 21 return (
22 '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
23 $self->_new_members . ';',
24 );
25}
7bf5e58d 26
27sub _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
35sub _tc_member_type {
36 my $self = shift;
37
53a4677c 38 my $tc = $self->associated_attribute->type_constraint;
39 while ($tc) {
7bf5e58d 40 return $tc->type_parameter
41 if $tc->can('type_parameter');
53a4677c 42 $tc = $tc->parent;
7bf5e58d 43 }
44
45 return;
46}
47
6e50f7e9 48sub _writer_value_needs_copy {
44babf1f 49 my $self = shift;
50
51 return $self->_constraint_must_be_checked
52 && !$self->_check_new_members_only;
53a4677c 53}
44babf1f 54
53a4677c 55sub _inline_tc_code {
56 my $self = shift;
44babf1f 57
53a4677c 58 return unless $self->_constraint_must_be_checked;
44babf1f 59
53a4677c 60 if ($self->_check_new_members_only) {
61 return unless $self->_adds_members;
44babf1f 62
53a4677c 63 return $self->_inline_check_member_constraint($self->_new_members);
44babf1f 64 }
65 else {
53a4677c 66 return (
ec86bdff 67 $self->_inline_check_coercion(@_),
68 $self->_inline_check_constraint(@_),
53a4677c 69 );
44babf1f 70 }
53a4677c 71}
44babf1f 72
73sub _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
98sub _inline_check_member_constraint {
53a4677c 99 my $self = shift;
100 my ($new_value) = @_;
44babf1f 101
102 my $attr_name = $self->associated_attribute->name;
103
53a4677c 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->get_message($_)',
111 'data => $_',
112 ) . ';',
113 '}',
114 '}',
115 );
44babf1f 116}
117
53a4677c 118sub _inline_get_old_value_for_trigger {
119 my $self = shift;
120 my ($instance, $old) = @_;
44babf1f 121
122 my $attr = $self->associated_attribute;
53a4677c 123 return unless $attr->has_trigger;
44babf1f 124
53a4677c 125 return (
1e2c801e 126 'my ' . $old . ' = ' . $self->_has_value($instance),
127 '? ' . $self->_copy_old_value($self->_get_value($instance)),
53a4677c 128 ': ();',
129 );
130}
44babf1f 131
8b9641b8 132around _eval_environment => sub {
44babf1f 133 my $orig = shift;
134 my $self = shift;
135
136 my $env = $self->$orig(@_);
137
7bf5e58d 138 my $member_tc = $self->_tc_member_type;
139
140 return $env unless $member_tc;
141
142 $env->{'$member_tc_obj'} = \($member_tc);
44babf1f 143
7bf5e58d 144 $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
44babf1f 145
146 return $env;
8b9641b8 147};
44babf1f 148
149no Moose::Role;
150
1511;