fix pre-5.8.3 weak_ref setter as well
[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 use Scalar::Util 'blessed';
9 use overload ();
10 BEGIN {
11   our $CAN_HAZ_XS =
12     !$ENV{MOO_XS_DISABLE}
13       &&
14     _maybe_load_module('Class::XSAccessor')
15       &&
16     (eval { Class::XSAccessor->VERSION('1.07') })
17   ;
18 }
19
20 sub generate_method {
21   my ($self, $into, $name, $spec, $quote_opts) = @_;
22   $name =~ s/^\+//;
23   die "Must have an is" unless my $is = $spec->{is};
24   if ($is eq 'ro') {
25     $spec->{reader} = $name unless exists $spec->{reader};
26   } elsif ($is eq 'rw') {
27     $spec->{accessor} = $name unless exists $spec->{accessor};
28   } elsif ($is eq 'lazy') {
29     $spec->{reader} = $name unless exists $spec->{reader};
30     $spec->{lazy} = 1;
31     $spec->{builder} ||= '_build_'.$name unless $spec->{default};
32   } elsif ($is eq 'rwp') {
33     $spec->{reader} = $name unless exists $spec->{reader};
34     $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
35   } elsif ($is ne 'bare') {
36     die "Unknown is ${is}";
37   }
38   $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
39   die "Invalid builder for $into->$name - not a valid method name"
40     if exists $spec->{builder} and (ref $spec->{builder}
41       or $spec->{builder} !~ /\A[A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z_][A-Za-z0-9_]*)*\z/);
42   if (($spec->{predicate}||0) eq 1) {
43     $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
44   }
45   if (($spec->{clearer}||0) eq 1) {
46     $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
47   }
48   if (($spec->{trigger}||0) eq 1) {
49     $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
50   }
51
52   for my $setting (qw( default coerce )) {
53     next if !exists $spec->{$setting};
54     my $value = $spec->{$setting};
55     my $invalid = "Invalid $setting '" . overload::StrVal($value)
56       . "' for $into->$name - not a coderef";
57     die "$invalid or code-convertible object"
58       unless ref $value and (ref $value eq 'CODE' or blessed($value));
59     die "$invalid and could not be converted to a coderef: $@"
60       if !eval { \&$value };
61   }
62
63   my %methods;
64   if (my $reader = $spec->{reader}) {
65     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
66       $methods{$reader} = $self->_generate_xs(
67         getters => $into, $reader, $name, $spec
68       );
69     } else {
70       $self->{captures} = {};
71       $methods{$reader} =
72         quote_sub "${into}::${reader}"
73           => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
74              .$self->_generate_get($name, $spec)
75           => delete $self->{captures}
76         ;
77     }
78   }
79   if (my $accessor = $spec->{accessor}) {
80     if (
81       our $CAN_HAZ_XS
82       && $self->is_simple_get($name, $spec)
83       && $self->is_simple_set($name, $spec)
84     ) {
85       $methods{$accessor} = $self->_generate_xs(
86         accessors => $into, $accessor, $name, $spec
87       );
88     } else {
89       $self->{captures} = {};
90       $methods{$accessor} =
91         quote_sub "${into}::${accessor}"
92           => $self->_generate_getset($name, $spec)
93           => delete $self->{captures}
94         ;
95     }
96   }
97   if (my $writer = $spec->{writer}) {
98     if (
99       our $CAN_HAZ_XS
100       && $self->is_simple_set($name, $spec)
101     ) {
102       $methods{$writer} = $self->_generate_xs(
103         setters => $into, $writer, $name, $spec
104       );
105     } else {
106       $self->{captures} = {};
107       $methods{$writer} =
108         quote_sub "${into}::${writer}"
109           => $self->_generate_set($name, $spec)
110           => delete $self->{captures}
111         ;
112     }
113   }
114   if (my $pred = $spec->{predicate}) {
115     $methods{$pred} =
116       quote_sub "${into}::${pred}" =>
117         '    '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
118       ;
119   }
120   if (my $cl = $spec->{clearer}) {
121     $methods{$cl} =
122       quote_sub "${into}::${cl}" => 
123         $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
124       ;
125   }
126   if (my $hspec = $spec->{handles}) {
127     my $asserter = $spec->{asserter} ||= '_assert_'.$name;
128     my @specs = do {
129       if (ref($hspec) eq 'ARRAY') {
130         map [ $_ => $_ ], @$hspec;
131       } elsif (ref($hspec) eq 'HASH') {
132         map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
133           keys %$hspec;
134       } elsif (!ref($hspec)) {
135         map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
136       } else {
137         die "You gave me a handles of ${hspec} and I have no idea why";
138       }
139     };
140     foreach my $spec (@specs) {
141       my ($proxy, $target, @args) = @$spec;
142       $self->{captures} = {};
143       $methods{$proxy} =
144         quote_sub "${into}::${proxy}" =>
145           $self->_generate_delegation($asserter, $target, \@args),
146           delete $self->{captures}
147         ;
148     }
149   }
150   if (my $asserter = $spec->{asserter}) {
151     $self->{captures} = {};
152     $methods{$asserter} =
153       quote_sub "${into}::${asserter}" =>
154         'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
155         delete $self->{captures}
156       ;
157   }
158   \%methods;
159 }
160
161 sub is_simple_attribute {
162   my ($self, $name, $spec) = @_;
163   # clearer doesn't have to be listed because it doesn't
164   # affect whether defined/exists makes a difference
165   !grep $spec->{$_},
166     qw(lazy default builder coerce isa trigger predicate weak_ref);
167 }
168
169 sub is_simple_get {
170   my ($self, $name, $spec) = @_;
171   !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
172 }
173
174 sub is_simple_set {
175   my ($self, $name, $spec) = @_;
176   !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
177 }
178
179 sub has_eager_default {
180   my ($self, $name, $spec) = @_;
181   (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
182 }
183
184 sub _generate_get {
185   my ($self, $name, $spec) = @_;
186   my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
187   if ($self->is_simple_get($name, $spec)) {
188     $simple;
189   } else {
190     'do { '.$self->_generate_use_default(
191       '$_[0]', $name, $spec,
192       $self->_generate_simple_has('$_[0]', $name, $spec),
193     ).'; '
194     .($spec->{isa}
195       ?($self->_generate_isa_check($name, $simple, $spec->{isa}).'; ')
196       :''
197     )
198     .$simple.' }';
199   }
200 }
201
202 sub _generate_simple_has {
203   my ($self, $me, $name) = @_;
204   "exists ${me}->{${\perlstring $name}}";
205 }
206
207 sub _generate_simple_clear {
208   my ($self, $me, $name) = @_;
209   "    delete ${me}->{${\perlstring $name}}\n"
210 }
211
212 sub generate_get_default {
213   my $self = shift;
214   $self->{captures} = {};
215   my $code = $self->_generate_get_default(@_);
216   ($code, delete $self->{captures});
217 }
218
219 sub _generate_use_default {
220   my ($self, $me, $name, $spec, $test) = @_;
221   my $get_value = $self->_generate_get_default($me, $name, $spec);
222   if ($spec->{coerce}) {
223     $get_value = $self->_generate_coerce(
224       $name, $get_value,
225       $spec->{coerce}
226     )
227   }
228   $self->_generate_simple_set(
229     $me, $name, $spec, $get_value
230   ).' unless '.$test;
231 }
232
233 sub _generate_get_default {
234   my ($self, $me, $name, $spec) = @_;
235   $spec->{default}
236     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
237     : "${me}->${\$spec->{builder}}"
238 }
239
240 sub generate_simple_get {
241   my ($self, @args) = @_;
242   $self->_generate_simple_get(@args);
243 }
244
245 sub _generate_simple_get {
246   my ($self, $me, $name) = @_;
247   my $name_str = perlstring $name;
248   "${me}->{${name_str}}";
249 }
250
251 sub _generate_set {
252   my ($self, $name, $spec) = @_;
253   if ($self->is_simple_set($name, $spec)) {
254     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
255   } else {
256     my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
257     my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
258     my $code = "do { my (\$self, \$value) = \@_;\n";
259     if ($coerce) {
260       $code .=
261         "        \$value = "
262         .$self->_generate_coerce($name, '$value', $coerce).";\n";
263     }
264     if ($isa_check) {
265       $code .= 
266         "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
267     }
268     if ($trigger) {
269       my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
270       $code .=
271         "        ".$simple.";\n        ".$fire.";\n"
272         ."        \$value;\n";
273     } else {
274       $code .= "        ".$simple.";\n";
275     }
276     $code .= "      }";
277     $code;
278   }
279 }
280
281 sub generate_coerce {
282   my $self = shift;
283   $self->{captures} = {};
284   my $code = $self->_generate_coerce(@_);
285   ($code, delete $self->{captures});
286 }
287
288 sub _generate_coerce {
289   my ($self, $name, $value, $coerce) = @_;
290   $self->_generate_die_prefix(
291     "coercion for ${\perlstring($name)} failed: ",
292     $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
293   );
294 }
295  
296 sub generate_trigger {
297   my $self = shift;
298   $self->{captures} = {};
299   my $code = $self->_generate_trigger(@_);
300   ($code, delete $self->{captures});
301 }
302
303 sub _generate_trigger {
304   my ($self, $name, $obj, $value, $trigger) = @_;
305   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
306 }
307
308 sub generate_isa_check {
309   my ($self, @args) = @_;
310   $self->{captures} = {};
311   my $code = $self->_generate_isa_check(@args);
312   ($code, delete $self->{captures});
313 }
314
315 sub _generate_die_prefix {
316   my ($self, $prefix, $inside) = @_;
317   "do {\n"
318   .'  my $sig_die = $SIG{__DIE__} || sub { die $_[0] };'."\n"
319   .'  local $SIG{__DIE__} = sub {'."\n"
320   .'    $sig_die->(ref($_[0]) ? $_[0] : '.perlstring($prefix).'.$_[0]);'."\n"
321   .'  };'."\n"
322   .$inside
323   ."}\n"
324 }
325
326 sub _generate_isa_check {
327   my ($self, $name, $value, $check) = @_;
328   $self->_generate_die_prefix(
329     "isa check for ${\perlstring($name)} failed: ",
330     $self->_generate_call_code($name, 'isa_check', $value, $check)
331   );
332 }
333
334 sub _generate_call_code {
335   my ($self, $name, $type, $values, $sub) = @_;
336   if (my $quoted = quoted_from_sub($sub)) {
337     my $code = $quoted->[1];
338     if (my $captures = $quoted->[2]) {
339       my $cap_name = qq{\$${type}_captures_for_${name}};
340       $self->{captures}->{$cap_name} = \$captures;
341       Sub::Quote::inlinify(
342         $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), 1
343       );
344     } else {
345       Sub::Quote::inlinify($code, $values, undef, 1);
346     }
347   } else {
348     my $cap_name = qq{\$${type}_for_${name}};
349     $self->{captures}->{$cap_name} = \$sub;
350     "${cap_name}->(${values})";
351   }
352 }
353
354 sub generate_populate_set {
355   my $self = shift;
356   $self->{captures} = {};
357   my $code = $self->_generate_populate_set(@_);
358   ($code, delete $self->{captures});
359 }
360
361 sub _generate_populate_set {
362   my ($self, $me, $name, $spec, $source, $test) = @_;
363   if ($self->has_eager_default($name, $spec)) {
364     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
365     my $get_default = $self->_generate_get_default(
366                         '$new', $_, $spec
367                       );
368     my $get_value = 
369       defined($spec->{init_arg})
370         ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
371             .$get_default
372             ."\n${get_indent})"
373         : $get_default;
374     if ($spec->{coerce}) {
375       $get_value = $self->_generate_coerce(
376         $name, $get_value,
377         $spec->{coerce}
378       )
379     }
380     ($spec->{isa}
381       ? "    {\n      my \$value = ".$get_value.";\n      "
382         .$self->_generate_isa_check(
383           $name, '$value', $spec->{isa}
384         ).";\n"
385         .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
386         ."    }\n"
387       : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
388     )
389     .($spec->{trigger}
390       ? '    '
391         .$self->_generate_trigger(
392           $name, $me, $self->_generate_simple_get($me, $name, $spec),
393           $spec->{trigger}
394         )." if ${test};\n"
395       : ''
396     );
397   } else {
398     "    if (${test}) {\n"
399       .($spec->{coerce}
400         ? "      $source = "
401           .$self->_generate_coerce(
402             $name, $source,
403             $spec->{coerce}
404           ).";\n"
405         : ""
406       )
407       .($spec->{isa}
408         ? "      "
409           .$self->_generate_isa_check(
410             $name, $source, $spec->{isa}
411           ).";\n"
412         : ""
413       )
414       ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
415       .($spec->{trigger}
416         ? "      "
417           .$self->_generate_trigger(
418             $name, $me, $self->_generate_simple_get($me, $name, $spec),
419             $spec->{trigger}
420           ).";\n"
421         : ""
422       )
423       ."    }\n";
424   }
425 }
426
427 sub _generate_core_set {
428   my ($self, $me, $name, $spec, $value) = @_;
429   my $name_str = perlstring $name;
430   "${me}->{${name_str}} = ${value}";
431 }
432
433 sub _generate_simple_set {
434   my ($self, $me, $name, $spec, $value) = @_;
435   my $name_str = perlstring $name;
436
437   if ($spec->{weak_ref}) {
438     $value = '$preserve = '.$value;
439     my $simple = $self->_generate_core_set($me, $name, $spec, $value);
440     require Scalar::Util;
441
442     # Perl < 5.8.3 can't weaken refs to readonly vars
443     # (e.g. string constants). This *can* be solved by:
444     #
445     #Internals::SetReadWrite($foo);
446     #Scalar::Util::weaken ($foo);
447     #Internals::SetReadOnly($foo);
448     #
449     # but requires XS and is just too damn crazy
450     # so simply throw a better exception
451     my $weak_simple = "my \$preserve; Scalar::Util::weaken(${simple}); no warnings 'void'; \$preserve";
452     Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
453
454       my \$preserve;
455       eval { Scalar::Util::weaken($simple); 1 }
456         ? do { no warnings 'void'; \$preserve; }
457         : do {
458           if( \$@ =~ /Modification of a read-only value attempted/) {
459             require Carp;
460             Carp::croak( sprintf (
461               'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
462               $name_str,
463             ) );
464           } else {
465             die \$@;
466           }
467         }
468 EOC
469   } else {
470     $self->_generate_core_set($me, $name, $spec, $value);
471   }
472 }
473
474 sub _generate_getset {
475   my ($self, $name, $spec) = @_;
476   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
477     ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
478 }
479
480 sub _generate_delegation {
481   my ($self, $asserter, $target, $args) = @_;
482   my $arg_string = do {
483     if (@$args) {
484       # I could, I reckon, linearise out non-refs here using perlstring
485       # plus something to check for numbers but I'm unsure if it's worth it
486       $self->{captures}{'@curries'} = $args;
487       '@curries, @_';
488     } else {
489       '@_';
490     }
491   };
492   "shift->${asserter}->${target}(${arg_string});";
493 }
494
495 sub _generate_xs {
496   my ($self, $type, $into, $name, $slot) = @_;
497   Class::XSAccessor->import(
498     class => $into,
499     $type => { $name => $slot },
500     replace => 1,
501   );
502   $into->can($name);
503 }
504
505 sub default_construction_string { '{}' }
506
507 1;