Commit | Line | Data |
51a3b106 |
1 | package Method::Generate::Accessor; |
2 | |
3 | use strictures 1; |
b1eebd55 |
4 | use Moo::_Utils; |
5 | use base qw(Moo::Object); |
51a3b106 |
6 | use Sub::Quote; |
7 | use B 'perlstring'; |
daa05b62 |
8 | BEGIN { |
6e294299 |
9 | our $CAN_HAZ_XS = |
10 | _maybe_load_module('Class::XSAccessor') |
11 | && |
12 | (Class::XSAccessor->VERSION > 1.06) |
13 | ; |
daa05b62 |
14 | } |
51a3b106 |
15 | |
316917c9 |
16 | sub generate_method { |
6f68f022 |
17 | my ($self, $into, $name, $spec, $quote_opts) = @_; |
51a3b106 |
18 | die "Must have an is" unless my $is = $spec->{is}; |
a16d301e |
19 | local $self->{captures} = {}; |
51a3b106 |
20 | my $body = do { |
21 | if ($is eq 'ro') { |
e6f2e914 |
22 | if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) { |
23 | $self->_generate_xs_get($into, $name); |
24 | } else { |
25 | $self->_generate_get($name, $spec) |
26 | } |
51a3b106 |
27 | } elsif ($is eq 'rw') { |
e6f2e914 |
28 | if ( |
29 | our $CAN_HAZ_XS |
30 | && $self->is_simple_get($name, $spec) |
31 | && $self->is_simple_set($name, $spec) |
32 | ) { |
33 | $self->_generate_xs_getset($into, $name); |
34 | } else { |
35 | $self->_generate_getset($name, $spec) |
36 | } |
51a3b106 |
37 | } else { |
38 | die "Unknown is ${is}"; |
39 | } |
40 | }; |
8f333548 |
41 | if (my $pred = $spec->{predicate}) { |
42 | quote_sub "${into}::${pred}" => |
e6f2e914 |
43 | ' '.$self->_generate_simple_has('$_[0]', $name)."\n" |
8f333548 |
44 | ; |
45 | } |
46 | if (my $cl = $spec->{clearer}) { |
47 | quote_sub "${into}::${cl}" => |
48 | " delete \$_[0]->{${\perlstring $name}}\n" |
49 | ; |
50 | } |
901efe1a |
51 | if (ref($body)) { |
52 | $body; |
53 | } else { |
54 | quote_sub |
55 | "${into}::${name}" => ' '.$body."\n", |
56 | $self->{captures}, $quote_opts||{} |
57 | ; |
58 | } |
51a3b106 |
59 | } |
60 | |
3a9a65a4 |
61 | sub is_simple_attribute { |
62 | my ($self, $name, $spec) = @_; |
8f333548 |
63 | # clearer doesn't have to be listed because it doesn't |
64 | # affect whether defined/exists makes a difference |
901efe1a |
65 | !grep $spec->{$_}, |
8f333548 |
66 | qw(lazy default builder isa trigger predicate); |
3a9a65a4 |
67 | } |
68 | |
daa05b62 |
69 | sub is_simple_get { |
70 | my ($self, $name, $spec) = @_; |
901efe1a |
71 | !($spec->{lazy} and ($spec->{default} or $spec->{builder})); |
daa05b62 |
72 | } |
73 | |
74 | sub is_simple_set { |
75 | my ($self, $name, $spec) = @_; |
901efe1a |
76 | !grep $spec->{$_}, qw(isa trigger); |
daa05b62 |
77 | } |
78 | |
51a3b106 |
79 | sub _generate_get { |
46389f86 |
80 | my ($self, $name, $spec) = @_; |
81 | my $simple = $self->_generate_simple_get('$_[0]', $name); |
901efe1a |
82 | if ($self->is_simple_get($name, $spec)) { |
83 | $simple; |
84 | } else { |
85 | 'do { '.$self->_generate_use_default( |
86 | '$_[0]', $name, $spec, |
87 | $self->_generate_simple_has('$_[0]', $name), |
88 | ).'; '.$simple.' }'; |
89 | } |
46389f86 |
90 | } |
91 | |
92 | sub _generate_simple_has { |
93 | my ($self, $me, $name) = @_; |
94 | "exists ${me}->{${\perlstring $name}}"; |
95 | } |
96 | |
649ac264 |
97 | sub generate_get_default { |
98 | my $self = shift; |
99 | local $self->{captures} = {}; |
100 | my $code = $self->_generate_get_default(@_); |
901efe1a |
101 | ($code, $self->{captures}); |
649ac264 |
102 | } |
103 | |
104 | sub _generate_use_default { |
105 | my ($self, $me, $name, $spec, $test) = @_; |
46389f86 |
106 | $self->_generate_simple_set( |
649ac264 |
107 | $me, $name, $self->_generate_get_default($me, $name, $spec) |
46389f86 |
108 | ).' unless '.$test; |
a16d301e |
109 | } |
110 | |
649ac264 |
111 | sub _generate_get_default { |
112 | my ($self, $me, $name, $spec) = @_; |
113 | $spec->{default} |
114 | ? $self->_generate_call_code($name, 'default', $me, $spec->{default}) |
115 | : "${me}->${\$spec->{builder}}" |
116 | } |
117 | |
a16d301e |
118 | sub generate_simple_get { |
901efe1a |
119 | my ($self, @args) = @_; |
120 | $self->_generate_simple_get(@args); |
a16d301e |
121 | } |
122 | |
123 | sub _generate_simple_get { |
124 | my ($self, $me, $name) = @_; |
125 | my $name_str = perlstring $name; |
126 | "${me}->{${name_str}}"; |
51a3b106 |
127 | } |
128 | |
129 | sub _generate_set { |
a16d301e |
130 | my ($self, $name, $value, $spec) = @_; |
46389f86 |
131 | my $simple = $self->_generate_simple_set('$_[0]', $name, $value); |
901efe1a |
132 | if ($self->is_simple_set($name, $spec)) { |
133 | $simple; |
6d377074 |
134 | } else { |
901efe1a |
135 | my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)}; |
136 | my $code = "do {\n"; |
137 | if ($isa_check) { |
138 | $code .= |
139 | " ".$self->_generate_isa_check($name, '$_[1]', $isa_check).";\n"; |
140 | } |
141 | if ($trigger) { |
142 | my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger); |
143 | $code .= |
144 | " my \$value = ".$simple.";\n ".$fire.";\n" |
145 | ." \$value;\n"; |
146 | } else { |
147 | $code .= " ".$simple.";\n"; |
148 | } |
149 | $code .= " }"; |
150 | $code; |
a16d301e |
151 | } |
a16d301e |
152 | } |
901efe1a |
153 | |
a16d301e |
154 | sub generate_trigger { |
155 | my $self = shift; |
156 | local $self->{captures} = {}; |
157 | my $code = $self->_generate_trigger(@_); |
901efe1a |
158 | ($code, $self->{captures}); |
a16d301e |
159 | } |
160 | |
161 | sub _generate_trigger { |
162 | my ($self, $name, $obj, $value, $trigger) = @_; |
6d377074 |
163 | $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger); |
164 | } |
165 | |
166 | sub generate_isa_check { |
901efe1a |
167 | my ($self, @args) = @_; |
6d377074 |
168 | local $self->{captures} = {}; |
901efe1a |
169 | my $code = $self->_generate_isa_check(@args); |
170 | ($code, $self->{captures}); |
6d377074 |
171 | } |
172 | |
173 | sub _generate_isa_check { |
174 | my ($self, $name, $value, $check) = @_; |
175 | $self->_generate_call_code($name, 'isa_check', $value, $check); |
176 | } |
177 | |
178 | sub _generate_call_code { |
179 | my ($self, $name, $type, $values, $sub) = @_; |
180 | if (my $quoted = quoted_from_sub($sub)) { |
625d6219 |
181 | my $code = $quoted->[1]; |
6d377074 |
182 | my $at_ = 'local @_ = ('.$values.');'; |
8c6626cf |
183 | if (my $captures = $quoted->[2]) { |
6d377074 |
184 | my $cap_name = qq{\$${type}_captures_for_${name}}; |
8c6626cf |
185 | $self->{captures}->{$cap_name} = \$captures; |
186 | return "do {\n".' '.$at_."\n" |
17a8e3f0 |
187 | .Sub::Quote::capture_unroll($cap_name, $captures, 6) |
188 | ." ${code}\n }"; |
8c6626cf |
189 | } |
901efe1a |
190 | 'do { local @_ = ('.$values.'); '.$code.' }'; |
191 | } else { |
192 | my $cap_name = qq{\$${type}_for_${name}}; |
193 | $self->{captures}->{$cap_name} = \$sub; |
194 | "${cap_name}->(${values})"; |
625d6219 |
195 | } |
a16d301e |
196 | } |
197 | |
3a9a65a4 |
198 | sub generate_populate_set { |
199 | my $self = shift; |
200 | local $self->{captures} = {}; |
201 | my $code = $self->_generate_populate_set(@_); |
901efe1a |
202 | ($code, $self->{captures}); |
3a9a65a4 |
203 | } |
204 | |
205 | sub _generate_populate_set { |
206 | my ($self, $me, $name, $spec, $source, $test) = @_; |
207 | if (!$spec->{lazy} and |
208 | ($spec->{default} or $spec->{builder})) { |
209 | my $get_indent = ' ' x ($spec->{isa} ? 6 : 4); |
210 | my $get_value = |
211 | "(\n${get_indent} ${test}\n${get_indent} ? ${source}\n${get_indent} : " |
212 | .$self->_generate_get_default( |
213 | '$new', $_, $spec |
214 | ) |
215 | ."\n${get_indent})"; |
216 | ($spec->{isa} |
217 | ? " {\n my \$value = ".$get_value.";\n " |
5d349892 |
218 | .$self->_generate_isa_check( |
219 | $name, '$value', $spec->{isa} |
220 | ).";\n" |
221 | .' '.$self->_generate_simple_set($me, $name, '$value').";\n" |
222 | ." }\n" |
3a9a65a4 |
223 | : ' '.$self->_generate_simple_set($me, $name, $get_value).";\n" |
224 | ) |
225 | .($spec->{trigger} |
226 | ? ' ' |
5d349892 |
227 | .$self->_generate_trigger( |
228 | $name, $me, $self->_generate_simple_get($me, $name), |
229 | $spec->{trigger} |
230 | )." if ${test};\n" |
3a9a65a4 |
231 | : '' |
232 | ); |
233 | } else { |
234 | " if (${test}) {\n" |
235 | .($spec->{isa} |
236 | ? " " |
5d349892 |
237 | .$self->_generate_isa_check( |
238 | $name, $source, $spec->{isa} |
239 | ).";\n" |
3a9a65a4 |
240 | : "" |
241 | ) |
242 | ." ".$self->_generate_simple_set($me, $name, $source).";\n" |
243 | .($spec->{trigger} |
5d349892 |
244 | ? " " |
245 | .$self->_generate_trigger( |
246 | $name, $me, $self->_generate_simple_get($me, $name), |
247 | $spec->{trigger} |
248 | ).";\n" |
249 | : "" |
3a9a65a4 |
250 | ) |
251 | ." }\n"; |
252 | } |
253 | } |
254 | |
255 | sub generate_multi_set { |
256 | my ($self, $me, $to_set, $from) = @_; |
257 | "\@{${me}}{qw(${\join ' ', @$to_set})} = $from"; |
258 | } |
259 | |
649ac264 |
260 | sub generate_simple_set { |
261 | my $self = shift; |
262 | local $self->{captures} = {}; |
263 | my $code = $self->_generate_simple_set(@_); |
901efe1a |
264 | ($code, $self->{captures}); |
649ac264 |
265 | } |
266 | |
a16d301e |
267 | sub _generate_simple_set { |
46389f86 |
268 | my ($self, $me, $name, $value) = @_; |
a16d301e |
269 | my $name_str = perlstring $name; |
46389f86 |
270 | "${me}->{${name_str}} = ${value}"; |
51a3b106 |
271 | } |
272 | |
273 | sub _generate_getset { |
a16d301e |
274 | my ($self, $name, $spec) = @_; |
e6f2e914 |
275 | q{(@_ > 1}."\n ? ".$self->_generate_set($name, q{$_[1]}, $spec) |
276 | ."\n : ".$self->_generate_get($name)."\n )"; |
51a3b106 |
277 | } |
278 | |
daa05b62 |
279 | sub _generate_xs_get { |
280 | shift->_generate_xs('getters', @_); |
281 | } |
282 | |
283 | sub _generate_xs_getset { |
284 | shift->_generate_xs('accessors', @_); |
285 | } |
286 | |
287 | sub _generate_xs { |
e6f2e914 |
288 | my ($self, $type, $into, $name) = @_; |
daa05b62 |
289 | no strict 'refs'; |
290 | Class::XSAccessor->import( |
e6f2e914 |
291 | class => $into, |
daa05b62 |
292 | $type => { $name => $name } |
293 | ); |
901efe1a |
294 | $into->can($name); |
daa05b62 |
295 | } |
296 | |
51a3b106 |
297 | 1; |