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 | |
53a4677c |
21 | my $inv = '$self'; |
1e2c801e |
22 | my $slot_access = $self->_get_value($inv); |
5df54980 |
23 | |
53a4677c |
24 | return ( |
25 | 'sub {', |
26 | $self->_inline_pre_body(@_), |
27 | 'my ' . $inv . ' = shift;', |
28 | $self->_inline_curried_arguments, |
1e2c801e |
29 | $self->_inline_writer_core($inv, $slot_access), |
53a4677c |
30 | $self->_inline_post_body(@_), |
31 | '}', |
32 | ); |
e7724627 |
33 | } |
34 | |
1e2c801e |
35 | sub _inline_writer_core { |
53a4677c |
36 | my $self = shift; |
37 | my ($inv, $slot_access) = @_; |
e7724627 |
38 | |
53a4677c |
39 | my $potential = $self->_potential_value($slot_access); |
40 | my $old = '@old'; |
5df54980 |
41 | |
53a4677c |
42 | my @code; |
43 | push @code, ( |
44 | $self->_inline_check_argument_count, |
45 | $self->_inline_process_arguments($inv, $slot_access), |
46 | $self->_inline_check_arguments('for writer'), |
47 | $self->_inline_check_lazy($inv), |
48 | ); |
5df54980 |
49 | |
53a4677c |
50 | if ($self->_return_value($slot_access)) { |
7f5ec80d |
51 | # some writers will save the return value in this variable when they |
52 | # generate the potential value. |
53a4677c |
53 | push @code, 'my @return;' |
7f5ec80d |
54 | } |
55 | |
53a4677c |
56 | push @code, ( |
57 | $self->_inline_coerce_new_values, |
58 | $self->_inline_copy_native_value(\$potential), |
59 | $self->_inline_tc_code($potential), |
60 | $self->_inline_get_old_value_for_trigger($inv, $old), |
61 | $self->_inline_capture_return_value($slot_access), |
62 | $self->_inline_set_new_value($inv, $potential, $slot_access), |
63 | $self->_inline_trigger($inv, $slot_access, $old), |
64 | $self->_inline_return_value($slot_access, 'for writer'), |
65 | ); |
66 | |
67 | return @code; |
5df54980 |
68 | } |
69 | |
53a4677c |
70 | sub _inline_process_arguments { return } |
5df54980 |
71 | |
53a4677c |
72 | sub _inline_check_arguments { return } |
5df54980 |
73 | |
53a4677c |
74 | sub _inline_coerce_new_values { return } |
7bf5e58d |
75 | |
c302c35a |
76 | sub _value_needs_copy { |
77 | my $self = shift; |
78 | |
79 | return $self->_constraint_must_be_checked; |
80 | } |
5df54980 |
81 | |
a6ae7438 |
82 | sub _constraint_must_be_checked { |
83 | my $self = shift; |
84 | |
85 | my $attr = $self->associated_attribute; |
86 | |
87 | return $attr->has_type_constraint |
1e2c801e |
88 | && (!$self->_is_root_type( $attr->type_constraint ) |
89 | || ( $attr->should_coerce && $attr->type_constraint->has_coercion) |
90 | ); |
a6ae7438 |
91 | } |
92 | |
93 | sub _is_root_type { |
53a4677c |
94 | my $self = shift; |
95 | my ($type) = @_; |
a6ae7438 |
96 | |
53a4677c |
97 | my $name = $type->name; |
a6ae7438 |
98 | |
99 | return any { $name eq $_ } @{ $self->root_types }; |
100 | } |
101 | |
6ff86bed |
102 | sub _inline_copy_native_value { |
53a4677c |
103 | my $self = shift; |
104 | my ($potential_ref) = @_; |
fa072458 |
105 | |
53a4677c |
106 | return unless $self->_value_needs_copy; |
fa072458 |
107 | |
53a4677c |
108 | my $code = 'my $potential = ' . ${$potential_ref} . ';'; |
fa072458 |
109 | |
110 | ${$potential_ref} = '$potential'; |
111 | |
1e2c801e |
112 | return $code; |
fa072458 |
113 | } |
114 | |
53a4677c |
115 | around _inline_tc_code => sub { |
116 | my $orig = shift; |
117 | my $self = shift; |
118 | my ($value, $for_lazy) = @_; |
8044d617 |
119 | |
53a4677c |
120 | return unless $for_lazy || $self->_constraint_must_be_checked; |
8044d617 |
121 | |
53a4677c |
122 | return $self->$orig(@_); |
123 | }; |
5df54980 |
124 | |
e7724627 |
125 | sub _inline_check_coercion { |
53a4677c |
126 | my $self = shift; |
127 | my ($value) = @_; |
a6ae7438 |
128 | |
129 | my $attr = $self->associated_attribute; |
53a4677c |
130 | return unless $attr->should_coerce && $attr->type_constraint->has_coercion; |
a6ae7438 |
131 | |
132 | # We want to break the aliasing in @_ in case the coercion tries to make a |
133 | # destructive change to an array member. |
1e2c801e |
134 | return $value . ' = $type_constraint_obj->coerce(' . $value . ');'; |
e7724627 |
135 | } |
5df54980 |
136 | |
53a4677c |
137 | around _inline_check_constraint => sub { |
138 | my $orig = shift; |
139 | my $self = shift; |
140 | my ($value, $for_lazy) = @_; |
5df54980 |
141 | |
53a4677c |
142 | return unless $for_lazy || $self->_constraint_must_be_checked; |
5df54980 |
143 | |
53a4677c |
144 | return $self->$orig(@_); |
8b9641b8 |
145 | }; |
5df54980 |
146 | |
53a4677c |
147 | sub _inline_capture_return_value { return } |
5df54980 |
148 | |
a486d5ad |
149 | sub _inline_set_new_value { |
5df54980 |
150 | my $self = shift; |
151 | |
a486d5ad |
152 | return $self->_inline_store_value(@_) |
f878e6cf |
153 | if $self->_value_needs_copy |
154 | || !$self->_slot_access_can_be_inlined |
1e2c801e |
155 | || !$self->_get_is_lvalue; |
e32b7489 |
156 | |
a486d5ad |
157 | return $self->_inline_optimized_set_new_value(@_); |
f878e6cf |
158 | } |
159 | |
1e2c801e |
160 | sub _get_is_lvalue { |
f878e6cf |
161 | my $self = shift; |
162 | |
163 | return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue; |
164 | } |
e32b7489 |
165 | |
a486d5ad |
166 | sub _inline_optimized_set_new_value { |
e32b7489 |
167 | my $self = shift; |
168 | |
a486d5ad |
169 | return $self->_inline_store_value(@_); |
5df54980 |
170 | } |
171 | |
7f5ec80d |
172 | sub _return_value { |
53a4677c |
173 | my $self = shift; |
174 | my ($slot_access) = @_; |
7f5ec80d |
175 | |
176 | return $slot_access; |
177 | } |
5df54980 |
178 | |
8b9641b8 |
179 | no Moose::Role; |
180 | |
5df54980 |
181 | 1; |