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