handles and asserter support
[gitmo/Moo.git] / lib / Method / Generate / Accessor.pm
1 package Method::Generate::Accessor;
2
3 use strictures 1;
4 use Moo::_Utils;
5 use base qw(Moo::Object);
6 use Sub::Quote;
7 use B 'perlstring';
8 BEGIN {
9   our $CAN_HAZ_XS =
10     _maybe_load_module('Class::XSAccessor')
11       &&
12     (Class::XSAccessor->VERSION > 1.06)
13   ;
14 }
15
16 sub generate_method {
17   my ($self, $into, $name, $spec, $quote_opts) = @_;
18   die "Must have an is" unless my $is = $spec->{is};
19   if ($is eq 'ro') {
20     $spec->{reader} = $name unless exists $spec->{reader};
21   } elsif ($is eq 'rw') {
22     $spec->{accessor} = $name unless exists $spec->{accessor};
23   } elsif ($is eq 'lazy') {
24     $spec->{init_arg} = undef unless exists $spec->{init_arg};
25     $spec->{reader} = $name unless exists $spec->{reader};
26     $spec->{lazy} = 1;
27     $spec->{builder} ||= '_build_'.$name unless $spec->{default};
28   } elsif ($is ne 'bare') {
29     die "Unknown is ${is}";
30   }
31   my %methods;
32   if (my $reader = $spec->{reader}) {
33     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
34       $methods{$reader} = $self->_generate_xs(
35         getters => $into, $reader, $name
36       );
37     } else {
38       local $self->{captures} = {};
39       $methods{$reader} =
40         quote_sub "${into}::${reader}"
41           => $self->_generate_get($name, $spec)
42           => $self->{captures}
43         ;
44     }
45   }
46   if (my $accessor = $spec->{accessor}) {
47     if (
48       our $CAN_HAZ_XS
49       && $self->is_simple_get($name, $spec)
50       && $self->is_simple_set($name, $spec)
51     ) {
52       $methods{$accessor} = $self->_generate_xs(
53         accessors => $into, $accessor, $name
54       );
55     } else {
56       local $self->{captures} = {};
57       $methods{$accessor} =
58         quote_sub "${into}::${accessor}"
59           => $self->_generate_getset($name, $spec)
60           => $self->{captures}
61         ;
62     }
63   }
64   if (my $writer = $spec->{writer}) {
65     if (
66       our $CAN_HAZ_XS
67       && $self->is_simple_set($name, $spec)
68     ) {
69       $methods{$writer} = $self->_generate_xs(
70         setters => $into, $writer, $name
71       );
72     } else {
73       local $self->{captures} = {};
74       $methods{$writer} =
75         quote_sub "${into}::${writer}"
76           => $self->_generate_set($name, $spec)
77           => $self->{captures}
78         ;
79     }
80   }
81   if (my $pred = $spec->{predicate}) {
82     $methods{$pred} =
83       quote_sub "${into}::${pred}" =>
84         '    '.$self->_generate_simple_has('$_[0]', $name)."\n"
85       ;
86   }
87   if (my $cl = $spec->{clearer}) {
88     $methods{$cl} =
89       quote_sub "${into}::${cl}" => 
90         "    delete \$_[0]->{${\perlstring $name}}\n"
91       ;
92   }
93   if (my $hspec = $spec->{handles}) {
94     my $asserter = $spec->{asserter} ||= '_assert_'.$name;
95     my @specs = do {
96       if (ref($hspec) eq 'ARRAY') {
97         map [ $_ => $_ ], @$hspec;
98       } elsif (ref($hspec) eq 'HASH') {
99         map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
100           keys %$hspec;
101       } elsif (!ref($hspec)) {
102         map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
103       } else {
104         die "You gave me a handles of ${hspec} and I have no idea why";
105       }
106     };
107     foreach my $spec (@specs) {
108       my ($proxy, $target, @args) = @$spec;
109       local $self->{captures} = {};
110       $methods{$proxy} =
111         quote_sub "${into}::${proxy}" =>
112           $self->_generate_delegation($asserter, $target, \@args),
113           $self->{captures}
114         ;
115     }
116   }
117   if (my $asserter = $spec->{asserter}) {
118     local $self->{captures} = {};
119     $methods{$asserter} =
120       quote_sub "${into}::${asserter}" =>
121         'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
122         $self->{captures}
123       ;
124   }
125   \%methods;
126 }
127
128 sub is_simple_attribute {
129   my ($self, $name, $spec) = @_;
130   # clearer doesn't have to be listed because it doesn't
131   # affect whether defined/exists makes a difference
132   !grep $spec->{$_},
133     qw(lazy default builder isa trigger predicate);
134 }
135
136 sub is_simple_get {
137   my ($self, $name, $spec) = @_;
138   !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
139 }
140
141 sub is_simple_set {
142   my ($self, $name, $spec) = @_;
143   !grep $spec->{$_}, qw(isa trigger);
144 }
145
146 sub _generate_get {
147   my ($self, $name, $spec) = @_;
148   my $simple = $self->_generate_simple_get('$_[0]', $name);
149   if ($self->is_simple_get($name, $spec)) {
150     $simple;
151   } else {
152     'do { '.$self->_generate_use_default(
153       '$_[0]', $name, $spec,
154       $self->_generate_simple_has('$_[0]', $name),
155     ).'; '.$simple.' }';
156   }
157 }
158
159 sub _generate_simple_has {
160   my ($self, $me, $name) = @_;
161   "exists ${me}->{${\perlstring $name}}";
162 }
163
164 sub generate_get_default {
165   my $self = shift;
166   local $self->{captures} = {};
167   my $code = $self->_generate_get_default(@_);
168   ($code, $self->{captures});
169 }
170
171 sub _generate_use_default {
172   my ($self, $me, $name, $spec, $test) = @_;
173   $self->_generate_simple_set(
174     $me, $name, $self->_generate_get_default($me, $name, $spec)
175   ).' unless '.$test;
176 }
177
178 sub _generate_get_default {
179   my ($self, $me, $name, $spec) = @_;
180   $spec->{default}
181     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
182     : "${me}->${\$spec->{builder}}"
183 }
184
185 sub generate_simple_get {
186   my ($self, @args) = @_;
187   $self->_generate_simple_get(@args);
188 }
189
190 sub _generate_simple_get {
191   my ($self, $me, $name) = @_;
192   my $name_str = perlstring $name;
193   "${me}->{${name_str}}";
194 }
195
196 sub _generate_set {
197   my ($self, $name, $spec) = @_;
198   my $simple = $self->_generate_simple_set('$_[0]', $name, '$_[1]');
199   if ($self->is_simple_set($name, $spec)) {
200     $simple;
201   } else {
202     my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
203     my $code = "do {\n";
204     if ($isa_check) {
205       $code .= 
206         "        ".$self->_generate_isa_check($name, '$_[1]', $isa_check).";\n";
207     }
208     if ($trigger) {
209       my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
210       $code .=
211         "        my \$value = ".$simple.";\n        ".$fire.";\n"
212         ."        \$value;\n";
213     } else {
214       $code .= "        ".$simple.";\n";
215     }
216     $code .= "      }";
217     $code;
218   }
219 }
220   
221 sub generate_trigger {
222   my $self = shift;
223   local $self->{captures} = {};
224   my $code = $self->_generate_trigger(@_);
225   ($code, $self->{captures});
226 }
227
228 sub _generate_trigger {
229   my ($self, $name, $obj, $value, $trigger) = @_;
230   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
231 }
232
233 sub generate_isa_check {
234   my ($self, @args) = @_;
235   local $self->{captures} = {};
236   my $code = $self->_generate_isa_check(@args);
237   ($code, $self->{captures});
238 }
239
240 sub _generate_isa_check {
241   my ($self, $name, $value, $check) = @_;
242   $self->_generate_call_code($name, 'isa_check', $value, $check);
243 }
244
245 sub _generate_call_code {
246   my ($self, $name, $type, $values, $sub) = @_;
247   if (my $quoted = quoted_from_sub($sub)) {
248     my $code = $quoted->[1];
249     my $at_ = 'local @_ = ('.$values.');';
250     if (my $captures = $quoted->[2]) {
251       my $cap_name = qq{\$${type}_captures_for_${name}};
252       $self->{captures}->{$cap_name} = \$captures;
253       return "do {\n".'      '.$at_."\n"
254         .Sub::Quote::capture_unroll($cap_name, $captures, 6)
255         ."     ${code}\n    }";
256     }
257     'do { local @_ = ('.$values.'); '.$code.' }';
258   } else {
259     my $cap_name = qq{\$${type}_for_${name}};
260     $self->{captures}->{$cap_name} = \$sub;
261     "${cap_name}->(${values})";
262   }
263 }
264
265 sub generate_populate_set {
266   my $self = shift;
267   local $self->{captures} = {};
268   my $code = $self->_generate_populate_set(@_);
269   ($code, $self->{captures});
270 }
271
272 sub _generate_populate_set {
273   my ($self, $me, $name, $spec, $source, $test) = @_;
274   if (!$spec->{lazy} and
275         ($spec->{default} or $spec->{builder})) {
276     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
277     my $get_value = 
278       "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
279         .$self->_generate_get_default(
280           '$new', $_, $spec
281         )
282         ."\n${get_indent})";
283     ($spec->{isa}
284       ? "    {\n      my \$value = ".$get_value.";\n      "
285         .$self->_generate_isa_check(
286           $name, '$value', $spec->{isa}
287         ).";\n"
288         .'      '.$self->_generate_simple_set($me, $name, '$value').";\n"
289         ."    }\n"
290       : '    '.$self->_generate_simple_set($me, $name, $get_value).";\n"
291     )
292     .($spec->{trigger}
293       ? '    '
294         .$self->_generate_trigger(
295           $name, $me, $self->_generate_simple_get($me, $name),
296           $spec->{trigger}
297         )." if ${test};\n"
298       : ''
299     );
300   } else {
301     "    if (${test}) {\n"
302       .($spec->{isa}
303         ? "      "
304           .$self->_generate_isa_check(
305             $name, $source, $spec->{isa}
306           ).";\n"
307         : ""
308       )
309       ."      ".$self->_generate_simple_set($me, $name, $source).";\n"
310       .($spec->{trigger}
311         ? "      "
312           .$self->_generate_trigger(
313             $name, $me, $self->_generate_simple_get($me, $name),
314             $spec->{trigger}
315           ).";\n"
316         : ""
317       )
318       ."    }\n";
319   }
320 }
321
322 sub generate_multi_set {
323   my ($self, $me, $to_set, $from) = @_;
324   "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
325 }
326
327 sub generate_simple_set {
328   my $self = shift;
329   local $self->{captures} = {};
330   my $code = $self->_generate_simple_set(@_);
331   ($code, $self->{captures});
332 }
333
334 sub _generate_simple_set {
335   my ($self, $me, $name, $value) = @_;
336   my $name_str = perlstring $name;
337   "${me}->{${name_str}} = ${value}";
338 }
339
340 sub _generate_getset {
341   my ($self, $name, $spec) = @_;
342   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
343     ."\n      : ".$self->_generate_get($name)."\n    )";
344 }
345
346 sub _generate_delegation {
347   my ($self, $asserter, $target, $args) = @_;
348   my $arg_string = do {
349     if (@$args) {
350       # I could, I reckon, linearise out non-refs here using perlstring
351       # plus something to check for numbers but I'm unsure if it's worth it
352       $self->{captures}{'@curries'} = $args;
353       '@curries, @_';
354     } else {
355       '@_';
356     }
357   };
358   "shift->${asserter}->${target}(${arg_string});";
359 }
360
361 sub _generate_xs {
362   my ($self, $type, $into, $name, $slot) = @_;
363   Class::XSAccessor->import(
364     class => $into,
365     $type => { $name => $slot }
366   );
367   $into->can($name);
368 }
369
370 1;