clean up coerce generation a bit
[gitmo/Moo.git] / lib / Method / Generate / Accessor.pm
CommitLineData
51a3b106 1package Method::Generate::Accessor;
2
3use strictures 1;
b1eebd55 4use Moo::_Utils;
5use base qw(Moo::Object);
51a3b106 6use Sub::Quote;
7use B 'perlstring';
daa05b62 8BEGIN {
6e294299 9 our $CAN_HAZ_XS =
33d35735 10 !$ENV{MOO_XS_DISABLE}
11 &&
6e294299 12 _maybe_load_module('Class::XSAccessor')
13 &&
edb9977c 14 (eval { Class::XSAccessor->VERSION('1.07') })
6e294299 15 ;
daa05b62 16}
51a3b106 17
316917c9 18sub generate_method {
6f68f022 19 my ($self, $into, $name, $spec, $quote_opts) = @_;
51a3b106 20 die "Must have an is" unless my $is = $spec->{is};
dcae37d3 21 if ($is eq 'ro') {
22 $spec->{reader} = $name unless exists $spec->{reader};
23 } elsif ($is eq 'rw') {
24 $spec->{accessor} = $name unless exists $spec->{accessor};
25 } elsif ($is eq 'lazy') {
26 $spec->{init_arg} = undef unless exists $spec->{init_arg};
27 $spec->{reader} = $name unless exists $spec->{reader};
28 $spec->{lazy} = 1;
29 $spec->{builder} ||= '_build_'.$name unless $spec->{default};
30 } elsif ($is ne 'bare') {
31 die "Unknown is ${is}";
32 }
33 my %methods;
34 if (my $reader = $spec->{reader}) {
35 if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
36 $methods{$reader} = $self->_generate_xs(
37 getters => $into, $reader, $name
38 );
39 } else {
e57f338d 40 $self->{captures} = {};
dcae37d3 41 $methods{$reader} =
42 quote_sub "${into}::${reader}"
33d35735 43 => ' die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
44 .$self->_generate_get($name, $spec)
e57f338d 45 => delete $self->{captures}
dcae37d3 46 ;
47 }
48 }
49 if (my $accessor = $spec->{accessor}) {
50 if (
51 our $CAN_HAZ_XS
52 && $self->is_simple_get($name, $spec)
53 && $self->is_simple_set($name, $spec)
54 ) {
55 $methods{$accessor} = $self->_generate_xs(
56 accessors => $into, $accessor, $name
57 );
58 } else {
e57f338d 59 $self->{captures} = {};
dcae37d3 60 $methods{$accessor} =
61 quote_sub "${into}::${accessor}"
62 => $self->_generate_getset($name, $spec)
e57f338d 63 => delete $self->{captures}
dcae37d3 64 ;
65 }
66 }
67 if (my $writer = $spec->{writer}) {
68 if (
69 our $CAN_HAZ_XS
70 && $self->is_simple_set($name, $spec)
71 ) {
72 $methods{$writer} = $self->_generate_xs(
73 setters => $into, $writer, $name
74 );
51a3b106 75 } else {
e57f338d 76 $self->{captures} = {};
dcae37d3 77 $methods{$writer} =
78 quote_sub "${into}::${writer}"
79 => $self->_generate_set($name, $spec)
e57f338d 80 => delete $self->{captures}
dcae37d3 81 ;
51a3b106 82 }
dcae37d3 83 }
8f333548 84 if (my $pred = $spec->{predicate}) {
dcae37d3 85 $methods{$pred} =
86 quote_sub "${into}::${pred}" =>
87 ' '.$self->_generate_simple_has('$_[0]', $name)."\n"
88 ;
8f333548 89 }
90 if (my $cl = $spec->{clearer}) {
dcae37d3 91 $methods{$cl} =
92 quote_sub "${into}::${cl}" =>
93 " delete \$_[0]->{${\perlstring $name}}\n"
94 ;
901efe1a 95 }
4db3a740 96 if (my $hspec = $spec->{handles}) {
97 my $asserter = $spec->{asserter} ||= '_assert_'.$name;
98 my @specs = do {
99 if (ref($hspec) eq 'ARRAY') {
100 map [ $_ => $_ ], @$hspec;
101 } elsif (ref($hspec) eq 'HASH') {
102 map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
103 keys %$hspec;
104 } elsif (!ref($hspec)) {
105 map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
106 } else {
107 die "You gave me a handles of ${hspec} and I have no idea why";
108 }
109 };
110 foreach my $spec (@specs) {
111 my ($proxy, $target, @args) = @$spec;
e57f338d 112 $self->{captures} = {};
4db3a740 113 $methods{$proxy} =
114 quote_sub "${into}::${proxy}" =>
115 $self->_generate_delegation($asserter, $target, \@args),
e57f338d 116 delete $self->{captures}
4db3a740 117 ;
118 }
119 }
120 if (my $asserter = $spec->{asserter}) {
e57f338d 121 $self->{captures} = {};
4db3a740 122 $methods{$asserter} =
123 quote_sub "${into}::${asserter}" =>
124 'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
e57f338d 125 delete $self->{captures}
4db3a740 126 ;
127 }
dcae37d3 128 \%methods;
51a3b106 129}
130
3a9a65a4 131sub is_simple_attribute {
132 my ($self, $name, $spec) = @_;
8f333548 133 # clearer doesn't have to be listed because it doesn't
134 # affect whether defined/exists makes a difference
901efe1a 135 !grep $spec->{$_},
82a5b146 136 qw(lazy default builder coerce isa trigger predicate weak_ref);
3a9a65a4 137}
138
daa05b62 139sub is_simple_get {
140 my ($self, $name, $spec) = @_;
901efe1a 141 !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
daa05b62 142}
143
144sub is_simple_set {
145 my ($self, $name, $spec) = @_;
82a5b146 146 !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
daa05b62 147}
148
4ced3a94 149sub has_eager_default {
150 my ($self, $name, $spec) = @_;
151 (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
152}
153
51a3b106 154sub _generate_get {
46389f86 155 my ($self, $name, $spec) = @_;
156 my $simple = $self->_generate_simple_get('$_[0]', $name);
901efe1a 157 if ($self->is_simple_get($name, $spec)) {
158 $simple;
159 } else {
160 'do { '.$self->_generate_use_default(
161 '$_[0]', $name, $spec,
162 $self->_generate_simple_has('$_[0]', $name),
163 ).'; '.$simple.' }';
164 }
46389f86 165}
166
167sub _generate_simple_has {
168 my ($self, $me, $name) = @_;
169 "exists ${me}->{${\perlstring $name}}";
170}
171
649ac264 172sub generate_get_default {
173 my $self = shift;
e57f338d 174 $self->{captures} = {};
649ac264 175 my $code = $self->_generate_get_default(@_);
e57f338d 176 ($code, delete $self->{captures});
649ac264 177}
178
179sub _generate_use_default {
180 my ($self, $me, $name, $spec, $test) = @_;
160c2c2c 181 my $get_value = $self->_generate_get_default($me, $name, $spec);
182 if ($spec->{coerce}) {
183 $get_value = $self->_generate_coerce(
b1f04da5 184 $name, $get_value,
160c2c2c 185 $spec->{coerce}
186 )
187 }
46389f86 188 $self->_generate_simple_set(
160c2c2c 189 $me, $name, $spec, $get_value
46389f86 190 ).' unless '.$test;
a16d301e 191}
192
649ac264 193sub _generate_get_default {
194 my ($self, $me, $name, $spec) = @_;
195 $spec->{default}
196 ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
197 : "${me}->${\$spec->{builder}}"
198}
199
a16d301e 200sub generate_simple_get {
901efe1a 201 my ($self, @args) = @_;
202 $self->_generate_simple_get(@args);
a16d301e 203}
204
205sub _generate_simple_get {
206 my ($self, $me, $name) = @_;
207 my $name_str = perlstring $name;
208 "${me}->{${name_str}}";
51a3b106 209}
210
211sub _generate_set {
dcae37d3 212 my ($self, $name, $spec) = @_;
901efe1a 213 if ($self->is_simple_set($name, $spec)) {
32381de9 214 $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
6d377074 215 } else {
82a5b146 216 my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
32381de9 217 my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
e57f338d 218 my $code = "do { my (\$self, \$value) = \@_;\n";
82a5b146 219 if ($coerce) {
220 $code .=
221 " \$value = "
b1f04da5 222 .$self->_generate_coerce($name, '$value', $coerce).";\n";
82a5b146 223 }
901efe1a 224 if ($isa_check) {
225 $code .=
e57f338d 226 " ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
901efe1a 227 }
228 if ($trigger) {
e57f338d 229 my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
901efe1a 230 $code .=
e57f338d 231 " ".$simple.";\n ".$fire.";\n"
901efe1a 232 ." \$value;\n";
233 } else {
234 $code .= " ".$simple.";\n";
235 }
236 $code .= " }";
237 $code;
a16d301e 238 }
a16d301e 239}
82a5b146 240
241sub generate_coerce {
242 my $self = shift;
243 $self->{captures} = {};
244 my $code = $self->_generate_coerce(@_);
245 ($code, delete $self->{captures});
246}
247
248sub _generate_coerce {
b1f04da5 249 my ($self, $name, $value, $coerce) = @_;
82a5b146 250 $self->_generate_call_code($name, 'coerce', "${value}", $coerce);
251}
252
a16d301e 253sub generate_trigger {
254 my $self = shift;
e57f338d 255 $self->{captures} = {};
a16d301e 256 my $code = $self->_generate_trigger(@_);
e57f338d 257 ($code, delete $self->{captures});
a16d301e 258}
259
260sub _generate_trigger {
261 my ($self, $name, $obj, $value, $trigger) = @_;
6d377074 262 $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
263}
264
265sub generate_isa_check {
901efe1a 266 my ($self, @args) = @_;
e57f338d 267 $self->{captures} = {};
901efe1a 268 my $code = $self->_generate_isa_check(@args);
e57f338d 269 ($code, delete $self->{captures});
6d377074 270}
271
272sub _generate_isa_check {
273 my ($self, $name, $value, $check) = @_;
274 $self->_generate_call_code($name, 'isa_check', $value, $check);
275}
276
277sub _generate_call_code {
278 my ($self, $name, $type, $values, $sub) = @_;
279 if (my $quoted = quoted_from_sub($sub)) {
625d6219 280 my $code = $quoted->[1];
e57f338d 281 my $at_ = '@_ = ('.$values.');';
8c6626cf 282 if (my $captures = $quoted->[2]) {
6d377074 283 my $cap_name = qq{\$${type}_captures_for_${name}};
8c6626cf 284 $self->{captures}->{$cap_name} = \$captures;
e57f338d 285 Sub::Quote::inlinify(
286 $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6)
287 );
288 } else {
289 Sub::Quote::inlinify($code, $values);
8c6626cf 290 }
901efe1a 291 } else {
292 my $cap_name = qq{\$${type}_for_${name}};
293 $self->{captures}->{$cap_name} = \$sub;
294 "${cap_name}->(${values})";
625d6219 295 }
a16d301e 296}
297
3a9a65a4 298sub generate_populate_set {
299 my $self = shift;
e57f338d 300 $self->{captures} = {};
3a9a65a4 301 my $code = $self->_generate_populate_set(@_);
e57f338d 302 ($code, delete $self->{captures});
3a9a65a4 303}
304
305sub _generate_populate_set {
306 my ($self, $me, $name, $spec, $source, $test) = @_;
4ced3a94 307 if ($self->has_eager_default($name, $spec)) {
3a9a65a4 308 my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
d02da2bc 309 my $get_default = $self->_generate_get_default(
310 '$new', $_, $spec
311 );
3a9a65a4 312 my $get_value =
d02da2bc 313 defined($spec->{init_arg})
314 ? "(\n${get_indent} ${test}\n${get_indent} ? ${source}\n${get_indent} : "
315 .$get_default
316 ."\n${get_indent})"
317 : $get_default;
b1f04da5 318 if ($spec->{coerce}) {
319 $get_value = $self->_generate_coerce(
320 $name, $get_value,
321 $spec->{coerce}
322 )
7fe3b886 323 }
3a9a65a4 324 ($spec->{isa}
325 ? " {\n my \$value = ".$get_value.";\n "
5d349892 326 .$self->_generate_isa_check(
327 $name, '$value', $spec->{isa}
328 ).";\n"
32381de9 329 .' '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
5d349892 330 ." }\n"
32381de9 331 : ' '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
3a9a65a4 332 )
333 .($spec->{trigger}
334 ? ' '
5d349892 335 .$self->_generate_trigger(
336 $name, $me, $self->_generate_simple_get($me, $name),
337 $spec->{trigger}
338 )." if ${test};\n"
3a9a65a4 339 : ''
340 );
341 } else {
342 " if (${test}) {\n"
82a5b146 343 .($spec->{coerce}
344 ? " $source = "
345 .$self->_generate_coerce(
b1f04da5 346 $name, $source,
82a5b146 347 $spec->{coerce}
348 ).";\n"
349 : ""
350 )
3a9a65a4 351 .($spec->{isa}
352 ? " "
5d349892 353 .$self->_generate_isa_check(
354 $name, $source, $spec->{isa}
355 ).";\n"
3a9a65a4 356 : ""
357 )
32381de9 358 ." ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
3a9a65a4 359 .($spec->{trigger}
5d349892 360 ? " "
361 .$self->_generate_trigger(
362 $name, $me, $self->_generate_simple_get($me, $name),
363 $spec->{trigger}
364 ).";\n"
365 : ""
3a9a65a4 366 )
367 ." }\n";
368 }
369}
370
371sub generate_multi_set {
372 my ($self, $me, $to_set, $from) = @_;
373 "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
374}
375
a16d301e 376sub _generate_simple_set {
32381de9 377 my ($self, $me, $name, $spec, $value) = @_;
a16d301e 378 my $name_str = perlstring $name;
32381de9 379 my $simple = "${me}->{${name_str}} = ${value}";
2215d4b9 380
32381de9 381 if ($spec->{weak_ref}) {
faa9ce11 382 require Scalar::Util;
2215d4b9 383
384 # Perl < 5.8.3 can't weaken refs to readonly vars
385 # (e.g. string constants). This *can* be solved by:
386 #
387 #Internals::SetReadWrite($foo);
388 #Scalar::Util::weaken ($foo);
389 #Internals::SetReadOnly($foo);
390 #
391 # but requires XS and is just too damn crazy
392 # so simply throw a better exception
393 Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
394
395 eval { Scalar::Util::weaken($simple); 1 } or do {
396 if( \$@ =~ /Modification of a read-only value attempted/) {
faa9ce11 397 require Carp;
2215d4b9 398 Carp::croak( sprintf (
399 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
400 $name_str,
401 ) );
402 } else {
403 die \$@;
404 }
405 };
406EOC
32381de9 407 } else {
408 $simple;
409 }
51a3b106 410}
411
412sub _generate_getset {
a16d301e 413 my ($self, $name, $spec) = @_;
dcae37d3 414 q{(@_ > 1}."\n ? ".$self->_generate_set($name, $spec)
f537c364 415 ."\n : ".$self->_generate_get($name, $spec)."\n )";
51a3b106 416}
417
4db3a740 418sub _generate_delegation {
419 my ($self, $asserter, $target, $args) = @_;
420 my $arg_string = do {
421 if (@$args) {
422 # I could, I reckon, linearise out non-refs here using perlstring
423 # plus something to check for numbers but I'm unsure if it's worth it
424 $self->{captures}{'@curries'} = $args;
425 '@curries, @_';
426 } else {
427 '@_';
428 }
429 };
430 "shift->${asserter}->${target}(${arg_string});";
431}
432
daa05b62 433sub _generate_xs {
dcae37d3 434 my ($self, $type, $into, $name, $slot) = @_;
daa05b62 435 Class::XSAccessor->import(
e6f2e914 436 class => $into,
dcae37d3 437 $type => { $name => $slot }
daa05b62 438 );
901efe1a 439 $into->can($name);
daa05b62 440}
441
51a3b106 4421;