File Coverage

blib/lib/Sub/HandlesVia/Toolkit/Moo.pm
Criterion Covered Total %
statement 132 202 65.3
branch 60 136 44.1
condition 20 61 32.7
subroutine 19 29 65.5
pod 0 3 0.0
total 231 431 53.6


line stmt bran cond sub pod time code
1 37     134   696 use 5.008;
  37         302  
2 37     107   225 use strict;
  37         96  
  37         847  
3 37     107   181 use warnings;
  37         87  
  37         2443  
4              
5             package Sub::HandlesVia::Toolkit::Moo;
6              
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '0.046';
9              
10 37     77   17711 use Sub::HandlesVia::Mite;
  37         129  
  37         315  
11             extends 'Sub::HandlesVia::Toolkit';
12              
13 37     51   3714 use Types::Standard qw( is_ArrayRef is_Str assert_HashRef is_CodeRef is_Undef );
  37         85  
  37         420  
14 37     37   115456 use Types::Standard qw( ArrayRef HashRef Str Num Int CodeRef Bool );
  37         104  
  37         158  
15              
16             sub setup_for {
17 108     108 0 291 my $me = shift;
18 108         328 my ($target) = @_;
19 108         421 $me->install_has_wrapper($target);
20             }
21              
22             sub install_has_wrapper {
23 108     108 0 258 my $me = shift;
24 108         276 my ($target) = @_;
25              
26 108         213 my ($installer, $orig);
27 108 100 100     849 if ($INC{'Moo/Role.pm'} && 'Moo::Role'->is_role($target)) {
28 3         118 $installer = 'Moo::Role::_install_tracked';
29 3         8 $orig = $Moo::Role::INFO{$target}{exports}{has};
30             }
31             else {
32 105         2262 require Moo;
33 105         319 $installer = 'Moo::_install_tracked';
34 105   33     937 $orig = $Moo::MAKERS{$target}{exports}{has} || $Moo::MAKERS{$target}{non_methods}{has};
35             }
36            
37 108   66     443 $orig ||= $target->can('has');
38 108 50       426 ref($orig) or croak("$target doesn't have a `has` function");
39            
40             $target->$installer(has => sub {
41 128 50   128   830665 if (@_ % 2 == 0) {
        128      
        113      
42 0         0 require Carp;
43 0         0 Carp::croak("Invalid options for attribute(s): even number of arguments expected, got " . scalar @_);
44             }
45 128         1037 my ($attrs, %spec) = @_;
46 128 100       644 return $orig->($attrs, %spec) unless $spec{handles}; # shortcut
47 124 50       593 for my $attr ( ref($attrs) ? @$attrs : $attrs ) {
48 124         443 ( my $real_attr = $attr ) =~ s/^[+]//;
49 124         1289 my $shv = $me->clean_spec($target, $real_attr, \%spec);
50 124         929 $orig->($attr, %spec);
51 124 50       926440 $me->install_delegations($shv) if $shv;
52             }
53 124         23212 return;
54 108         1383 });
55             }
56              
57             sub code_generator_for_attribute {
58 124     124 0 545 my ($me, $target, $attrname) = (shift, @_);
59            
60 124 50       589 if (ref $attrname) {
61 124 50       559 @$attrname==1 or die;
62 124         412 ($attrname) = @$attrname;
63             }
64            
65 124   66     1098 my $ctor_maker = $INC{'Moo.pm'} && 'Moo'->_constructor_maker_for($target);
66            
67 124 100       1540 if (!$ctor_maker) {
68 3         19 return $me->_code_generator_for_role_attribute($target, $attrname);
69             }
70            
71 121         638 my $spec = $ctor_maker->all_attribute_specs->{$attrname};
72 121         890 my $maker = 'Moo'->_accessor_maker_for($target);
73              
74 121 50       3600 my $type = $spec->{isa} ? Types::TypeTiny::to_TypeTiny($spec->{isa}) : undef;
75 121 100       2574 my $coerce = exists($spec->{coerce}) ? $spec->{coerce} : 0;
76 121 50 100     857 if ((ref($coerce)||'') eq 'CODE') {
77 0         0 $type = $type->plus_coercions(Types::Standard::Any(), $coerce);
78 0         0 $coerce = 1;
79             }
80            
81             my $slot = sub {
82 1     1   3 my $gen = shift;
83 1         5 my ($code) = $maker->generate_simple_get($gen->generate_self, $attrname, $spec);
84 1         29 $code;
85 121         882 };
86            
87 121         334 my $captures = {};
88             my ($is_simple_get, $get) = $maker->is_simple_get($attrname, $spec)
89             ? (1, sub {
90 1796     1796   3173 my $gen = shift;
91 1796 100       5712 my $selfvar = $gen ? $gen->generate_self : '$_[0]';
92 1796         6600 my ($return) = $maker->generate_simple_get($selfvar, $attrname, $spec);
93 1796 50       49328 %$captures = ( %$captures, %{ delete($maker->{captures}) or {} } );
  1796         9143  
94 1796         11946 $return;
95             })
96             : (0, sub {
97 377     377   688 my $gen = shift;
98 377 100       1232 my $selfvar = $gen ? $gen->generate_self : '$_[0]';
99 377         1465 my ($return) = $maker->_generate_use_default(
100             $selfvar,
101             $attrname,
102             $spec,
103             $maker->_generate_simple_has($selfvar, $attrname, $spec),
104             );
105 377 100       91691 %$captures = ( %$captures, %{ delete($maker->{captures}) or {} } );
  377         2204  
106 377         2903 $return;
107 121 100       670 });
108             my ($is_simple_set, $set) = $maker->is_simple_set($attrname, $spec)
109             ? (1, sub {
110 0     0   0 my ($gen, $var) = @_;
111 0 0       0 my $selfvar = $gen ? $gen->generate_self : '$_[0]';
112 0         0 my $code = $maker->_generate_simple_set($selfvar, $attrname, $spec, $var);
113 0 0       0 $captures = { %$captures, %{ delete($maker->{captures}) or {} } }; # merge environments
  0         0  
114 0         0 $code;
115             })
116             : (0, sub { # that allows us to avoid going down this yucky code path
117 637     637   2420 my ($gen, $var) = @_;
118 637 100       2395 my $selfvar = $gen ? $gen->generate_self : '$_[0]';
119 637         2466 my $code = $maker->_generate_set($attrname, $spec);
120 637 100       130887 $captures = { %$captures, %{ delete($maker->{captures}) or {} } }; # merge environments
  637         4162  
121 637         3521 $code = "do { local \@_ = ($selfvar, $var); $code }";
122 637         4262 $code;
123 121 50       1959 });
124            
125             # force $captures to be updated
126 121         2616 $get->(undef, '$dummy');
127 121         509 $set->(undef, '$dummy');
128            
129 121         296 my $default;
130 121 100       550 if (exists $spec->{default}) {
    100          
131 90         376 $default = [ default => $spec->{default} ];
132             }
133             elsif (exists $spec->{builder}) {
134 12         54 $default = [ builder => $spec->{builder} ];
135             }
136            
137 121 100       744 if (is_CodeRef $default->[1]) {
138 47         185 $captures->{'$shv_default_for_reset'} = \$default->[1];
139             }
140            
141 121         21154 require Sub::HandlesVia::CodeGenerator;
142             return 'Sub::HandlesVia::CodeGenerator'->new(
143             toolkit => $me,
144             target => $target,
145             attribute => $attrname,
146             attribute_spec => $spec,
147             env => $captures,
148             isa => $type,
149             coerce => !!$coerce,
150             generator_for_slot => $slot,
151             generator_for_get => $get,
152             generator_for_set => $set,
153             get_is_lvalue => $is_simple_get,
154             set_checks_isa => !$is_simple_set,
155             set_strictly => $spec->{weak_ref} || $spec->{trigger},
156             generator_for_default => sub {
157 19 50   19   121 my ( $gen, $handler ) = @_ or die;
158 19 50 33     305 if ( !$default and $handler ) {
    100 66        
    100 33        
    50 33        
    50          
159 0         0 return $handler->default_for_reset->();
160             }
161             elsif ( $default->[0] eq 'builder' ) {
162 4         12 return sprintf(
163             '(%s)->%s',
164             $gen->generate_self,
165             $default->[1],
166             );
167             }
168             elsif ( $default->[0] eq 'default' and is_CodeRef $default->[1] ) {
169 5         36 return sprintf(
170             '(%s)->$shv_default_for_reset',
171             $gen->generate_self,
172             );
173             }
174             elsif ( $default->[0] eq 'default' and is_Undef $default->[1] ) {
175 0         0 return 'undef';
176             }
177             elsif ( $default->[0] eq 'default' and is_Str $default->[1] ) {
178 10         68 require B;
179 10         89 return B::perlstring( $default->[1] );
180             }
181 0         0 return;
182             },
183 121   66     2541 );
184             }
185              
186             sub _code_generator_for_role_attribute {
187 3     3   13 my ($me, $target, $attrname) = (shift, @_);
188            
189 3 50       13 if (ref $attrname) {
190 0 0       0 @$attrname==1 or die;
191 0         0 ($attrname) = @$attrname;
192             }
193            
194 3         24 require B;
195            
196 3         9 my %all_specs = @{ $Moo::Role::INFO{$target}{attributes} };
  3         21  
197 3         10 my $spec = $all_specs{$attrname};
198              
199 3         11 my ($reader_name, $writer_name);
200            
201 3 50       18 if ($spec->{is} eq 'ro') {
    0          
    0          
202 3         8 $reader_name = $attrname;
203             }
204             elsif ($spec->{is} eq 'rw') {
205 0         0 $reader_name = $attrname;
206 0         0 $writer_name = $attrname;
207             }
208             elsif ($spec->{is} eq 'rwp') {
209 0         0 $reader_name = $attrname;
210 0         0 $writer_name = "_set_$attrname";
211             }
212 3 50       15 if (exists $spec->{reader}) {
213 3         9 $reader_name = $spec->{reader};
214             }
215 3 50       11 if (exists $spec->{writer}) {
216 0         0 $writer_name = $spec->{reader};
217             }
218 3 50       12 if (exists $spec->{accessor}) {
219 0 0       0 $reader_name = $spec->{accessor} unless defined $reader_name;
220 0 0       0 $writer_name = $spec->{accessor} unless defined $writer_name;
221             }
222            
223 3 50       20 my $type = $spec->{isa} ? Types::TypeTiny::to_TypeTiny($spec->{isa}) : undef;
224 3         60 my $coerce = $spec->{coerce};
225 3 50 50     37 if ((ref($coerce)||'') eq 'CODE') {
226 0         0 $type = $type->plus_coercions(Types::Standard::Any(), $coerce);
227 0         0 $coerce = 1;
228             }
229            
230 3         11 my $captures = {};
231 3         14 my ($get, $set);
232            
233 3 50       12 if (defined $reader_name) {
234             $get = ($reader_name =~ /^[\W0-9]\w*$/s)
235 0     0   0 ? sub { my $gen = shift; sprintf "%s->%s", $gen->generate_self, $reader_name }
  0         0  
236 3 50   7   32 : sub { my $gen = shift; sprintf "%s->\${\\ %s }", $gen->generate_self, B::perlstring($reader_name) };
  7         26  
  7         26  
237             }
238             else {
239 0         0 my ($default, $default_literal) = (undef, 0);
240 0 0 0     0 if (is_Coderef $spec->{default}) {
    0 0        
    0          
    0          
241 0         0 $default = $spec->{default};
242             }
243             elsif (exists $spec->{default}) {
244 0         0 ++$default_literal;
245 0         0 $default = $spec->{default};
246             }
247             elsif (is_CodeRef $spec->{builder} or (($spec->{builder}||0) eq 1)) {
248 0         0 $default = '_build_'.$attrname;
249             }
250             elsif ($spec->{builder}) {
251 0         0 $default = $spec->{builder};
252             }
253             else {
254 0         0 ++$default_literal;
255             }
256             my $dammit_i_need_to_build_a_reader = sub {
257 0     0   0 my $instance = shift;
258 0 0       0 exists($instance->{$attrname}) or do {
259 0 0 0     0 $instance->{$attrname} ||= $default_literal ? $default : $instance->$default;
260             };
261 0         0 $instance->{$attrname};
262 0         0 };
263 0         0 $captures->{'$shv_reader'} = \$dammit_i_need_to_build_a_reader;
264 0     0   0 $get = sub { my $gen = shift; $gen->generate_self . '->$shv_reader()' };
  0         0  
  0         0  
265             }
266            
267            
268 3 50       12 if (defined $writer_name) {
269             $set = $writer_name =~ /^[\W0-9]\w*$/s
270 0     0   0 ? sub { my ($gen, $val) = @_; sprintf "%s->%s(%s)", $gen->generate_self, $writer_name, $val }
  0         0  
271 0 0   0   0 : sub { my ($gen, $val) = @_; sprintf "%s->\${\\ %s }(%s)", $gen->generate_self, B::perlstring($writer_name), $val };
  0         0  
  0         0  
272             }
273             else {
274 3         10 my $trigger;
275 3 50 50     26 if (($spec->{trigger}||0) eq 1) {
276 0         0 $trigger = "_trigger_$attrname";
277             }
278 3   50     17 my $weaken = $spec->{weak_ref} || 0;
279             my $dammit_i_need_to_build_a_writer = sub {
280 0     0   0 my ($instance, $new_value) = (shift, @_);
281 0 0       0 if ($type) {
282 0 0 0     0 ($type->has_coercion && $coerce)
283             ? ($new_value = $type->assert_coerce($new_value))
284             : $type->assert_valid($new_value);
285             }
286 0 0       0 if ($trigger) {
287 0 0       0 $instance->$trigger($new_value, exists($instance->{$attrname}) ? $instance->{$attrname} : ())
288             }
289 0         0 $instance->{$attrname} = $new_value;
290 0 0 0     0 if ($weaken and ref $new_value) {
291 0         0 Scalar::Util::weaken($instance->{$attrname});
292             }
293 0         0 $instance->{$attrname};
294 3         19 };
295 3         12 $captures->{'$shv_writer'} = \$dammit_i_need_to_build_a_writer;
296 3     0   16 $set = sub { my ($gen, $val) = @_; $gen->generate_self . "->\$shv_writer($val)" };
  0         0  
  0         0  
297             }
298              
299 3         8 my $default;
300 3 100       26 if (exists $spec->{default}) {
    50          
301 1         5 $default = [ default => $spec->{default} ];
302             }
303             elsif (exists $spec->{builder}) {
304 2         8 $default = [ builder => $spec->{builder} ];
305             }
306            
307 3 100       18 if (is_CodeRef $default->[1]) {
308 1         4 $captures->{'$shv_default_for_reset'} = \$default->[1];
309             }
310            
311 3         1742 require Sub::HandlesVia::CodeGenerator;
312             return 'Sub::HandlesVia::CodeGenerator'->new(
313             toolkit => $me,
314             target => $target,
315             attribute => $attrname,
316             attribute_spec => $spec,
317             env => $captures,
318             isa => $type,
319             coerce => !!$coerce,
320 0     0     generator_for_slot => sub { shift->generate_self.'->{'.B::perlstring($attrname).'}' }, # icky
321             generator_for_get => $get,
322             generator_for_set => $set,
323             get_is_lvalue => !!0,
324             set_checks_isa => !!1,
325             set_strictly => !!0,
326             generator_for_default => sub {
327 0 0   0     my ( $gen, $handler ) = @_ or die;
328 0 0 0       if ( !$default and $handler ) {
    0 0        
    0 0        
    0 0        
    0          
329 0           return $handler->default_for_reset->();
330             }
331             elsif ( $default->[0] eq 'builder' ) {
332 0           return sprintf(
333             '(%s)->%s',
334             $gen->generate_self,
335             $default->[1],
336             );
337             }
338             elsif ( $default->[0] eq 'default' and is_CodeRef $default->[1] ) {
339 0           return sprintf(
340             '(%s)->$shv_default_for_reset',
341             $gen->generate_self,
342             );
343             }
344             elsif ( $default->[0] eq 'default' and is_Undef $default->[1] ) {
345 0           return 'undef';
346             }
347             elsif ( $default->[0] eq 'default' and is_Str $default->[1] ) {
348 0           require B;
349 0           return B::perlstring( $default->[1] );
350             }
351 0           return;
352             },
353 3         63 );
354             }
355              
356             1;