File Coverage

blib/lib/Sub/HandlesVia/Toolkit/Mite.pm
Criterion Covered Total %
statement 98 122 80.3
branch 37 64 57.8
condition 8 17 47.0
subroutine 17 19 89.4
pod 0 3 0.0
total 160 225 71.1


line stmt bran cond sub pod time code
1 10     10   206 use 5.008;
  10         35  
2 10     10   54 use strict;
  10         18  
  10         258  
3 10     10   54 use warnings;
  10         19  
  10         754  
4              
5             package Sub::HandlesVia::Toolkit::Mite;
6              
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '0.046';
9              
10 10     10   4711 use Sub::HandlesVia::Mite -all;
  10         30  
  10         67  
11             extends 'Sub::HandlesVia::Toolkit';
12              
13 10     10   1070 use Types::Standard -types, -is;
  10         24  
  10         149  
14              
15             sub setup_for {
16 10     10 0 31 my $me = shift;
17 10         35 my ($target) = @_;
18 10         49 $me->install_has_wrapper($target);
19             }
20              
21             my %SPECS;
22             sub install_has_wrapper {
23 10     10 0 25 my $me = shift;
24 10         23 my ($target) = @_;
25            
26 10     10   144749 no strict 'refs';
  10         26  
  10         451  
27 10     10   63 no warnings 'redefine';
  10         29  
  10         18451  
28            
29 10         19 my $orig = \&{ "$target\::has" };
  10         95  
30 10         22 my $uses_mite = ${ "$target\::USES_MITE" };
  10         50  
31 10         25 my $mite_shim = ${ "$target\::MITE_SHIM" };
  10         47  
32              
33 10         88 *{ "$target\::has" } = sub {
34 10     10   10783 my ( $names, %spec ) = @_;
35 10 50       66 return $orig->($names, %spec) unless $spec{handles}; # shortcut
36            
37 10         24 my @shv;
38 10 50       47 for my $name ( ref($names) ? @$names : $names) {
39 10         35 ( my $real_name = $name ) =~ s/^[+]//;
40 10         123 my $shv = $me->clean_spec( $target, $real_name, \%spec );
41 10         46 $SPECS{$target}{$real_name} = \%spec;
42 10         73 $orig->( $name, %spec );
43 10 50       618 push @shv, $shv if $shv;
44             }
45            
46 10 50 33     90 if ( $ENV{MITE_COMPILE}
      33        
47             or defined($Mite::COMPILING) && ( $Mite::COMPILING eq $mite_shim )) {
48 0         0 return;
49             }
50            
51 10 100       47 if ( $uses_mite eq 'Mite::Role' ) {
52 1         599 require Role::Hooks;
53             'Role::Hooks'->after_apply( $target, sub {
54 2         3723 my ( $from, $to ) = @_;
55 2 100       8 return if 'Role::Hooks'->is_role( $to );
56 1         23 for my $shv ( @shv ) {
57 1         21 $me->install_delegations( { %$shv, target => $to } );
58             }
59 1         6086 } );
60             }
61             else {
62 9         28 for my $shv ( @shv ) {
63 9         127 $me->install_delegations( $shv );
64             }
65             }
66            
67 10         472 return;
68 10         52 };
69             }
70              
71             my @method_name_generator = (
72             { # public
73             reader => sub { "get_$_" },
74             writer => sub { "set_$_" },
75             accessor => sub { $_ },
76             lvalue => sub { $_ },
77             clearer => sub { "clear_$_" },
78             predicate => sub { "has_$_" },
79             builder => sub { "_build_$_" },
80             trigger => sub { "_trigger_$_" },
81             },
82             { # private
83             reader => sub { "_get_$_" },
84             writer => sub { "_set_$_" },
85             accessor => sub { $_ },
86             lvalue => sub { $_ },
87             clearer => sub { "_clear_$_" },
88             predicate => sub { "_has_$_" },
89             builder => sub { "_build_$_" },
90             trigger => sub { "_trigger_$_" },
91             },
92             );
93              
94             sub code_generator_for_attribute {
95 10     10 0 46 my ( $me, $target, $attrname ) = ( shift, @_ );
96            
97 10         39 my $name = $attrname->[0];
98 10         41 my $spec = $SPECS{$target}{$name};
99 10         27 my $env = {};
100            
101 10         55 my $private = 0+!! ( $name =~ /^_/ );
102            
103 10   100     61 $spec->{is} ||= bare;
104 10 50       50 if ( $spec->{is} eq lazy ) {
105 0 0       0 $spec->{builder} = 1 unless exists $spec->{builder};
106 0         0 $spec->{is} = ro;
107             }
108 10 100       47 if ( $spec->{is} eq ro ) {
109 1 50       5 $spec->{reader} = '%s' unless exists $spec->{reader};
110             }
111 10 50       45 if ( $spec->{is} eq rw ) {
112 0 0       0 $spec->{accessor} = '%s' unless exists $spec->{accessor};
113             }
114 10 100       42 if ( $spec->{is} eq rwp ) {
115 8 50       47 $spec->{reader} = '%s' unless exists $spec->{reader};
116 8 50       42 $spec->{writer} = '_set_%s' unless exists $spec->{writer};
117             }
118            
119 10         40 for my $property ( 'reader', 'writer', 'accessor', 'builder', 'lvalue' ) {
120 50 100       158 defined( my $methodname = $spec->{$property} ) or next;
121 17 50       61 if ( $methodname eq 1 ) {
122 0         0 my $gen = $method_name_generator[$private]{$property};
123 0         0 local $_ = $name;
124 0         0 $spec->{$property} = $gen->( $_ );
125             }
126 17         82 $spec->{$property} =~ s/\%s/$name/g;
127             }
128            
129 10         39 my ( $get, $set, $get_is_lvalue, $set_checks_isa, $default, $slot );
130            
131 10 100 33     81 if ( my $reader = $spec->{reader} || $spec->{accessor} || $spec->{lvalue} ) {
132 9     173   58 $get = sub { shift->generate_self . "->$reader" };
  173         450  
133 9         30 $get_is_lvalue = false;
134             }
135             else {
136 1     3   7 $get = sub { shift->generate_self . "->{q[$name]}" };
  3         11  
137 1         3 $get_is_lvalue = true;
138             }
139            
140 10 100 66     71 if ( my $writer = $spec->{writer} || $spec->{accessor} ) {
    50          
141             $set = sub {
142 49     49   204 my ( $gen, $expr ) = @_;
143 49         157 $gen->generate_self . "->$writer($expr)";
144 8         61 };
145 8         28 $set_checks_isa = true;
146             }
147             elsif ( $writer = $spec->{lvalue} ) {
148             $set = sub {
149 0     0   0 my ( $gen, $expr ) = @_;
150 0         0 "( " . $gen->generate_self . "->$writer = $expr )";
151 0         0 };
152 0         0 $set_checks_isa = false;
153             }
154             else {
155             $set = sub {
156 5     5   30 my ( $gen, $expr ) = @_;
157 5         19 "( " . $gen->generate_self . "->{q[$name]} = $expr )";
158 2         11 };
159 2         7 $set_checks_isa = false;
160             }
161            
162 10     1   74 $slot = sub { shift->generate_self . "->{q[$name]}" };
  1         4  
163            
164 10 50       103 if ( ref $spec->{builder} ) {
    50          
    100          
    50          
165 0         0 $default = $spec->{builder};
166 0         0 $env->{'$shv_default_for_reset'} = \$default;
167             }
168             elsif ( $spec->{builder} ) {
169 0         0 $default = $spec->{builder};
170             }
171             elsif ( ref $spec->{default} ) {
172 9         28 $default = $spec->{default};
173 9         38 $env->{'$shv_default_for_reset'} = \$default;
174             }
175             elsif ( exists $spec->{default} ) {
176 0         0 my $value = $spec->{default};
177 0     0   0 $default = sub { $value };
  0         0  
178 0         0 $env->{'$shv_default_for_reset'} = \$default;
179             }
180            
181 10         5703 require Sub::HandlesVia::CodeGenerator;
182             return 'Sub::HandlesVia::CodeGenerator'->new(
183             toolkit => $me,
184             target => $target,
185             attribute => $name,
186             env => $env,
187             isa => $spec->{type},
188             coerce => $spec->{coerce},
189             generator_for_get => $get,
190             generator_for_set => $set,
191             get_is_lvalue => $get_is_lvalue,
192             set_checks_isa => $set_checks_isa,
193             set_strictly => true,
194             generator_for_default => sub {
195 6 50   6   36 my ( $gen, $handler ) = @_ or die;
196 6 50 33     82 if ( !$default and $handler ) {
    100          
    50          
    50          
    0          
    0          
197 0         0 return $handler->default_for_reset->();
198             }
199             elsif ( is_CodeRef $default ) {
200 5         23 return sprintf(
201             '(%s)->$shv_default_for_reset',
202             $gen->generate_self,
203             );
204             }
205             elsif ( is_Str $default ) {
206 0         0 require B;
207 0         0 return sprintf(
208             '(%s)->${\ %s }',
209             $gen->generate_self,
210             B::perlstring( $default ),
211             );
212             }
213             elsif ( is_ScalarRef $default ) {
214 1         19 return $$default;
215             }
216             elsif ( is_HashRef $default ) {
217 0           return '{}';
218             }
219             elsif ( is_ArrayRef $default ) {
220 0           return '[]';
221             }
222 0           return;
223             },
224 10 50       255 ( $slot ? ( generator_for_slot => $slot ) : () ),
225             );
226             }
227              
228             1;
229