File Coverage

blib/lib/Method/Generate/Accessor.pm
Criterion Covered Total %
statement 309 309 100.0
branch 194 194 100.0
condition 90 104 86.5
subroutine 52 52 100.0
pod 0 16 0.0
total 645 675 95.5


line stmt bran cond sub pod time code
1             package Method::Generate::Accessor;
2 188     188   170292 use strict;
  188         427  
  188         6398  
3 188     188   1056 use warnings;
  188         393  
  188         6294  
4              
5 188     188   1861 use Moo::_Utils qw(_maybe_load_module _install_coderef _module_name_rx);
  188         461  
  188         10485  
6 188     188   12205 use Moo::Object ();
  188         443  
  188         6777  
7 188     188   9379 BEGIN { our @ISA = qw(Moo::Object) }
8 188     188   15574 use Sub::Quote qw(quote_sub quoted_from_sub quotify sanitize_identifier);
  188         197631  
  188         12630  
9 188     188   1456 use Scalar::Util 'blessed';
  188         425  
  188         8987  
10 188     188   1279 use Carp qw(croak);
  188         473  
  188         11927  
11             BEGIN {
12 188     188   30954 our @CARP_NOT = qw(
13             Moo::_Utils
14             Moo::Object
15             Moo::Role
16             );
17             }
18             BEGIN {
19             *_CAN_WEAKEN_READONLY = (
20             "$]" < 5.008_003 or $ENV{MOO_TEST_PRE_583}
21 188 100 66 188   3259 ) ? sub(){0} : sub(){1};
22             our $CAN_HAZ_XS =
23             !$ENV{MOO_XS_DISABLE}
24             &&
25             _maybe_load_module('Class::XSAccessor')
26             &&
27 188   66     1817 (eval { Class::XSAccessor->VERSION('1.07') })
28             ;
29             our $CAN_HAZ_XS_PRED =
30             $CAN_HAZ_XS &&
31 188   66     4925 (eval { Class::XSAccessor->VERSION('1.17') })
32             ;
33             }
34             BEGIN {
35             package
36             Method::Generate::Accessor::_Generated;
37 188     188   919393 $Carp::Internal{+__PACKAGE__} = 1;
38             }
39              
40             sub _die_overwrite {
41 18     18   41 my ($pkg, $method, $type) = @_;
42 18   50     3491 croak "You cannot overwrite a locally defined method ($method) with "
43             . ( $type || 'an accessor' );
44             }
45              
46             sub generate_method {
47 696     696 0 33217 my ($self, $into, $name, $spec, $quote_opts) = @_;
48             $quote_opts = {
49             no_defer => 1,
50             package => 'Method::Generate::Accessor::_Generated',
51 696 100       1245 %{ $quote_opts||{} },
  696         4332  
52             };
53 696 100       2751 $spec->{allow_overwrite}++ if $name =~ s/^\+//;
54 696 100       3293 croak "Must have an is" unless my $is = $spec->{is};
55 690 100       2363 if ($is eq 'ro') {
    100          
    100          
    100          
    100          
56 460 100       1575 $spec->{reader} = $name unless exists $spec->{reader};
57             } elsif ($is eq 'rw') {
58             $spec->{accessor} = $name unless exists $spec->{accessor}
59 184 100 100     1055 or ( $spec->{reader} and $spec->{writer} );
      100        
60             } elsif ($is eq 'lazy') {
61 28 100       86 $spec->{reader} = $name unless exists $spec->{reader};
62 28         55 $spec->{lazy} = 1;
63 28 100 66     110 $spec->{builder} ||= '_build_'.$name unless exists $spec->{default};
64             } elsif ($is eq 'rwp') {
65 12 100       57 $spec->{reader} = $name unless exists $spec->{reader};
66 12 100       62 $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
67             } elsif ($is ne 'bare') {
68 2         220 croak "Unknown is ${is}";
69             }
70 688 100       1885 if (exists $spec->{builder}) {
71 46 100       130 if(ref $spec->{builder}) {
72             $self->_validate_codulatable('builder', $spec->{builder},
73 10         52 "$into->$name", 'or a method name');
74 10         23 $spec->{builder_sub} = $spec->{builder};
75 10         72 $spec->{builder} = 1;
76             }
77 46 100 50     207 $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
78             croak "Invalid builder for $into->$name - not a valid method name"
79 46 100       615 if $spec->{builder} !~ _module_name_rx;
80             }
81 686 100 100     3442 if (($spec->{predicate}||0) eq 1) {
82 8 100       59 $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
83             }
84 686 100 100     3132 if (($spec->{clearer}||0) eq 1) {
85 4 100       16 $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
86             }
87 686 100 100     3020 if (($spec->{trigger}||0) eq 1) {
88 2         12 $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
89             }
90 686 100 100     3337 if (($spec->{coerce}||0) eq 1) {
91 10         19 my $isa = $spec->{isa};
92 10 100 100     116 if (blessed $isa and $isa->can('coercion')) {
    100 100        
93 4         109 $spec->{coerce} = $isa->coercion;
94             } elsif (blessed $isa and $isa->can('coerce')) {
95 2     2   10 $spec->{coerce} = sub { $isa->coerce(@_) };
  2         325  
96             } else {
97 4         837 croak "Invalid coercion for $into->$name - no appropriate type constraint";
98             }
99             }
100              
101 682         1727 foreach my $setting (qw( isa coerce )) {
102 1364 100       3564 next if !exists $spec->{$setting};
103 182         1517 $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
104             }
105              
106 672 100       1892 if (exists $spec->{default}) {
107 188 100       639 if (ref $spec->{default}) {
108 152         772 $self->_validate_codulatable('default', $spec->{default}, "$into->$name",
109             'or a non-ref');
110             }
111             }
112              
113 664 100       2474 if (exists $spec->{moosify}) {
114 8 100       24 if (ref $spec->{moosify} ne 'ARRAY') {
115 2         6 $spec->{moosify} = [$spec->{moosify}];
116             }
117              
118 8         14 foreach my $spec (@{$spec->{moosify}}) {
  8         21  
119 12         39 $self->_validate_codulatable('moosify', $spec, "$into->$name");
120             }
121             }
122              
123 664         1529 my %methods;
124 664 100       1871 if (my $reader = $spec->{reader}) {
125             _die_overwrite($into, $reader, 'a reader')
126 488 100 100     1754 if !$spec->{allow_overwrite} && defined &{"${into}::${reader}"};
  452         3515  
127 482 100 100     2070 if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
128 218         717 $methods{$reader} = $self->_generate_xs(
129             getters => $into, $reader, $name, $spec
130             );
131             } else {
132 264         735 $self->{captures} = {};
133             $methods{$reader} =
134             quote_sub "${into}::${reader}"
135             => ' Carp::croak("'.$reader.' is a read-only accessor") if @_ > 1;'."\n"
136             .$self->_generate_get($name, $spec)
137             => delete $self->{captures}
138 264         1393 => $quote_opts
139             ;
140             }
141             }
142 658 100       154945 if (my $accessor = $spec->{accessor}) {
143             _die_overwrite($into, $accessor, 'an accessor')
144 186 100 100     600 if !$spec->{allow_overwrite} && defined &{"${into}::${accessor}"};
  176         1274  
145 184 100 100     882 if (
      100        
146             our $CAN_HAZ_XS
147             && $self->is_simple_get($name, $spec)
148             && $self->is_simple_set($name, $spec)
149             ) {
150 31         97 $methods{$accessor} = $self->_generate_xs(
151             accessors => $into, $accessor, $name, $spec
152             );
153             } else {
154 153         367 $self->{captures} = {};
155             $methods{$accessor} =
156             quote_sub "${into}::${accessor}"
157             => $self->_generate_getset($name, $spec)
158             => delete $self->{captures}
159 153         585 => $quote_opts
160             ;
161             }
162             }
163 656 100       106611 if (my $writer = $spec->{writer}) {
164             _die_overwrite($into, $writer, 'a writer')
165 22 100 66     93 if !$spec->{allow_overwrite} && defined &{"${into}::${writer}"};
  22         173  
166 20 100 100     121 if (
167             our $CAN_HAZ_XS
168             && $self->is_simple_set($name, $spec)
169             ) {
170 5         12 $methods{$writer} = $self->_generate_xs(
171             setters => $into, $writer, $name, $spec
172             );
173             } else {
174 15         41 $self->{captures} = {};
175             $methods{$writer} =
176             quote_sub "${into}::${writer}"
177             => $self->_generate_set($name, $spec)
178             => delete $self->{captures}
179 15         82 => $quote_opts
180             ;
181             }
182             }
183 654 100       10682 if (my $pred = $spec->{predicate}) {
184             _die_overwrite($into, $pred, 'a predicate')
185 14 100 66     53 if !$spec->{allow_overwrite} && defined &{"${into}::${pred}"};
  14         109  
186 12 100 66     63 if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) {
187 6         46 $methods{$pred} = $self->_generate_xs(
188             exists_predicates => $into, $pred, $name, $spec
189             );
190             } else {
191 6         18 $self->{captures} = {};
192             $methods{$pred} =
193             quote_sub "${into}::${pred}"
194             => $self->_generate_simple_has('$_[0]', $name, $spec)."\n"
195             => delete $self->{captures}
196 6         29 => $quote_opts
197             ;
198             }
199             }
200 652 100       4994 if (my $builder = delete $spec->{builder_sub}) {
201 10         67 _install_coderef( "${into}::$spec->{builder}" => $builder );
202             }
203 652 100       1616 if (my $cl = $spec->{clearer}) {
204             _die_overwrite($into, $cl, 'a clearer')
205 16 100 66     61 if !$spec->{allow_overwrite} && defined &{"${into}::${cl}"};
  16         128  
206 14         48 $self->{captures} = {};
207             $methods{$cl} =
208             quote_sub "${into}::${cl}"
209             => $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
210             => delete $self->{captures}
211 14         58 => $quote_opts
212             ;
213             }
214 650 100       9221 if (my $hspec = $spec->{handles}) {
215 42   66     236 my $asserter = $spec->{asserter} ||= '_assert_'.$name;
216 42         83 my @specs = do {
217 42 100       246 if (ref($hspec) eq 'ARRAY') {
    100          
    100          
218 10         60 map [ $_ => $_ ], @$hspec;
219             } elsif (ref($hspec) eq 'HASH') {
220 16 100       120 map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
  2         10  
221             keys %$hspec;
222             } elsif (!ref($hspec)) {
223 14         1225 require Moo::Role;
224 14         102 map [ $_ => $_ ], Moo::Role->methods_provided_by($hspec)
225             } else {
226 2         421 croak "You gave me a handles of ${hspec} and I have no idea why";
227             }
228             };
229 36         438 foreach my $delegation_spec (@specs) {
230 38         1201 my ($proxy, $target, @args) = @$delegation_spec;
231             _die_overwrite($into, $proxy, 'a delegation')
232 38 100 100     128 if !$spec->{allow_overwrite} && defined &{"${into}::${proxy}"};
  34         243  
233 36         164 $self->{captures} = {};
234             $methods{$proxy} =
235             quote_sub "${into}::${proxy}"
236             => $self->_generate_delegation($asserter, $target, \@args)
237             => delete $self->{captures}
238 36         188 => $quote_opts
239             ;
240             }
241             }
242 642 100       19608 if (my $asserter = $spec->{asserter}) {
243             _die_overwrite($into, $asserter, 'an asserter')
244 44 100 100     168 if !$spec->{allow_overwrite} && defined &{"${into}::${asserter}"};
  36         270  
245 42         126 local $self->{captures} = {};
246             $methods{$asserter} =
247             quote_sub "${into}::${asserter}"
248             => $self->_generate_asserter($name, $spec)
249             => delete $self->{captures}
250 42         180 => $quote_opts
251             ;
252             }
253 640         26417 \%methods;
254             }
255              
256             sub merge_specs {
257 26     26 0 62 my ($self, @specs) = @_;
258 26         52 my $spec = shift @specs;
259 26         59 for my $old_spec (@specs) {
260 26         99 foreach my $key (keys %$old_spec) {
261 122 100 100     535 if ($key eq 'handles') {
    100          
    100          
    100          
262             }
263             elsif ($key eq 'moosify') {
264             $spec->{$key} = [
265 4 100       18 map { ref $_ eq 'ARRAY' ? @$_ : $_ }
266             grep defined,
267 2         9 ($old_spec->{$key}, $spec->{$key})
268             ];
269             }
270             elsif ($key eq 'builder' || $key eq 'default') {
271             $spec->{$key} = $old_spec->{$key}
272 24 100 100     228 if !(exists $spec->{builder} || exists $spec->{default});
273             }
274             elsif (!exists $spec->{$key}) {
275 74         168 $spec->{$key} = $old_spec->{$key};
276             }
277             }
278             }
279 26         71 $spec;
280             }
281              
282             sub is_simple_attribute {
283 4     4 0 665 my ($self, $name, $spec) = @_;
284             # clearer doesn't have to be listed because it doesn't
285             # affect whether defined/exists makes a difference
286 4         34 !grep $spec->{$_},
287             qw(lazy default builder coerce isa trigger predicate weak_ref);
288             }
289              
290             sub is_simple_get {
291 792     792 0 1869 my ($self, $name, $spec) = @_;
292 792   100     4073 !($spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
293             }
294              
295             sub is_simple_set {
296 259     259 0 520 my ($self, $name, $spec) = @_;
297 259         1495 !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
298             }
299              
300             sub has_default {
301 56     56 0 159 my ($self, $name, $spec) = @_;
302 56 100 50     1092 $spec->{builder} or exists $spec->{default} or (($spec->{is}||'') eq 'lazy');
      100        
303             }
304              
305             sub has_eager_default {
306 1596     1596 0 2929 my ($self, $name, $spec) = @_;
307 1596 100 66     7651 (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
308             }
309              
310             sub _generate_get {
311 459     459   1144 my ($self, $name, $spec) = @_;
312 459         1371 my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
313 459 100       1354 if ($self->is_simple_get($name, $spec)) {
314 389         2140 $simple;
315             } else {
316 70         261 $self->_generate_use_default(
317             '$_[0]', $name, $spec,
318             $self->_generate_simple_has('$_[0]', $name, $spec),
319             );
320             }
321             }
322              
323             sub generate_simple_has {
324 14     14 0 28 my $self = shift;
325 14         37 $self->{captures} = {};
326 14         42 my $code = $self->_generate_simple_has(@_);
327 14         264 ($code, delete $self->{captures});
328             }
329              
330             sub _generate_simple_has {
331 132     132   376 my ($self, $me, $name) = @_;
332 132         359 "exists ${me}->{${\quotify $name}}";
  132         354  
333             }
334              
335             sub _generate_simple_clear {
336 14     14   36 my ($self, $me, $name) = @_;
337 14         32 " delete ${me}->{${\quotify $name}}\n"
  14         49  
338             }
339              
340             sub generate_get_default {
341 2     2 0 4 my $self = shift;
342 2         8 $self->{captures} = {};
343 2         8 my $code = $self->_generate_get_default(@_);
344 2         40 ($code, delete $self->{captures});
345             }
346              
347             sub generate_use_default {
348 14     14 0 28 my $self = shift;
349 14         35 $self->{captures} = {};
350 14         58 my $code = $self->_generate_use_default(@_);
351 14         57 ($code, delete $self->{captures});
352             }
353              
354             sub _generate_use_default {
355 84     84   904 my ($self, $me, $name, $spec, $test) = @_;
356 84         295 my $get_value = $self->_generate_get_default($me, $name, $spec);
357 84 100       673 if ($spec->{coerce}) {
358             $get_value = $self->_generate_coerce(
359             $name, $get_value,
360             $spec->{coerce}
361             )
362 6         17 }
363             $test." ? \n"
364             .$self->_generate_simple_get($me, $name, $spec)."\n:"
365             .($spec->{isa} ?
366             " do {\n my \$value = ".$get_value.";\n"
367 84 100       410 ." ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
368             ." ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
369             ." }\n"
370             : ' ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n"
371             );
372             }
373              
374             sub _generate_get_default {
375 210     210   475 my ($self, $me, $name, $spec) = @_;
376 210 100       542 if (exists $spec->{default}) {
377             ref $spec->{default}
378             ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
379 172 100       740 : quotify $spec->{default};
380             }
381             else {
382 38         74 "${me}->${\$spec->{builder}}"
  38         135  
383             }
384             }
385              
386             sub generate_simple_get {
387 2     2 0 2955 my ($self, @args) = @_;
388 2         7 $self->{captures} = {};
389 2         10 my $code = $self->_generate_simple_get(@args);
390 2         10 ($code, delete $self->{captures});
391             }
392              
393             sub _generate_simple_get {
394 676     676   2159 my ($self, $me, $name) = @_;
395 676         1688 my $name_str = quotify $name;
396 676         7428 "${me}->{${name_str}}";
397             }
398              
399             sub _generate_set {
400 168     168   336 my ($self, $name, $spec) = @_;
401 168         328 my ($me, $source) = ('$_[0]', '$_[1]');
402 168 100       476 if ($self->is_simple_set($name, $spec)) {
403 42         139 return $self->_generate_simple_set($me, $name, $spec, $source);
404             }
405              
406 126         260 my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
  126         351  
407 126 100       322 if ($coerce) {
408 46         129 $source = $self->_generate_coerce($name, $source, $coerce);
409             }
410 126 100       1267 if ($isa_check) {
    100          
411 48 100       234 'scalar do { my $value = '.$source.";\n"
412             .' ('.$self->_generate_isa_check($name, '$value', $isa_check)."),\n"
413             .' ('.$self->_generate_simple_set($me, $name, $spec, '$value')."),\n"
414             .($trigger
415             ? '('.$self->_generate_trigger($name, $me, '$value', $trigger)."),\n"
416             : '')
417             .' ('.$self->_generate_simple_get($me, $name, $spec)."),\n"
418             ."}";
419             }
420             elsif ($trigger) {
421 20         44 my $set = $self->_generate_simple_set($me, $name, $spec, $source);
422 20         78 "scalar (\n"
423             . ' ('.$self->_generate_trigger($name, $me, "($set)", $trigger)."),\n"
424             . ' ('.$self->_generate_simple_get($me, $name, $spec)."),\n"
425             . ")";
426             }
427             else {
428 58         175 '('.$self->_generate_simple_set($me, $name, $spec, $source).')';
429             }
430             }
431              
432             sub generate_coerce {
433 2     2 0 2666 my $self = shift;
434 2         6 $self->{captures} = {};
435 2         12 my $code = $self->_generate_coerce(@_);
436 2         101 ($code, delete $self->{captures});
437             }
438              
439             sub _attr_desc {
440 268     268   544 my ($name, $init_arg) = @_;
441 268 100 100     1370 return quotify($name) if !defined($init_arg) or $init_arg eq $name;
442 10         25 return quotify($name).' (constructor argument: '.quotify($init_arg).')';
443             }
444              
445             sub _generate_coerce {
446 122     122   319 my ($self, $name, $value, $coerce, $init_arg) = @_;
447 122         460 $self->_wrap_attr_exception(
448             $name,
449             "coercion",
450             $init_arg,
451             $self->_generate_call_code($name, 'coerce', "${value}", $coerce),
452             1,
453             );
454             }
455              
456             sub generate_trigger {
457 2     2 0 3157 my $self = shift;
458 2         6 $self->{captures} = {};
459 2         10 my $code = $self->_generate_trigger(@_);
460 2         49 ($code, delete $self->{captures});
461             }
462              
463             sub _generate_trigger {
464 62     62   124 my ($self, $name, $obj, $value, $trigger) = @_;
465 62         216 $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
466             }
467              
468             sub generate_isa_check {
469 2     2 0 2894 my ($self, @args) = @_;
470 2         7 $self->{captures} = {};
471 2         11 my $code = $self->_generate_isa_check(@args);
472 2         54 ($code, delete $self->{captures});
473             }
474              
475             sub _wrap_attr_exception {
476 268     268   3344 my ($self, $name, $step, $arg, $code, $want_return) = @_;
477 268         741 my $prefix = quotify("${step} for "._attr_desc($name, $arg).' failed: ');
478 268 100       4447 "do {\n"
    100          
    100          
479             .' local $Method::Generate::Accessor::CurrentAttribute = {'."\n"
480             .' init_arg => '.quotify($arg).",\n"
481             .' name => '.quotify($name).",\n"
482             .' step => '.quotify($step).",\n"
483             ." };\n"
484             .($want_return ? ' (my $_return),'."\n" : '')
485             .' (my $_error), (my $_old_error = $@);'."\n"
486             ." (eval {\n"
487             .' ($@ = $_old_error),'."\n"
488             .' ('
489             .($want_return ? '$_return ='."\n" : '')
490             .$code."),\n"
491             ." 1\n"
492             ." } or\n"
493             .' $_error = CORE::ref $@ ? $@ : '.$prefix.'.$@);'."\n"
494             .' ($@ = $_old_error),'."\n"
495             .' (defined $_error and CORE::die $_error);'."\n"
496             .($want_return ? ' $_return;'."\n" : '')
497             ."}\n"
498             }
499              
500             sub _generate_isa_check {
501 146     146   378 my ($self, $name, $value, $check, $init_arg) = @_;
502 146         503 $self->_wrap_attr_exception(
503             $name,
504             "isa check",
505             $init_arg,
506             $self->_generate_call_code($name, 'isa_check', $value, $check)
507             );
508             }
509              
510             sub _generate_call_code {
511 458     458   1001 my ($self, $name, $type, $values, $sub) = @_;
512 458 100       1407 $sub = \&{$sub} if blessed($sub); # coderef if blessed
  22         67  
513 458 100       3486 if (my $quoted = quoted_from_sub($sub)) {
514 104         5423 my $local = 1;
515 104 100 66     563 if ($values eq '@_' || $values eq '$_[0]') {
516 4         19 $local = 0;
517 4         47 $values = '@_';
518             }
519 104         210 my $code = $quoted->[1];
520 104 100       270 if (my $captures = $quoted->[2]) {
521 38         142 my $cap_name = qq{\$${type}_captures_for_}.sanitize_identifier($name);
522 38         460 $self->{captures}->{$cap_name} = \$captures;
523 38         114 Sub::Quote::inlinify($code, $values,
524             Sub::Quote::capture_unroll($cap_name, $captures, 6), $local);
525             } else {
526 66         206 Sub::Quote::inlinify($code, $values, undef, $local);
527             }
528             } else {
529 354         3421 my $cap_name = qq{\$${type}_for_}.sanitize_identifier($name);
530 354         4302 $self->{captures}->{$cap_name} = \$sub;
531 354         1496 "${cap_name}->(${values})";
532             }
533             }
534              
535 2     2   9490 sub _sanitize_name { sanitize_identifier($_[1]) }
536              
537             sub generate_populate_set {
538 1560     1560 0 5767 my $self = shift;
539 1560         3074 $self->{captures} = {};
540 1560         3617 my $code = $self->_generate_populate_set(@_);
541 1560         7348 ($code, delete $self->{captures});
542             }
543              
544             sub _generate_populate_set {
545 1560     1560   3736 my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
546              
547 1560         3435 my $has_default = $self->has_eager_default($name, $spec);
548 1560 100 100     5848 if (!($has_default || $test)) {
549 2         9 return '';
550             }
551 1558 100       3346 if ($has_default) {
552 124         365 my $get_default = $self->_generate_get_default($me, $name, $spec);
553 124 100       983 $source =
554             $test
555             ? "(\n ${test}\n"
556             ." ? ${source}\n : "
557             .$get_default
558             .")"
559             : $get_default;
560             }
561 1558 100       3406 if ($spec->{coerce}) {
562             $source = $self->_generate_coerce(
563             $name, $source,
564 68         254 $spec->{coerce}, $init_arg
565             )
566             }
567 1558 100       4667 if ($spec->{isa}) {
568             $source = 'scalar do { my $value = '.$source.";\n"
569             .' ('.$self->_generate_isa_check(
570 84         762 $name, '$value', $spec->{isa}, $init_arg
571             )."),\n"
572             ." \$value\n"
573             ."}\n";
574             }
575 1558         5898 my $set = $self->_generate_simple_set($me, $name, $spec, $source);
576             my $trigger = $spec->{trigger} ? $self->_generate_trigger(
577             $name, $me, $self->_generate_simple_get($me, $name, $spec),
578             $spec->{trigger}
579 1558 100       3377 ) : undef;
580 1558 100       3349 if ($has_default) {
581 124 100 100     774 "($set)," . ($trigger && $test ? "($test and $trigger)," : '') . "\n";
582             }
583             else {
584 1434 100       6387 "($test and ($set)" . ($trigger ? ", ($trigger)" : '') . "),\n";
585             }
586             }
587              
588             sub _generate_core_set {
589 1772     1772   3528 my ($self, $me, $name, $spec, $value) = @_;
590 1772         3325 my $name_str = quotify $name;
591 1772         14426 "${me}->{${name_str}} = ${value}";
592             }
593              
594             sub _generate_simple_set {
595 1810     1810   5682 my ($self, $me, $name, $spec, $value) = @_;
596 1810         4050 my $name_str = quotify $name;
597 1810         15357 my $simple = $self->_generate_core_set($me, $name, $spec, $value);
598              
599 1810 100       4378 if ($spec->{weak_ref}) {
600 44         245 require Scalar::Util;
601 44         108 my $get = $self->_generate_simple_get($me, $name, $spec);
602              
603             # Perl < 5.8.3 can't weaken refs to readonly vars
604             # (e.g. string constants). This *can* be solved by:
605             #
606             # &Internals::SvREADONLY($foo, 0);
607             # Scalar::Util::weaken($foo);
608             # &Internals::SvREADONLY($foo, 1);
609             #
610             # but requires Internal functions and is just too damn crazy
611             # so simply throw a better exception
612 44         277 my $weak_simple = _CAN_WEAKEN_READONLY
613             ? "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }"
614             : <<"EOC"
615             ( eval { Scalar::Util::weaken($simple); 1 }
616             ? do { no warnings 'void'; $get }
617             : do {
618             if( \$@ =~ /Modification of a read-only value attempted/) {
619             require Carp;
620             Carp::croak( sprintf (
621             'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
622             $name_str,
623             ) );
624             } else {
625             die \$@;
626             }
627             }
628             )
629             EOC
630             } else {
631 1766         4473 $simple;
632             }
633             }
634              
635             sub _generate_getset {
636 153     153   371 my ($self, $name, $spec) = @_;
637 153         476 q{(@_ > 1}."\n ? ".$self->_generate_set($name, $spec)
638             ."\n : ".$self->_generate_get($name, $spec)."\n )";
639             }
640              
641             sub _generate_asserter {
642 42     42   108 my ($self, $name, $spec) = @_;
643 42         116 my $name_str = quotify($name);
644 42         457 "do {\n"
645             ." my \$val = ".$self->_generate_get($name, $spec).";\n"
646             ." ".$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
647             ." or Carp::croak(q{Attempted to access '}.${name_str}.q{' but it is not set});\n"
648             ." \$val;\n"
649             ."}\n";
650             }
651             sub _generate_delegation {
652 36     36   102 my ($self, $asserter, $target, $args) = @_;
653 36         66 my $arg_string = do {
654 36 100       98 if (@$args) {
655             # I could, I reckon, linearise out non-refs here using quotify
656             # plus something to check for numbers but I'm unsure if it's worth it
657 2         5 $self->{captures}{'@curries'} = $args;
658 2         4 '@curries, @_';
659             } else {
660 34         68 '@_';
661             }
662             };
663 36         234 "shift->${asserter}->${target}(${arg_string});";
664             }
665              
666             sub _generate_xs {
667 249     249   671 my ($self, $type, $into, $name, $slot) = @_;
668 249         1637 Class::XSAccessor->import(
669             class => $into,
670             $type => { $name => $slot },
671             replace => 1,
672             );
673 249         37358 $into->can($name);
674             }
675              
676 426     426 0 3005 sub default_construction_string { '{}' }
677              
678             sub _validate_codulatable {
679 356     356   1001 my ($self, $setting, $value, $into, $appended) = @_;
680              
681 356         807 my $error;
682              
683 356 100       1597 if (blessed $value) {
    100          
684 34         71 local $@;
685 188     188   2770 no warnings 'void';
  188         580  
  188         37621  
686 34 100       61 eval { \&$value; 1 }
  34         380  
  24         2659  
687             and return 1;
688 10         36 $error = "could not be converted to a coderef: $@";
689             }
690             elsif (ref $value eq 'CODE') {
691 314         824 return 1;
692             }
693             else {
694 8         17 $error = 'is not a coderef or code-convertible object';
695             }
696              
697             croak "Invalid $setting '"
698 18 100       663 . ($INC{'overload.pm'} ? overload::StrVal($value) : $value)
    100          
699             . "' for $into " . $error
700             . ($appended ? " $appended" : '');
701             }
702              
703             1;