line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
94
|
|
|
30525
|
|
109965
|
use 5.008; |
|
94
|
|
|
|
|
440
|
|
2
|
94
|
|
|
94
|
|
624
|
use strict; |
|
94
|
|
|
|
|
277
|
|
|
94
|
|
|
|
|
2442
|
|
3
|
94
|
|
|
94
|
|
601
|
use warnings; |
|
94
|
|
|
|
|
268
|
|
|
94
|
|
|
|
|
7738
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Sub::HandlesVia::CodeGenerator; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
8
|
|
|
|
|
|
|
our $VERSION = '0.046'; |
9
|
|
|
|
|
|
|
|
10
|
94
|
|
|
94
|
|
1316
|
use Sub::HandlesVia::Mite -all; |
|
94
|
|
|
|
|
308
|
|
|
94
|
|
|
|
|
1497
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
has toolkit => ( |
13
|
|
|
|
|
|
|
is => ro, |
14
|
|
|
|
|
|
|
); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
has target => ( |
17
|
|
|
|
|
|
|
is => ro, |
18
|
|
|
|
|
|
|
); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
has attribute => ( |
21
|
|
|
|
|
|
|
is => ro, |
22
|
|
|
|
|
|
|
); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
has attribute_spec => ( |
25
|
|
|
|
|
|
|
is => ro, |
26
|
|
|
|
|
|
|
isa => 'HashRef', |
27
|
|
|
|
|
|
|
); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
has isa => ( |
30
|
|
|
|
|
|
|
is => ro, |
31
|
|
|
|
|
|
|
); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
has coerce => ( |
34
|
|
|
|
|
|
|
is => ro, |
35
|
|
|
|
|
|
|
isa => 'Bool', |
36
|
|
|
|
|
|
|
); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
has env => ( |
39
|
|
|
|
|
|
|
is => ro, |
40
|
|
|
|
|
|
|
isa => 'HashRef', |
41
|
|
|
|
|
|
|
default => \ '{}', |
42
|
|
|
|
|
|
|
default_is_trusted => true, |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
has sandboxing_package => ( |
46
|
|
|
|
|
|
|
is => ro, |
47
|
|
|
|
|
|
|
isa => 'Str|Undef', |
48
|
|
|
|
|
|
|
default => sprintf( '%s::__SANDBOX__', __PACKAGE__ ), |
49
|
|
|
|
|
|
|
default_is_trusted => true, |
50
|
|
|
|
|
|
|
); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
has [ 'generator_for_slot', 'generator_for_get', 'generator_for_set', 'generator_for_default' ] => ( |
53
|
|
|
|
|
|
|
is => ro, |
54
|
|
|
|
|
|
|
isa => 'CodeRef', |
55
|
|
|
|
|
|
|
); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
has generator_for_args => ( |
58
|
|
|
|
|
|
|
is => ro, |
59
|
|
|
|
|
|
|
isa => 'CodeRef', |
60
|
|
|
|
|
|
|
builder => sub { |
61
|
|
|
|
|
|
|
return sub { |
62
|
134
|
|
|
134
|
|
724
|
'@_[1..$#_]'; |
63
|
346
|
|
|
346
|
|
2138
|
}; |
64
|
|
|
|
|
|
|
}, |
65
|
|
|
|
|
|
|
default_is_trusted => true, |
66
|
|
|
|
|
|
|
); |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
has generator_for_arg => ( |
69
|
|
|
|
|
|
|
is => ro, |
70
|
|
|
|
|
|
|
isa => 'CodeRef', |
71
|
|
|
|
|
|
|
builder => sub { |
72
|
|
|
|
|
|
|
return sub { |
73
|
4587
|
50
|
|
4587
|
|
10553
|
@_==2 or die; |
74
|
4587
|
|
|
|
|
7977
|
my $n = pop; |
75
|
4587
|
|
|
|
|
20306
|
"\$_[$n]"; |
76
|
346
|
|
|
346
|
|
1945
|
}; |
77
|
|
|
|
|
|
|
}, |
78
|
|
|
|
|
|
|
default_is_trusted => true, |
79
|
|
|
|
|
|
|
); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
has generator_for_argc => ( |
82
|
|
|
|
|
|
|
is => ro, |
83
|
|
|
|
|
|
|
isa => 'CodeRef', |
84
|
|
|
|
|
|
|
builder => sub { |
85
|
|
|
|
|
|
|
return sub { |
86
|
472
|
|
|
472
|
|
2278
|
'(@_-1)'; |
87
|
346
|
|
|
346
|
|
1650
|
}; |
88
|
|
|
|
|
|
|
}, |
89
|
|
|
|
|
|
|
default_is_trusted => true, |
90
|
|
|
|
|
|
|
); |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
has generator_for_currying => ( |
93
|
|
|
|
|
|
|
is => ro, |
94
|
|
|
|
|
|
|
isa => 'CodeRef', |
95
|
|
|
|
|
|
|
builder => sub { |
96
|
|
|
|
|
|
|
return sub { |
97
|
0
|
0
|
|
0
|
|
0
|
@_==2 or die; |
98
|
0
|
|
|
|
|
0
|
my $arr = pop; |
99
|
0
|
|
|
|
|
0
|
"splice(\@_,1,0,$arr);"; |
100
|
346
|
|
|
346
|
|
1929
|
}; |
101
|
|
|
|
|
|
|
}, |
102
|
|
|
|
|
|
|
default_is_trusted => true, |
103
|
|
|
|
|
|
|
); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
has generator_for_usage_string => ( |
106
|
|
|
|
|
|
|
is => ro, |
107
|
|
|
|
|
|
|
isa => 'CodeRef', |
108
|
|
|
|
|
|
|
builder => sub { |
109
|
|
|
|
|
|
|
return sub { |
110
|
2661
|
50
|
|
2661
|
|
6459
|
@_==3 or die; |
111
|
2661
|
|
|
|
|
4041
|
shift; |
112
|
2661
|
|
|
|
|
4323
|
my $method_name = shift; |
113
|
2661
|
|
|
|
|
4236
|
my $guts = shift; |
114
|
2661
|
|
|
|
|
21876
|
"\$instance->$method_name($guts)"; |
115
|
346
|
|
|
346
|
|
1997
|
}; |
116
|
|
|
|
|
|
|
}, |
117
|
|
|
|
|
|
|
default_is_trusted => true, |
118
|
|
|
|
|
|
|
); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
has generator_for_self => ( |
121
|
|
|
|
|
|
|
is => ro, |
122
|
|
|
|
|
|
|
isa => 'CodeRef', |
123
|
|
|
|
|
|
|
builder => sub { |
124
|
|
|
|
|
|
|
return sub { |
125
|
5398
|
|
|
5398
|
|
18527
|
'$_[0]'; |
126
|
346
|
|
|
346
|
|
1662
|
}; |
127
|
|
|
|
|
|
|
}, |
128
|
|
|
|
|
|
|
default_is_trusted => true, |
129
|
|
|
|
|
|
|
); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
has generator_for_type_assertion => ( |
132
|
|
|
|
|
|
|
is => ro, |
133
|
|
|
|
|
|
|
isa => 'CodeRef', |
134
|
|
|
|
|
|
|
builder => sub { |
135
|
|
|
|
|
|
|
return sub { |
136
|
790
|
|
|
790
|
|
2013
|
my ( $gen, $env, $type, $varname ) = @_; |
137
|
790
|
|
|
|
|
1337
|
my $i = 0; |
138
|
790
|
|
|
|
|
3166
|
my $type_varname = sprintf '$shv_type_constraint_%d', $type->{uniq}; |
139
|
790
|
|
|
|
|
2165
|
$env->{$type_varname} = \$type; |
140
|
790
|
100
|
100
|
|
|
2654
|
if ( $gen->coerce and $type->has_coercion ) { |
141
|
8
|
50
|
|
|
|
106
|
if ( $type->coercion->can_be_inlined ) { |
142
|
8
|
|
|
|
|
758
|
return sprintf '%s=%s;%s;', |
143
|
|
|
|
|
|
|
$varname, |
144
|
|
|
|
|
|
|
$type->coercion->inline_coercion($varname), |
145
|
|
|
|
|
|
|
$type->inline_assert( $varname, $type_varname ); |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
else { |
148
|
0
|
|
|
|
|
0
|
return sprintf '%s=%s->assert_coerce(%s);', |
149
|
|
|
|
|
|
|
$varname, $type_varname, $varname; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
} |
152
|
782
|
|
|
|
|
3711
|
return $type->inline_assert( $varname, $type_varname ); |
153
|
346
|
|
|
346
|
|
2397
|
}; |
154
|
|
|
|
|
|
|
}, |
155
|
|
|
|
|
|
|
default_is_trusted => true, |
156
|
|
|
|
|
|
|
); |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
has generator_for_error => ( |
159
|
|
|
|
|
|
|
is => ro, |
160
|
|
|
|
|
|
|
isa => 'CodeRef', |
161
|
|
|
|
|
|
|
builder => sub { |
162
|
|
|
|
|
|
|
return sub { |
163
|
2746
|
|
|
2746
|
|
6272
|
my ( $gen, $error ) = @_; |
164
|
2746
|
|
|
|
|
9631
|
sprintf 'do { require Carp; Carp::croak(%s) }', $error; |
165
|
346
|
|
|
346
|
|
1948
|
}; |
166
|
|
|
|
|
|
|
}, |
167
|
|
|
|
|
|
|
default_is_trusted => true, |
168
|
|
|
|
|
|
|
); |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
has generator_for_prelude => ( |
171
|
|
|
|
|
|
|
is => ro, |
172
|
|
|
|
|
|
|
isa => 'CodeRef', |
173
|
|
|
|
|
|
|
builder => sub { |
174
|
2988
|
|
|
2988
|
|
9960
|
return sub { '' }; |
|
1601
|
|
|
|
|
5325
|
|
175
|
|
|
|
|
|
|
}, |
176
|
|
|
|
|
|
|
default_is_trusted => true, |
177
|
|
|
|
|
|
|
); |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
has method_installer => ( |
180
|
|
|
|
|
|
|
is => rw, |
181
|
|
|
|
|
|
|
isa => 'CodeRef', |
182
|
|
|
|
|
|
|
); |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
has _override => ( |
185
|
|
|
|
|
|
|
is => rw, |
186
|
|
|
|
|
|
|
init_arg => undef, |
187
|
|
|
|
|
|
|
); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
has is_method => ( |
190
|
|
|
|
|
|
|
is => ro, |
191
|
|
|
|
|
|
|
default => true, |
192
|
|
|
|
|
|
|
); |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
has get_is_lvalue => ( |
195
|
|
|
|
|
|
|
is => ro, |
196
|
|
|
|
|
|
|
default => false, |
197
|
|
|
|
|
|
|
); |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
has set_checks_isa => ( |
200
|
|
|
|
|
|
|
is => ro, |
201
|
|
|
|
|
|
|
default => false, |
202
|
|
|
|
|
|
|
); |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
has set_strictly => ( |
205
|
|
|
|
|
|
|
is => ro, |
206
|
|
|
|
|
|
|
default => true, |
207
|
|
|
|
|
|
|
); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
my $REASONABLE_SCALAR = qr/^ |
210
|
|
|
|
|
|
|
\$ # scalar access |
211
|
|
|
|
|
|
|
[^\W0-9]\w* # normal-looking variable name (including $_) |
212
|
|
|
|
|
|
|
(?: # then... |
213
|
|
|
|
|
|
|
(?:\-\>)? # dereference maybe |
214
|
|
|
|
|
|
|
[\[\{] # opening [ or { |
215
|
|
|
|
|
|
|
[\'\"]? # quote maybe |
216
|
|
|
|
|
|
|
\w+ # word characters (includes digits) |
217
|
|
|
|
|
|
|
[\'\"]? # quote maybe |
218
|
|
|
|
|
|
|
[\]\}] # closing ] or } |
219
|
|
|
|
|
|
|
){0,3} # ... up to thrice |
220
|
|
|
|
|
|
|
$/x; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
my @generatable_things = qw( |
223
|
|
|
|
|
|
|
slot get set default arg args argc currying usage_string self |
224
|
|
|
|
|
|
|
type_assertion error prelude |
225
|
|
|
|
|
|
|
); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
for my $thing ( @generatable_things ) { |
228
|
|
|
|
|
|
|
my $generator = "generator_for_$thing"; |
229
|
|
|
|
|
|
|
my $method_name = "generate_$thing"; |
230
|
|
|
|
|
|
|
my $method = sub { |
231
|
37611
|
|
|
37611
|
|
96746
|
my $gen = shift; |
232
|
37611
|
|
|
|
|
55196
|
local ${^GENERATOR} = $gen; |
233
|
|
|
|
|
|
|
|
234
|
37611
|
100
|
|
|
|
49333
|
if ( @{ $gen->_override->{$thing} || [] } ) { |
|
37611
|
100
|
|
|
|
139292
|
|
235
|
8577
|
|
|
|
|
12609
|
my $coderef = pop @{ $gen->_override->{$thing} }; |
|
8577
|
|
|
|
|
18425
|
|
236
|
|
|
|
|
|
|
my $guard = guard { |
237
|
8577
|
|
50
|
8577
|
|
12407
|
push @{ $gen->_override->{$thing} ||= [] }, $coderef; |
|
8577
|
|
|
|
|
59677
|
|
238
|
8577
|
|
|
|
|
41362
|
}; |
239
|
8577
|
|
|
|
|
21459
|
return $gen->$coderef( @_ ); |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
29034
|
|
|
|
|
101968
|
return $gen->$generator->( $gen, @_ ); |
243
|
|
|
|
|
|
|
}; |
244
|
94
|
|
|
94
|
|
115014
|
no strict 'refs'; |
|
94
|
|
|
|
|
294
|
|
|
94
|
|
|
|
|
51390
|
|
245
|
|
|
|
|
|
|
*$method_name = $method; |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub attribute_name { |
249
|
3
|
|
|
3
|
0
|
5
|
my $self = shift; |
250
|
3
|
|
|
|
|
19
|
my $attr = $self->attribute; |
251
|
|
|
|
|
|
|
|
252
|
3
|
50
|
|
|
|
17
|
return $attr |
253
|
|
|
|
|
|
|
if !ref $attr; |
254
|
|
|
|
|
|
|
|
255
|
0
|
0
|
|
|
|
0
|
return sprintf '$instance->%s', $attr->[0] |
256
|
|
|
|
|
|
|
if ref($attr) eq 'ARRAY'; |
257
|
|
|
|
|
|
|
|
258
|
0
|
|
|
|
|
0
|
return '$attribute_value'; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub _start_overriding_generators { |
262
|
4246
|
|
|
4246
|
|
7066
|
my $self = shift; |
263
|
4246
|
|
|
|
|
14166
|
$self->_override( {} ); |
264
|
|
|
|
|
|
|
return guard { |
265
|
4246
|
|
|
4246
|
|
32533
|
$self->_override( {} ); |
266
|
4246
|
|
|
|
|
23486
|
}; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
{ |
270
|
|
|
|
|
|
|
my %generatable_thing = map +( $_ => 1 ), @generatable_things; |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
sub _add_generator_override { |
273
|
3089
|
|
|
3089
|
|
11437
|
my ( $self, %overrides ) = @_; |
274
|
3089
|
|
|
|
|
11622
|
while ( my ( $key, $value ) = each %overrides ) { |
275
|
11200
|
100
|
|
|
|
22763
|
next if !defined $value; |
276
|
10928
|
100
|
|
|
|
24375
|
next if !$generatable_thing{$key}; |
277
|
8916
|
|
100
|
|
|
12013
|
push @{ $self->_override->{$key} ||= [] }, $value; |
|
8916
|
|
|
|
|
47773
|
|
278
|
|
|
|
|
|
|
} |
279
|
3089
|
|
|
|
|
7374
|
return $self; |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
sub generate_and_install_method { |
284
|
4244
|
|
|
4244
|
1
|
8926
|
my ( $self, $method_name, $handler ) = @_; |
285
|
|
|
|
|
|
|
|
286
|
4244
|
|
|
|
|
11449
|
$self->install_method( |
287
|
|
|
|
|
|
|
$method_name, |
288
|
|
|
|
|
|
|
$self->generate_coderef_for_handler( $method_name, $handler ), |
289
|
|
|
|
|
|
|
); |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
{ |
293
|
|
|
|
|
|
|
my $sub_rename; |
294
|
|
|
|
|
|
|
if ( eval { require Sub::Util } ) { |
295
|
|
|
|
|
|
|
$sub_rename = Sub::Util->can('set_subname'); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
elsif ( eval { require Sub::Name } ) { |
298
|
|
|
|
|
|
|
$sub_rename = Sub::Name->can('subname'); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
sub install_method { |
302
|
4244
|
|
|
4244
|
1
|
1862237
|
my ( $self, $method_name, $coderef ) = @_; |
303
|
4244
|
|
|
|
|
14129
|
my $target = $self->target; |
304
|
|
|
|
|
|
|
|
305
|
4244
|
50
|
|
|
|
14272
|
eval { |
306
|
4244
|
|
|
|
|
34981
|
$coderef = $sub_rename->( "$target\::$method_name", $coderef ) |
307
|
|
|
|
|
|
|
} if ref $sub_rename; |
308
|
|
|
|
|
|
|
|
309
|
4244
|
100
|
|
|
|
16964
|
if ( $self->method_installer ) { |
310
|
2593
|
|
|
|
|
6748
|
$self->method_installer->( $method_name, $coderef ); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
else { |
313
|
94
|
|
|
94
|
|
1017
|
no strict 'refs'; |
|
94
|
|
|
|
|
356
|
|
|
94
|
|
|
|
|
231350
|
|
314
|
1651
|
|
|
|
|
2886
|
*{"$target\::$method_name"} = $coderef; |
|
1651
|
|
|
|
|
12110
|
|
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub generate_coderef_for_handler { |
320
|
4245
|
|
|
4245
|
1
|
7791
|
my ( $self, $method_name, $handler ) = @_; |
321
|
|
|
|
|
|
|
|
322
|
4245
|
|
|
|
|
9538
|
my $ec_args = $self->_generate_ec_args_for_handler( $method_name, $handler ); |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# warn "#### $method_name"; |
325
|
|
|
|
|
|
|
# warn join("\n", @{$ec_args->{source}}); |
326
|
|
|
|
|
|
|
# for my $key (sort keys %{$ec_args->{environment}}) { |
327
|
|
|
|
|
|
|
# warn ">> $key : ".ref($ec_args->{environment}{$key}); |
328
|
|
|
|
|
|
|
# if ( ref($ec_args->{environment}{$key}) eq 'REF' and ref(${$ec_args->{environment}{$key}}) eq 'CODE' ) { |
329
|
|
|
|
|
|
|
# require B::Deparse; |
330
|
|
|
|
|
|
|
# warn B::Deparse->new->coderef2text(${$ec_args->{environment}{$key}}); |
331
|
|
|
|
|
|
|
# } |
332
|
|
|
|
|
|
|
# } |
333
|
|
|
|
|
|
|
|
334
|
4245
|
|
|
|
|
24241
|
require Eval::TypeTiny; |
335
|
4245
|
|
|
|
|
19513
|
Eval::TypeTiny::eval_closure( %$ec_args ); |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub _generate_ec_args_for_handler { |
339
|
4246
|
|
|
4246
|
|
7562
|
my ( $self, $method_name, $handler ) = @_; |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
# Later on, we might need to override the generators for |
342
|
|
|
|
|
|
|
# arg, argc, args, set, etc. |
343
|
|
|
|
|
|
|
# |
344
|
4246
|
|
|
|
|
9028
|
my $guard = $self->_start_overriding_generators; |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# Make a COPY of $self->env! |
347
|
|
|
|
|
|
|
# |
348
|
4246
|
|
|
|
|
7574
|
my $env = { %{$self->env} }; |
|
4246
|
|
|
|
|
14557
|
|
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# Preamble code. |
351
|
|
|
|
|
|
|
# |
352
|
4246
|
|
|
|
|
9874
|
my $code = [ |
353
|
|
|
|
|
|
|
'sub {', |
354
|
|
|
|
|
|
|
]; |
355
|
|
|
|
|
|
|
|
356
|
4246
|
50
|
|
|
|
24673
|
push @$code, sprintf( 'package %s;', $self->sandboxing_package ) |
357
|
|
|
|
|
|
|
if $self->sandboxing_package; |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# Need to maintain state between following method calls. A proper |
360
|
|
|
|
|
|
|
# object might be nice, but a hashref will do for now. |
361
|
|
|
|
|
|
|
# |
362
|
4246
|
|
|
|
|
14531
|
my $state = { |
363
|
|
|
|
|
|
|
signature_check_needed => true, # hasn't been done yet |
364
|
|
|
|
|
|
|
final_type_check_needed => $handler->is_mutator, |
365
|
|
|
|
|
|
|
getter => scalar($self->generate_get), |
366
|
|
|
|
|
|
|
getter_is_lvalue => $self->get_is_lvalue, |
367
|
|
|
|
|
|
|
template_wrapper => undef, # nothing yet |
368
|
|
|
|
|
|
|
add_later => undef, # nothing yet |
369
|
|
|
|
|
|
|
shifted_self => false, |
370
|
|
|
|
|
|
|
}; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
# use Hash::Util qw( lock_ref_keys ); |
373
|
|
|
|
|
|
|
# lock_ref_keys( $state ); |
374
|
|
|
|
|
|
|
|
375
|
4246
|
|
|
|
|
25963
|
my @args = ( |
376
|
|
|
|
|
|
|
$method_name, # Intended name for the coderef being generated |
377
|
|
|
|
|
|
|
$handler, # Info about the functionality being delegated |
378
|
|
|
|
|
|
|
$env, # Variables which need to be closed over |
379
|
|
|
|
|
|
|
$code, # Lines of code in the method |
380
|
|
|
|
|
|
|
$state, # Shared state while building method. (Minimal!) |
381
|
|
|
|
|
|
|
); |
382
|
4246
|
|
|
|
|
10855
|
$self |
383
|
|
|
|
|
|
|
->_handle_sigcheck( @args ) # check method sigs |
384
|
|
|
|
|
|
|
->_handle_prelude( @args ) # insert any prelude |
385
|
|
|
|
|
|
|
->_handle_shiftself( @args ) # $self = shift |
386
|
|
|
|
|
|
|
->_handle_currying( @args ) # push curried values to @_ |
387
|
|
|
|
|
|
|
->_handle_additional_validation( @args ) # additional type checks |
388
|
|
|
|
|
|
|
->_handle_getter_code( @args ) # optimize calling getter |
389
|
|
|
|
|
|
|
->_handle_setter_code( @args ) # make calling setter safer |
390
|
|
|
|
|
|
|
->_handle_template( @args ) # perform code substitutes |
391
|
|
|
|
|
|
|
->_handle_chaining( @args ); # return $self if requested |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# Postamble code. Can't really do much here because the template |
394
|
|
|
|
|
|
|
# might want to be able to return something. |
395
|
|
|
|
|
|
|
# |
396
|
4246
|
|
|
|
|
9790
|
push @$code, "}"; |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# Allow the handler to inject variables into the environment. |
399
|
|
|
|
|
|
|
# Rarely needed. |
400
|
|
|
|
|
|
|
# |
401
|
4246
|
|
|
|
|
14894
|
$handler->_tweak_env( $env ); |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
return { |
404
|
4246
|
|
50
|
|
|
44991
|
source => $code, |
405
|
|
|
|
|
|
|
environment => $env, |
406
|
|
|
|
|
|
|
description => sprintf( |
407
|
|
|
|
|
|
|
"%s=%s", |
408
|
|
|
|
|
|
|
$method_name || '__ANON__', |
409
|
|
|
|
|
|
|
$handler->name, |
410
|
|
|
|
|
|
|
), |
411
|
|
|
|
|
|
|
}; |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
sub _handle_sigcheck { |
415
|
4246
|
|
|
4246
|
|
9153
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
# If there's a proper signature for the method... |
418
|
|
|
|
|
|
|
# |
419
|
4246
|
100
|
|
|
|
6307
|
if ( @{ $handler->signature || [] } ) { |
|
4246
|
100
|
|
|
|
18135
|
|
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
# Generate code using Type::Params to check the signature. |
422
|
|
|
|
|
|
|
# We also need to close over the signature. |
423
|
|
|
|
|
|
|
# |
424
|
1585
|
|
|
|
|
9320
|
require Type::Params; |
425
|
1585
|
|
|
|
|
4816
|
unshift @$code, 'my $__sigcheck;'; |
426
|
1585
|
|
|
|
|
3885
|
$env->{'@__sig'} = $handler->signature; |
427
|
1585
|
50
|
|
|
|
3359
|
if ( $state->{shifted_self} ) { |
428
|
0
|
|
|
|
|
0
|
push @$code, '$__sigcheck||=Type::Params::compile(@__sig);@_=&$__sigcheck;'; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
else { |
431
|
1585
|
|
|
|
|
3752
|
push @$code, '$__sigcheck||=Type::Params::compile(1, @__sig);@_=&$__sigcheck;'; |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
# As we've now inserted a signature check, we can stop worrying |
435
|
|
|
|
|
|
|
# about signature checks. |
436
|
|
|
|
|
|
|
# |
437
|
1585
|
|
|
|
|
2929
|
$state->{signature_check_needed} = 0; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
# There is no proper signature, but there's still check the |
440
|
|
|
|
|
|
|
# arity of the method. |
441
|
|
|
|
|
|
|
# |
442
|
|
|
|
|
|
|
else { |
443
|
|
|
|
|
|
|
# What is the arity? |
444
|
|
|
|
|
|
|
# |
445
|
2661
|
|
100
|
|
|
7906
|
my $min_args = $handler->min_args || 0; |
446
|
2661
|
|
|
|
|
7451
|
my $max_args = $handler->max_args; |
447
|
|
|
|
|
|
|
|
448
|
2661
|
|
|
|
|
4731
|
my $plus = 1; |
449
|
2661
|
50
|
|
|
|
6486
|
if ( $state->{shifted_self} ) { |
450
|
0
|
|
|
|
|
0
|
$plus = 0; |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# What usage message do we want to print if wrong arity? |
454
|
|
|
|
|
|
|
# |
455
|
2661
|
|
|
|
|
8708
|
my $usg = $self->generate_error( sprintf( |
456
|
|
|
|
|
|
|
' "Wrong number of parameters; usage: " . %s ', |
457
|
|
|
|
|
|
|
B::perlstring( $self->generate_usage_string( $method_name, $handler->usage ) ), |
458
|
|
|
|
|
|
|
) ); |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# Insert the check into the code. |
461
|
|
|
|
|
|
|
# |
462
|
2661
|
100
|
66
|
|
|
17871
|
if (defined $min_args and defined $max_args and $min_args==$max_args) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
463
|
1810
|
|
|
|
|
6846
|
push @$code, sprintf('@_==%d or %s;', $min_args + $plus, $usg); |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
elsif (defined $min_args and defined $max_args) { |
466
|
264
|
|
|
|
|
1284
|
push @$code, sprintf('(@_ >= %d and @_ <= %d) or %s;', $min_args + $plus, $max_args + $plus, $usg); |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
elsif (defined $min_args and $min_args > 0) { |
469
|
187
|
|
|
|
|
866
|
push @$code, sprintf('@_ >= %d or %s;', $min_args + $plus, $usg); |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
# We are still lacking a proper signature check though, so note |
473
|
|
|
|
|
|
|
# that in the state. The information can be used by |
474
|
|
|
|
|
|
|
# additional_validation coderefs. |
475
|
|
|
|
|
|
|
# |
476
|
2661
|
|
|
|
|
6975
|
$state->{signature_check_needed} = true; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
4246
|
|
|
|
|
12083
|
return $self; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub _handle_prelude { |
483
|
4246
|
|
|
4246
|
|
9356
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
484
|
4246
|
|
|
|
|
9336
|
push @$code, grep !!$_, $self->generate_prelude(); |
485
|
4246
|
|
|
|
|
11962
|
return $self; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub _handle_shiftself { |
489
|
4246
|
|
|
4246
|
|
9121
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# Handlers which use @ARG will benefit from shifting $self |
492
|
|
|
|
|
|
|
# off @_, but for other handlers, this will just slow compilation |
493
|
|
|
|
|
|
|
# down (but not much). |
494
|
|
|
|
|
|
|
# |
495
|
4246
|
100
|
100
|
|
|
20713
|
return $self |
496
|
|
|
|
|
|
|
unless $handler->curried || $handler->prefer_shift_self; |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
# Shift off the invocant. |
499
|
|
|
|
|
|
|
# |
500
|
1708
|
|
|
|
|
4056
|
push @$code, 'my $shv_self=shift;'; |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
$self->_add_generator_override( |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
# Override $ARG[$n] because the array has been reindexed. |
505
|
|
|
|
|
|
|
# |
506
|
2472
|
|
|
2472
|
|
6804
|
arg => sub { my ($gen, $n) = @_; $gen->generate_arg( $n - 1 ) }, |
|
2472
|
|
|
|
|
6901
|
|
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# Overrride @ARG to point to the whole array. This is the |
509
|
|
|
|
|
|
|
# real speed-up! |
510
|
|
|
|
|
|
|
# |
511
|
683
|
|
|
683
|
|
2804
|
args => sub { '@_' }, |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# Override #ARG to no longer subtract 1. |
514
|
|
|
|
|
|
|
# |
515
|
875
|
|
|
875
|
|
2817
|
argc => sub { 'scalar(@_)' }, |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# $SELF is now '$shv_self'. |
518
|
|
|
|
|
|
|
# |
519
|
2636
|
|
|
2636
|
|
9623
|
self => sub { '$shv_self' }, |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
# The default currying callback will splice the list into |
522
|
|
|
|
|
|
|
# @_ at index 1. Instead unshift the list at the start of @_. |
523
|
|
|
|
|
|
|
# |
524
|
|
|
|
|
|
|
currying => sub { |
525
|
1403
|
|
|
1403
|
|
3452
|
my ($gen, $list) = @_; |
526
|
1403
|
|
|
|
|
6231
|
"CORE::unshift(\@_, $list);"; |
527
|
|
|
|
|
|
|
}, |
528
|
1708
|
|
|
|
|
20393
|
); |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# Getter was cached in $state and needs update. |
531
|
|
|
|
|
|
|
# |
532
|
1708
|
|
|
|
|
4232
|
$state->{getter} = $self->generate_get; |
533
|
1708
|
|
|
|
|
7241
|
$state->{shifted_self} = true; |
534
|
|
|
|
|
|
|
|
535
|
1708
|
|
|
|
|
5317
|
return $self; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# Insert code into method for currying. |
539
|
|
|
|
|
|
|
# |
540
|
|
|
|
|
|
|
sub _handle_currying { |
541
|
4246
|
|
|
4246
|
|
9365
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
542
|
|
|
|
|
|
|
|
543
|
4246
|
100
|
|
|
|
11556
|
if ( my $curried = $handler->curried ) { |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# If the curried values are non-simple, we close over an array |
546
|
|
|
|
|
|
|
# called @curry. |
547
|
|
|
|
|
|
|
# |
548
|
1403
|
100
|
|
|
|
5322
|
if ( grep ref, @$curried ) { |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# Note that generate_currying will generate code that unshifts whatever |
551
|
|
|
|
|
|
|
# parameters it is given onto @_. |
552
|
360
|
|
|
|
|
1196
|
push @$code, $self->generate_currying('@curry'); |
553
|
360
|
|
|
|
|
1241
|
$env->{'@curry'} = $curried; |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
# If it's just strings, numbers, and undef, it should be pretty |
556
|
|
|
|
|
|
|
# trivial to hard-code the values into the generated Perl string. |
557
|
|
|
|
|
|
|
# |
558
|
|
|
|
|
|
|
else { |
559
|
1043
|
|
|
|
|
5852
|
require B; |
560
|
|
|
|
|
|
|
my $values = join( |
561
|
|
|
|
|
|
|
',', |
562
|
1043
|
50
|
|
|
|
2503
|
map { defined($_) ? B::perlstring($_) : 'undef' } @$curried, |
|
1559
|
|
|
|
|
7148
|
|
563
|
|
|
|
|
|
|
); |
564
|
1043
|
|
|
|
|
4133
|
push @$code, $self->generate_currying( "($values)" ); |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
|
568
|
4246
|
|
|
|
|
11416
|
return $self; |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub _handle_additional_validation { |
572
|
4246
|
|
|
4246
|
|
8469
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# If the handler specifies no validation needed, or the attribute |
575
|
|
|
|
|
|
|
# simply has no type check, we don't need to check the type of the |
576
|
|
|
|
|
|
|
# final attribute value. |
577
|
|
|
|
|
|
|
# |
578
|
4246
|
100
|
66
|
|
|
34781
|
if ( $handler->no_validation_needed or not $self->isa ) { |
579
|
177
|
|
|
|
|
354
|
$state->{final_type_check_needed} = false; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
# The handler can define some additional validation to be performed |
583
|
|
|
|
|
|
|
# on arguments either now or later, such that if this additional |
584
|
|
|
|
|
|
|
# validation is performed, the type check we were planning later |
585
|
|
|
|
|
|
|
# will be known to be unnecessary. |
586
|
|
|
|
|
|
|
# |
587
|
|
|
|
|
|
|
# An example for this is that is the attribute value is already an |
588
|
|
|
|
|
|
|
# arrayref of numbers, and we're pushing a new value onto it, by checking |
589
|
|
|
|
|
|
|
# up front that the INCOMING value is a number, it becomes unnecessary |
590
|
|
|
|
|
|
|
# to check the whole arrayref contains numbers after the push. |
591
|
|
|
|
|
|
|
# |
592
|
|
|
|
|
|
|
# Not all handlers define an additional_validation coderef to do |
593
|
|
|
|
|
|
|
# this, because in many cases it doesn't make sense to. |
594
|
|
|
|
|
|
|
# |
595
|
|
|
|
|
|
|
# Also if we've already decided a final type check isn't needed, we |
596
|
|
|
|
|
|
|
# can skip this step. |
597
|
|
|
|
|
|
|
# |
598
|
4246
|
100
|
100
|
|
|
31991
|
if ( $state->{final_type_check_needed} |
599
|
|
|
|
|
|
|
and defined $handler->additional_validation ) { |
600
|
|
|
|
|
|
|
|
601
|
1381
|
|
|
|
|
4642
|
my $real_av_method = $handler->_real_additional_validation; |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
# The additional_validation coderef is called as a method and takes |
604
|
|
|
|
|
|
|
# two additional parameters: |
605
|
|
|
|
|
|
|
# |
606
|
|
|
|
|
|
|
my $opt = $handler->$real_av_method( |
607
|
|
|
|
|
|
|
!$state->{signature_check_needed}, # $sig_was_checked |
608
|
1381
|
|
|
|
|
5843
|
$self, # $gen |
609
|
|
|
|
|
|
|
); |
610
|
1381
|
|
100
|
|
|
7000
|
$opt ||= {}; # can return undef |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# The additional_validation coderef will often generate code which |
613
|
|
|
|
|
|
|
# coerces incoming data, thus moving it from @_ to some other array. |
614
|
|
|
|
|
|
|
# This means that the generators for @ARG, $ARG, etc will need to |
615
|
|
|
|
|
|
|
# need to be overridden to point to the new array. |
616
|
|
|
|
|
|
|
# |
617
|
1381
|
|
|
|
|
6139
|
$self->_add_generator_override( %$opt ); |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# The additional_validation coderef may supply extra variables |
620
|
|
|
|
|
|
|
# to close over. |
621
|
|
|
|
|
|
|
# |
622
|
|
|
|
|
|
|
$env->{$_} = $opt->{env}{$_} |
623
|
1381
|
100
|
|
|
|
2475
|
for keys %{ $opt->{env} || {} }; |
|
1381
|
|
|
|
|
6646
|
|
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
# The additional_validation coderef will normally generate |
626
|
|
|
|
|
|
|
# new code. |
627
|
|
|
|
|
|
|
# |
628
|
1381
|
100
|
|
|
|
5335
|
if ( defined $opt->{code} ) { |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# Code can be inserted into the generated method straight away, |
631
|
|
|
|
|
|
|
# or may need to be inserted in a special placeholder position |
632
|
|
|
|
|
|
|
# later. |
633
|
|
|
|
|
|
|
# |
634
|
|
|
|
|
|
|
$opt->{add_later} |
635
|
|
|
|
|
|
|
? ( $state->{add_later} = $opt->{code} ) |
636
|
889
|
100
|
|
|
|
2705
|
: push( @$code, $opt->{code} ); |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
# Final type check is often no longer needed. |
639
|
|
|
|
|
|
|
# |
640
|
889
|
|
100
|
|
|
5893
|
$state->{final_type_check_needed} = $opt->{final_type_check_needed} || false; |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
|
644
|
4246
|
|
|
|
|
11822
|
return $self; |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
sub _handle_getter_code { |
648
|
4246
|
|
|
4246
|
|
9439
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
# If there's a complicated way to fetch the attribute value (perhaps |
651
|
|
|
|
|
|
|
# involving a lazy builder)... |
652
|
|
|
|
|
|
|
# |
653
|
4246
|
100
|
|
|
|
39270
|
if ( $state->{getter} !~ $REASONABLE_SCALAR ) { |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
# And if it's definitely a reference anyway, then get it straight away, |
656
|
|
|
|
|
|
|
# and store it in $shv_ref_invocant so we don't have to keep doing the |
657
|
|
|
|
|
|
|
# complicated thing. |
658
|
|
|
|
|
|
|
# |
659
|
847
|
100
|
100
|
|
|
6659
|
if ( $handler->name =~ /^(Array|Hash):/ ) { |
|
|
100
|
66
|
|
|
|
|
660
|
501
|
|
|
|
|
1831
|
push @$code, "my \$shv_ref_invocant = do { $state->{getter} };"; |
661
|
501
|
|
|
|
|
981
|
$state->{getter} = '$shv_ref_invocant'; |
662
|
501
|
|
|
|
|
981
|
$state->{getter_is_lvalue} = true; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
# Alternatively, unless the handler doesn't want us to, or the template |
666
|
|
|
|
|
|
|
# doesn't want to get the attribute value anyway, then we'll do something |
667
|
|
|
|
|
|
|
# similar. Here it can't be used as an lvalue though. |
668
|
|
|
|
|
|
|
# |
669
|
|
|
|
|
|
|
elsif ( $handler->allow_getter_shortcuts |
670
|
|
|
|
|
|
|
and $handler->template.($handler->lvalue_template||'') =~ /\$GET/ ) { |
671
|
343
|
|
|
|
|
1308
|
( my $g = $state->{getter} ) =~ s/%/%%/g; |
672
|
343
|
|
|
|
|
1007
|
$state->{template_wrapper} = "do { my \$shv_real_invocant = $g; %s }"; |
673
|
343
|
|
|
|
|
704
|
$state->{getter} = '$shv_real_invocant'; |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
|
677
|
4246
|
|
|
|
|
12357
|
return $self; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
sub _handle_setter_code { |
681
|
4246
|
|
|
4246
|
|
9309
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# If a type check is needed, but the setter doesn't do type checks, |
684
|
|
|
|
|
|
|
# then override the setter. Now the setter does the type check, so |
685
|
|
|
|
|
|
|
# we no longer need to worry about it. |
686
|
|
|
|
|
|
|
# |
687
|
|
|
|
|
|
|
# XXX: I don't think any of the tests currently exercise this. |
688
|
|
|
|
|
|
|
# |
689
|
4246
|
50
|
66
|
|
|
14341
|
if ( $state->{final_type_check_needed} and not $self->set_checks_isa ) { |
690
|
|
|
|
|
|
|
$self->_add_generator_override( set => sub { |
691
|
0
|
|
|
0
|
|
0
|
my ( $me, $value_code ) = @_; |
692
|
0
|
|
|
|
|
0
|
$me->generate_set( sprintf( |
693
|
|
|
|
|
|
|
'do { my $shv_final_unchecked = %s; %s }', |
694
|
|
|
|
|
|
|
$value_code, |
695
|
|
|
|
|
|
|
$me->generate_type_assertion( $env, $me->isa, '$shv_final_unchecked' ), |
696
|
|
|
|
|
|
|
) ); |
697
|
0
|
|
|
|
|
0
|
} ); |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# In this case we can no longer use the getter as an lvalue, if we |
700
|
|
|
|
|
|
|
# ever could. |
701
|
|
|
|
|
|
|
# |
702
|
0
|
|
|
|
|
0
|
$state->{getter_is_lvalue} = false; |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
# Stop worrying about the final type check. The setter does that now. |
705
|
|
|
|
|
|
|
# |
706
|
0
|
|
|
|
|
0
|
$state->{final_type_check_needed} = false; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
4246
|
|
|
|
|
10431
|
return $self; |
710
|
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
sub _handle_template { |
713
|
4246
|
|
|
4246
|
|
8359
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
714
|
|
|
|
|
|
|
|
715
|
4246
|
|
|
|
|
6382
|
my $template; |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
# If the getter is an lvalue, the handler has a special template |
718
|
|
|
|
|
|
|
# for lvalues, we haven't been told to set strictly, and we have taken |
719
|
|
|
|
|
|
|
# care of any type checks, then use the special lvalue template. |
720
|
|
|
|
|
|
|
# |
721
|
4246
|
100
|
100
|
|
|
26258
|
if ( $state->{getter_is_lvalue} |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
722
|
|
|
|
|
|
|
and $handler->lvalue_template |
723
|
|
|
|
|
|
|
and !$self->set_strictly |
724
|
|
|
|
|
|
|
and !$state->{final_type_check_needed} ) { |
725
|
465
|
|
|
|
|
1081
|
$template = $handler->lvalue_template; |
726
|
|
|
|
|
|
|
} |
727
|
|
|
|
|
|
|
else { |
728
|
3781
|
|
|
|
|
8921
|
$template = $handler->template; |
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
# Perform substitutions of special codes in the template string. |
732
|
|
|
|
|
|
|
# |
733
|
4246
|
|
|
|
|
9619
|
$template =~ s/\$SLOT/$self->generate_slot()/eg; |
|
2
|
|
|
|
|
6
|
|
734
|
4246
|
|
|
|
|
25409
|
$template =~ s/\$GET/$state->{getter}/g; |
735
|
4246
|
|
|
|
|
9889
|
$template =~ s/\$ATTRNAME/$self->attribute_name()/eg; |
|
3
|
|
|
|
|
16
|
|
736
|
4246
|
|
|
|
|
9657
|
$template =~ s/\$ARG\[([0-9]+)\]/$self->generate_arg($1)/eg; |
|
2586
|
|
|
|
|
6189
|
|
737
|
4246
|
|
|
|
|
10154
|
$template =~ s/\$ARG/$self->generate_arg(1)/eg; |
|
2067
|
|
|
|
|
5231
|
|
738
|
4246
|
|
|
|
|
9159
|
$template =~ s/\#ARG/$self->generate_argc()/eg; |
|
865
|
|
|
|
|
2343
|
|
739
|
4246
|
|
|
|
|
8262
|
$template =~ s/\@ARG/$self->generate_args()/eg; |
|
587
|
|
|
|
|
1679
|
|
740
|
4246
|
|
|
|
|
7782
|
$template =~ s/⸨(.+?)⸩/$self->generate_error($1)/eg; |
|
85
|
|
|
|
|
308
|
|
741
|
4246
|
|
|
|
|
14390
|
$template =~ s/«(.+?)»/$self->generate_set($1)/eg; |
|
1989
|
|
|
|
|
5341
|
|
742
|
4246
|
|
|
|
|
9304
|
$template =~ s/\$DEFAULT/$self->generate_default($handler)/eg; |
|
55
|
|
|
|
|
220
|
|
743
|
4246
|
|
|
|
|
7241
|
$template =~ s/\$SELF/$self->generate_self()/eg; |
|
47
|
|
|
|
|
131
|
|
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
# Apply wrapper (if any). This wrapper is given |
746
|
|
|
|
|
|
|
# by _handle_getter_code (sometimes). |
747
|
|
|
|
|
|
|
# |
748
|
|
|
|
|
|
|
$template = sprintf( $state->{template_wrapper}, $template ) |
749
|
4246
|
100
|
|
|
|
11631
|
if $state->{template_wrapper}; |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
# If validation needs to be added late... |
752
|
|
|
|
|
|
|
# |
753
|
|
|
|
|
|
|
$template =~ s/\"?____VALIDATION_HERE____\"?/$state->{add_later}/ |
754
|
4246
|
100
|
|
|
|
9928
|
if defined $state->{add_later}; |
755
|
|
|
|
|
|
|
|
756
|
4246
|
|
|
|
|
9751
|
push @$code, $template; |
757
|
|
|
|
|
|
|
|
758
|
4246
|
|
|
|
|
15690
|
return $self; |
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
sub _handle_chaining { |
762
|
4246
|
|
|
4246
|
|
9089
|
my ( $self, $method_name, $handler, $env, $code, $state ) = @_; |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
# Will just insert a string like ';$_[0]' at the end |
765
|
|
|
|
|
|
|
# |
766
|
4246
|
100
|
|
|
|
11856
|
push @$code, ';' . $self->generate_self, |
767
|
|
|
|
|
|
|
if $handler->is_chainable; |
768
|
|
|
|
|
|
|
|
769
|
4246
|
|
|
|
|
7266
|
return $self; |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
1; |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
__END__ |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
=pod |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
=encoding utf-8 |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
=head1 NAME |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
Sub::HandlesVia::CodeGenerator - looks at a Handler and generates a string of Perl code for it |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
=head1 DESCRIPTION |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
B<< This module is part of Sub::HandlesVia's internal API. >> |
787
|
|
|
|
|
|
|
It is mostly of interest to people extending Sub::HandlesVia. |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
Sub::HandlesVia toolkits create a code generator for each attribute they're |
790
|
|
|
|
|
|
|
dealing with, and use the code generator to generate Perl code for one or |
791
|
|
|
|
|
|
|
more delegated methods. |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
=head1 CONSTRUCTORS |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
=head2 C<< new( %attributes ) >> |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
Standard Moose-like constructor. |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
=head1 ATTRIBUTES |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
=head2 C<toolkit> B<Object> |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
The toolkit which made this code generator. |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=head2 C<target> B<< ClassName|RoleName >> |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
The target package for generated methods. |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
=head2 C<sandboxing_package> B<< ClassName|RoleName|Undef >> |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
Package name to use as a sandbox; the default is usually fine. |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
=head2 C<attribute> B<< Str|ArrayRef >> |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
The attribute delegated to. |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
=head2 C<attribute_spec> B<< HashRef >> |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
Informational only. |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
=head2 C<is_method> B<< Bool >> |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
Indicates whether the generated code should be methods rather than functions. |
824
|
|
|
|
|
|
|
This defaults to true, and false isn't really tested or well-defined. |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
=head2 C<env> B<< HashRef >> |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
Variables which need to be closed over when compiling coderefs. |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
=head2 C<isa> B<< Maybe[TypeTiny] >> |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
The type constraint for the attribute. |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
=head2 C<coerce> B<< Bool >> |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
Should the attribute coerce? |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
=head2 C<method_installer> B<CodeRef> |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
A coderef which can be called with C<< $method_name >> and C<< $coderef >>, |
841
|
|
|
|
|
|
|
will install the method. Note that it isn't passed the package to install |
842
|
|
|
|
|
|
|
into (which can be found in C<target>), so that would need to be closed |
843
|
|
|
|
|
|
|
over. |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
=head2 C<generator_for_self> B<< CodeRef >> |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
A coderef which if called, generates a string like C<< '$_[0]' >>. |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
Has a sensible default. |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
All the C<generator_for_XXX> methods are called as methods, so have |
852
|
|
|
|
|
|
|
the code generator object as an invocant. |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
=head2 C<generator_for_slot> B<< CodeRef >> |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
A coderef which if called, generates a string like C<< '$_[0]{attrname}' >>. |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
=head2 C<generator_for_get> B<< CodeRef >> |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
A coderef which if called, generates a string like C<< '$_[0]->attrname' >>. |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=head2 C<generator_for_set> B<< CodeRef >> |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
A coderef which if called with a parameter, generates a string like |
865
|
|
|
|
|
|
|
C<< "\$_[0]->_set_attrname( $parameter )" >>. |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
=head2 C<generator_for_simple_default> B<< CodeRef >> |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
A coderef which if called with a parameter, generates a string like |
870
|
|
|
|
|
|
|
C<< 'undef' >> or C<< 'q[]' >> or C<< '{}' >>. |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
The parameter is a handler object, which offers a C<default_for_reset> |
873
|
|
|
|
|
|
|
attribute which might be able to provide a useful fallback. |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=head2 C<generator_for_args> B<< CodeRef >> |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
A coderef which if called, generates a string like C<< '@_[1..$#_]' >>. |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
Has a sensible default. |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
=head2 C<generator_for_argc> B<< CodeRef >> |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
A coderef which if called, generates a string like C<< '$#_' >>. |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
Has a sensible default. |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
=head2 C<generator_for_argc> B<< CodeRef >> |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
A coderef which if called with a parameter, generates a string like |
890
|
|
|
|
|
|
|
C<< "\$_[$parameter + 1]" >>. |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
Has a sensible default. |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=head2 C<generator_for_currying> B<< CodeRef >> |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
A coderef which if called with a parameter, generates a string like |
897
|
|
|
|
|
|
|
C<< "splice(\@_,1,0,$parameter);" >>. |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
Has a sensible default. |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
=head2 C<generator_for_usage_string> B<< CodeRef >> |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
The default is this coderef: |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
sub { |
906
|
|
|
|
|
|
|
@_==3 or die; |
907
|
|
|
|
|
|
|
shift; |
908
|
|
|
|
|
|
|
my $method_name = shift; |
909
|
|
|
|
|
|
|
my $guts = shift; |
910
|
|
|
|
|
|
|
return "\$instance->$method_name($guts)"; |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
=head2 C<generator_for_type_assertion> B<< CodeRef >> |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
Called as a method and passed a hashref compilation environment, a type |
916
|
|
|
|
|
|
|
constraint, and a variable name. Generates code to assert that the variable |
917
|
|
|
|
|
|
|
value meets the type constraint, with coercion if appropriate. |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
=head2 C<generator_for_error> B<< CodeRef >> |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
Called as a method and passed a Perl string which is an expression evaluating |
922
|
|
|
|
|
|
|
to an error message. Generates code to throw the error. |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
=head2 C<generator_for_prelude> B<< CodeRef >> |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
By default is a coderef returning the empty string. Can be used to generate |
927
|
|
|
|
|
|
|
some additional statements which will be inserted near the top of the |
928
|
|
|
|
|
|
|
method being generated. (Typically after parameter checks but before |
929
|
|
|
|
|
|
|
doing anything serious.) This can be used to unlock a read-only attribute, |
930
|
|
|
|
|
|
|
for example. |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
=head2 C<get_is_lvalue> B<Bool> |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
Indicates wheter the code generated by C<generator_for_get> |
935
|
|
|
|
|
|
|
will be suitable for used as an lvalue. |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
=head2 C<set_checks_isa> B<Bool> |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
Indicates wheter the code generated by C<generator_for_set> |
940
|
|
|
|
|
|
|
will do type checks. |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
=head2 C<set_strictly> B<Bool> |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
Indicates wheter we want to ensure that the setter is always called, |
945
|
|
|
|
|
|
|
and we should not try to bypass it, even if we have an lvalue getter. |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=head1 METHODS |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
For each C<generator_for_XXX> attribute, there's a corresponding |
950
|
|
|
|
|
|
|
C<generate_XXX> method to actually call the coderef, possibly including |
951
|
|
|
|
|
|
|
additional processing. |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
=head2 C<< generate_and_install_method( $method_name, $handler ) >> |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
Given a handler and a method name, will generate a coderef for the handler |
956
|
|
|
|
|
|
|
and install it into the target package. |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
=head2 C<< generate_coderef_for_handler( $method_name, $handler ) >> |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
As above, but just returns the coderef rather than installs it. |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
=head2 C<< install_method( $method_name, $coderef ) >> |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
Installs a coderef into the target package with the given name. |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
=head1 BUGS |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
Please report any bugs to |
969
|
|
|
|
|
|
|
L<https://github.com/tobyink/p5-sub-handlesvia/issues>. |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
=head1 SEE ALSO |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
L<Sub::HandlesVia>. |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
=head1 AUTHOR |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
Toby Inkster E<lt>tobyink@cpan.orgE<gt>. |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENCE |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
This software is copyright (c) 2020, 2022 by Toby Inkster. |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
984
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
=head1 DISCLAIMER OF WARRANTIES |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED |
989
|
|
|
|
|
|
|
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF |
990
|
|
|
|
|
|
|
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. |