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