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