Commit | Line | Data |
5df54980 |
1 | package Moose::Meta::Method::Accessor::Native::Writer; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a6ae7438 |
6 | use List::MoreUtils qw( any ); |
7 | |
245478d5 |
8 | our $VERSION = '1.19'; |
5df54980 |
9 | $VERSION = eval $VERSION; |
10 | our $AUTHORITY = 'cpan:STEVAN'; |
11 | |
8b9641b8 |
12 | use Moose::Role; |
13 | |
14 | with 'Moose::Meta::Method::Accessor::Native'; |
15 | |
16 | requires '_potential_value'; |
5df54980 |
17 | |
18 | sub _generate_method { |
19 | my $self = shift; |
20 | |
21 | my $inv = '$self'; |
22 | |
23 | my $slot_access = $self->_inline_get($inv); |
24 | |
25 | my $code = 'sub {'; |
e7724627 |
26 | |
5df54980 |
27 | $code .= "\n" . $self->_inline_pre_body(@_); |
28 | |
29 | $code .= "\n" . 'my $self = shift;'; |
30 | |
5df54980 |
31 | $code .= "\n" . $self->_inline_curried_arguments; |
32 | |
e7724627 |
33 | $code .= $self->_writer_core( $inv, $slot_access ); |
5df54980 |
34 | |
e7724627 |
35 | $code .= "\n" . $self->_inline_post_body(@_); |
36 | |
37 | $code .= "\n}"; |
5df54980 |
38 | |
e7724627 |
39 | return $code; |
40 | } |
41 | |
42 | sub _writer_core { |
43 | my ( $self, $inv, $slot_access ) = @_; |
44 | |
45 | my $code = q{}; |
46 | |
47 | $code .= "\n" . $self->_inline_check_argument_count; |
48 | $code .= "\n" . $self->_inline_process_arguments( $inv, $slot_access ); |
49 | $code .= "\n" . $self->_inline_check_arguments('for writer'); |
50 | |
51 | $code .= "\n" . $self->_inline_check_lazy($inv); |
5df54980 |
52 | |
5df54980 |
53 | my $potential_value = $self->_potential_value($slot_access); |
54 | |
7f5ec80d |
55 | if ( $self->_return_value($slot_access) ) { |
56 | # some writers will save the return value in this variable when they |
57 | # generate the potential value. |
58 | $code .= "\n" . 'my @return;'; |
59 | } |
60 | |
7bf5e58d |
61 | # This is only needed by collections. |
62 | $code .= "\n" . $self->_inline_coerce_new_values; |
6ff86bed |
63 | $code .= "\n" . $self->_inline_copy_native_value( \$potential_value ); |
5df54980 |
64 | $code .= "\n" |
65 | . $self->_inline_tc_code( |
5df54980 |
66 | $potential_value |
67 | ); |
68 | |
69 | $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv); |
e32b7489 |
70 | $code .= "\n" . $self->_inline_capture_return_value($slot_access); |
5df54980 |
71 | $code .= "\n" |
72 | . $self->_inline_set_new_value( |
73 | $inv, |
e32b7489 |
74 | $potential_value, |
75 | $slot_access, |
584540d9 |
76 | ) . ';'; |
5df54980 |
77 | $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' ); |
e32b7489 |
78 | $code .= "\n" . $self->_return_value( $slot_access, 'for writer' ); |
5df54980 |
79 | |
80 | return $code; |
81 | } |
82 | |
83 | sub _inline_process_arguments {q{}} |
84 | |
85 | sub _inline_check_arguments {q{}} |
86 | |
7bf5e58d |
87 | sub _inline_coerce_new_values {q{}} |
88 | |
c302c35a |
89 | sub _value_needs_copy { |
90 | my $self = shift; |
91 | |
92 | return $self->_constraint_must_be_checked; |
93 | } |
5df54980 |
94 | |
a6ae7438 |
95 | sub _constraint_must_be_checked { |
96 | my $self = shift; |
97 | |
98 | my $attr = $self->associated_attribute; |
99 | |
100 | return $attr->has_type_constraint |
101 | && ( !$self->_is_root_type( $attr->type_constraint ) |
102 | || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); |
103 | } |
104 | |
105 | sub _is_root_type { |
106 | my ($self, $type) = @_; |
107 | |
108 | my $name = $type->name(); |
109 | |
110 | return any { $name eq $_ } @{ $self->root_types }; |
111 | } |
112 | |
6ff86bed |
113 | sub _inline_copy_native_value { |
fa072458 |
114 | my ( $self, $potential_ref ) = @_; |
115 | |
116 | return q{} unless $self->_value_needs_copy; |
117 | |
118 | my $code = "my \$potential = ${$potential_ref};"; |
119 | |
120 | ${$potential_ref} = '$potential'; |
121 | |
122 | return $code; |
123 | } |
124 | |
e7724627 |
125 | sub _inline_tc_code { |
44babf1f |
126 | my ( $self, $potential_value ) = @_; |
8044d617 |
127 | |
128 | return q{} unless $self->_constraint_must_be_checked; |
129 | |
130 | return $self->_inline_check_coercion($potential_value) . "\n" |
131 | . $self->_inline_check_constraint($potential_value); |
e7724627 |
132 | } |
5df54980 |
133 | |
e7724627 |
134 | sub _inline_check_coercion { |
a6ae7438 |
135 | my ( $self, $value ) = @_; |
136 | |
137 | my $attr = $self->associated_attribute; |
138 | |
d26c82ab |
139 | return q{} |
7a431e9c |
140 | unless $attr->should_coerce |
141 | && $attr->type_constraint->has_coercion; |
a6ae7438 |
142 | |
143 | # We want to break the aliasing in @_ in case the coercion tries to make a |
144 | # destructive change to an array member. |
145 | return "$value = \$type_constraint_obj->coerce($value);"; |
e7724627 |
146 | } |
5df54980 |
147 | |
8b9641b8 |
148 | override _inline_check_constraint => sub { |
7a431e9c |
149 | my ( $self, $value, $for_lazy ) = @_; |
5df54980 |
150 | |
7a431e9c |
151 | return q{} unless $for_lazy || $self->_constraint_must_be_checked; |
5df54980 |
152 | |
8b9641b8 |
153 | return super(); |
154 | }; |
5df54980 |
155 | |
e32b7489 |
156 | sub _inline_capture_return_value { return q{} } |
5df54980 |
157 | |
158 | sub _inline_set_new_value { |
159 | my $self = shift; |
160 | |
8b9641b8 |
161 | return $self->_inline_store(@_) |
f878e6cf |
162 | if $self->_value_needs_copy |
163 | || !$self->_slot_access_can_be_inlined |
164 | || !$self->_inline_get_is_lvalue; |
e32b7489 |
165 | |
166 | return $self->_inline_optimized_set_new_value(@_); |
f878e6cf |
167 | } |
168 | |
169 | sub _inline_get_is_lvalue { |
170 | my $self = shift; |
171 | |
172 | return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue; |
173 | } |
e32b7489 |
174 | |
175 | sub _inline_optimized_set_new_value { |
176 | my $self = shift; |
177 | |
8b9641b8 |
178 | return $self->_inline_store(@_); |
5df54980 |
179 | } |
180 | |
7f5ec80d |
181 | sub _return_value { |
182 | my ( $self, $slot_access ) = @_; |
183 | |
184 | return $slot_access; |
185 | } |
5df54980 |
186 | |
8b9641b8 |
187 | no Moose::Role; |
188 | |
5df54980 |
189 | 1; |