line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Function::Parameters; |
2
|
|
|
|
|
|
|
|
3
|
48
|
|
|
48
|
|
3131709
|
use v5.14.0; |
|
48
|
|
|
|
|
574
|
|
4
|
48
|
|
|
48
|
|
269
|
use warnings; |
|
48
|
|
|
|
|
99
|
|
|
48
|
|
|
|
|
1424
|
|
5
|
48
|
|
|
48
|
|
281
|
use warnings::register; |
|
48
|
|
|
|
|
92
|
|
|
48
|
|
|
|
|
7387
|
|
6
|
|
|
|
|
|
|
|
7
|
48
|
|
|
48
|
|
373
|
use Carp qw(croak confess); |
|
48
|
|
|
|
|
95
|
|
|
48
|
|
|
|
|
2881
|
|
8
|
48
|
|
|
48
|
|
338
|
use Scalar::Util qw(blessed); |
|
48
|
|
|
|
|
88
|
|
|
48
|
|
|
|
|
5226
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
sub _croak { |
11
|
247
|
|
|
247
|
|
280643
|
my (undef, $file, $line) = caller 1; |
12
|
247
|
|
|
|
|
1934
|
die @_, " at $file line $line.\n"; |
13
|
|
|
|
|
|
|
} |
14
|
|
|
|
|
|
|
|
15
|
48
|
|
|
48
|
|
367
|
use XSLoader; |
|
48
|
|
|
|
|
116
|
|
|
48
|
|
|
|
|
2119
|
|
16
|
|
|
|
|
|
|
BEGIN { |
17
|
48
|
|
|
48
|
|
165
|
our $VERSION = '2.002002'; |
18
|
|
|
|
|
|
|
#$VERSION =~ s/-TRIAL[0-9]*\z//; |
19
|
48
|
|
|
|
|
56811
|
XSLoader::load; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub _warn_config_not_a_reference { |
23
|
2
|
|
|
2
|
|
1957
|
warnings::warnif sprintf q{%s: $^H{'%s'} is not a reference; skipping: %s}, __PACKAGE__, HINTK_CONFIG, $^H{+HINTK_CONFIG}; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub _assert_valid_identifier { |
27
|
275
|
|
|
275
|
|
561
|
my ($name, $with_dollar) = @_; |
28
|
275
|
100
|
|
|
|
565
|
my $bonus = $with_dollar ? '\$' : ''; |
29
|
275
|
100
|
|
|
|
11309
|
$name =~ /\A${bonus}[^\W\d]\w*\z/ |
30
|
|
|
|
|
|
|
or confess qq{"$name" doesn't look like a valid identifier}; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub _assert_valid_attributes { |
34
|
77
|
|
|
77
|
|
185
|
my ($attrs) = @_; |
35
|
77
|
100
|
|
|
|
1070
|
$attrs =~ m{ |
36
|
|
|
|
|
|
|
\A \s*+ |
37
|
|
|
|
|
|
|
: \s*+ |
38
|
|
|
|
|
|
|
(?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+ |
39
|
|
|
|
|
|
|
(?: |
40
|
|
|
|
|
|
|
(?: : \s*+ )? |
41
|
|
|
|
|
|
|
(?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+ |
42
|
|
|
|
|
|
|
)*+ |
43
|
|
|
|
|
|
|
\z |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
(?(DEFINE) |
46
|
|
|
|
|
|
|
(? |
47
|
|
|
|
|
|
|
[^\W\d] |
48
|
|
|
|
|
|
|
\w*+ |
49
|
|
|
|
|
|
|
) |
50
|
|
|
|
|
|
|
(? |
51
|
|
|
|
|
|
|
\( |
52
|
|
|
|
|
|
|
[^()\\]*+ |
53
|
|
|
|
|
|
|
(?: |
54
|
|
|
|
|
|
|
(?: |
55
|
|
|
|
|
|
|
\\ . |
56
|
|
|
|
|
|
|
| |
57
|
|
|
|
|
|
|
(?¶m) |
58
|
|
|
|
|
|
|
) |
59
|
|
|
|
|
|
|
[^()\\]*+ |
60
|
|
|
|
|
|
|
)*+ |
61
|
|
|
|
|
|
|
\) |
62
|
|
|
|
|
|
|
) |
63
|
|
|
|
|
|
|
) |
64
|
|
|
|
|
|
|
}sx or confess qq{"$attrs" doesn't look like valid attributes}; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub _reify_type_moose { |
68
|
0
|
|
|
0
|
|
0
|
require Moose::Util::TypeConstraints; |
69
|
0
|
|
|
|
|
0
|
Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0]) |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub _malformed_type { |
73
|
0
|
|
|
0
|
|
0
|
my ($type, $msg) = @_; |
74
|
0
|
|
|
|
|
0
|
my $pos = pos $_[0]; |
75
|
0
|
|
|
|
|
0
|
substr $type, $pos, 0, ' <-- HERE '; |
76
|
0
|
|
|
|
|
0
|
croak "Malformed type: $msg marked by <-- HERE in '$type'"; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub _reify_type_auto_parameterized { |
80
|
|
|
|
|
|
|
# (str, caller) |
81
|
67
|
50
|
|
67
|
|
226
|
$_[0] =~ /\G ( \w+ (?: :: \w+)* ) \s* /xgc or _malformed_type $_[0], "missing type name"; |
82
|
67
|
|
|
|
|
166
|
my $name = $1; |
83
|
67
|
50
|
|
|
|
195
|
$name = "$_[1]::$name" unless $name =~ /::/; |
84
|
67
|
|
|
|
|
98
|
my $fun = do { |
85
|
48
|
|
|
48
|
|
413
|
no strict 'refs'; |
|
48
|
|
|
|
|
107
|
|
|
48
|
|
|
|
|
128991
|
|
86
|
67
|
100
|
|
|
|
644
|
defined &$name or croak "Undefined type name $name"; |
87
|
65
|
|
|
|
|
123
|
\&$name |
88
|
|
|
|
|
|
|
}; |
89
|
|
|
|
|
|
|
|
90
|
65
|
100
|
|
|
|
182
|
$_[0] =~ /\G \[ \s* /xgc |
91
|
|
|
|
|
|
|
or return $fun; |
92
|
|
|
|
|
|
|
|
93
|
8
|
|
|
|
|
13
|
my @args; |
94
|
8
|
|
|
|
|
16
|
until ($_[0] =~ /\G \] \s* /xgc) { |
95
|
16
|
100
|
33
|
|
|
51
|
$_[0] =~ /\G , \s* /xgc or _malformed_type $_[0], "missing ',' or ']'" |
96
|
|
|
|
|
|
|
if @args; |
97
|
16
|
|
|
|
|
36
|
push @args, &_reify_type_auto_union; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
8
|
|
|
8
|
|
34
|
sub { $fun->([map $_->(), @args]) } |
101
|
8
|
|
|
|
|
45
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub _reify_type_auto_term { |
104
|
|
|
|
|
|
|
# (str, caller) |
105
|
71
|
|
|
71
|
|
103
|
my $compl = 0; |
106
|
71
|
|
|
|
|
173
|
while ($_[0] =~ /\G ~ \s* /xgc) { |
107
|
8
|
|
|
|
|
18
|
$compl++; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
71
|
|
|
|
|
104
|
my $inner; |
111
|
71
|
100
|
|
|
|
135
|
if ($_[0] =~ /\G \( \s* /xgc) { |
112
|
4
|
|
|
|
|
9
|
$inner = &_reify_type_auto_union; |
113
|
4
|
50
|
|
|
|
13
|
$_[0] =~ /\G \) \s* /xgc or _malformed_type $_[0], "missing ')'"; |
114
|
|
|
|
|
|
|
} else { |
115
|
67
|
|
|
|
|
117
|
$inner = &_reify_type_auto_parameterized; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
!$compl |
119
|
|
|
|
|
|
|
? $inner |
120
|
|
|
|
|
|
|
: sub { |
121
|
4
|
|
|
4
|
|
128
|
my $t = $inner->(); |
122
|
4
|
|
|
|
|
42
|
for my $i (1 .. $compl) { |
123
|
8
|
|
|
|
|
53
|
$t = ~$t; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
$t |
126
|
4
|
|
|
|
|
44
|
} |
127
|
69
|
100
|
|
|
|
169
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub _reify_type_auto_alternative { |
130
|
|
|
|
|
|
|
# (str, caller) |
131
|
67
|
|
|
67
|
|
160
|
my $fun = &_reify_type_auto_term; |
132
|
65
|
|
|
|
|
166
|
while ($_[0] =~ m!\G / \s* !xgc) { |
133
|
4
|
|
|
|
|
8
|
my $right = &_reify_type_auto_term; |
134
|
4
|
|
|
|
|
8
|
my $left = $fun; |
135
|
4
|
|
|
4
|
|
15
|
$fun = sub { $left->() / $right->() }; |
|
4
|
|
|
|
|
165
|
|
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
$fun |
138
|
65
|
|
|
|
|
105
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub _reify_type_auto_intersection { |
141
|
|
|
|
|
|
|
# (str, caller) |
142
|
59
|
|
|
59
|
|
98
|
my $fun = &_reify_type_auto_alternative; |
143
|
57
|
|
|
|
|
124
|
while ($_[0] =~ /\G & \s* /xgc) { |
144
|
8
|
|
|
|
|
14
|
my $right = &_reify_type_auto_alternative; |
145
|
8
|
|
|
|
|
11
|
my $left = $fun; |
146
|
8
|
|
|
8
|
|
35
|
$fun = sub { $left->() & $right->() }; |
|
8
|
|
|
|
|
139
|
|
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
$fun |
149
|
57
|
|
|
|
|
91
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
sub _reify_type_auto_union { |
152
|
|
|
|
|
|
|
# (str, caller) |
153
|
45
|
|
|
45
|
|
90
|
my $fun = &_reify_type_auto_intersection; |
154
|
43
|
|
|
|
|
104
|
while ($_[0] =~ /\G \| \s* /xgc) { |
155
|
14
|
|
|
|
|
26
|
my $right = &_reify_type_auto_intersection; |
156
|
14
|
|
|
|
|
18
|
my $left = $fun; |
157
|
14
|
|
|
14
|
|
66
|
$fun = sub { $left->() | $right->() }; |
|
14
|
|
|
|
|
236
|
|
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
$fun |
160
|
43
|
|
|
|
|
105
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub _reify_type_auto { |
163
|
25
|
|
|
25
|
|
72988
|
my ($type) = @_; |
164
|
25
|
|
|
|
|
59
|
my $caller = caller; |
165
|
|
|
|
|
|
|
|
166
|
25
|
|
|
|
|
75
|
$type =~ /\G \s+ /xgc; |
167
|
25
|
|
|
|
|
95
|
my $tfun = _reify_type_auto_union $type, $caller; |
168
|
23
|
50
|
|
|
|
94
|
$type =~ /\G \z/xgc or _malformed_type $type, "trailing garbage"; |
169
|
23
|
|
|
|
|
1264
|
$tfun->() |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub _delete_default { |
173
|
1162
|
|
|
1162
|
|
2037
|
my ($href, $key, $default) = @_; |
174
|
1162
|
100
|
|
|
|
2697
|
exists $href->{$key} ? delete $href->{$key} : $default |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub _find_or_add_idx { |
178
|
1
|
|
|
1
|
|
2
|
my ($array, $x) = @_; |
179
|
1
|
|
|
|
|
2
|
my $index; |
180
|
1
|
|
|
|
|
5
|
for my $i (0 .. $#$array) { |
181
|
0
|
0
|
|
|
|
0
|
if ($array->[$i] == $x) { |
182
|
0
|
|
|
|
|
0
|
$index = $i; |
183
|
0
|
|
|
|
|
0
|
last; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
} |
186
|
1
|
50
|
|
|
|
4
|
unless (defined $index) { |
187
|
1
|
|
|
|
|
3
|
$index = @$array; |
188
|
1
|
|
|
|
|
3
|
push @$array, $x; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
$index |
191
|
1
|
|
|
|
|
2
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
my %type_map = ( |
194
|
|
|
|
|
|
|
function_strict => {}, |
195
|
|
|
|
|
|
|
function_lax => { |
196
|
|
|
|
|
|
|
defaults => 'function_strict', |
197
|
|
|
|
|
|
|
strict => 0, |
198
|
|
|
|
|
|
|
}, |
199
|
|
|
|
|
|
|
function => { defaults => 'function_strict' }, |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
method_strict => { |
202
|
|
|
|
|
|
|
defaults => 'function_strict', |
203
|
|
|
|
|
|
|
attributes => ':method', |
204
|
|
|
|
|
|
|
shift => '$self', |
205
|
|
|
|
|
|
|
invocant => 1, |
206
|
|
|
|
|
|
|
}, |
207
|
|
|
|
|
|
|
method_lax => { |
208
|
|
|
|
|
|
|
defaults => 'method_strict', |
209
|
|
|
|
|
|
|
strict => 0, |
210
|
|
|
|
|
|
|
}, |
211
|
|
|
|
|
|
|
method => { defaults => 'method_strict' }, |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
classmethod_strict => { |
214
|
|
|
|
|
|
|
defaults => 'method_strict', |
215
|
|
|
|
|
|
|
shift => '$class', |
216
|
|
|
|
|
|
|
}, |
217
|
|
|
|
|
|
|
classmethod_lax => { |
218
|
|
|
|
|
|
|
defaults => 'classmethod_strict', |
219
|
|
|
|
|
|
|
strict => 0, |
220
|
|
|
|
|
|
|
}, |
221
|
|
|
|
|
|
|
classmethod => { defaults => 'classmethod_strict' }, |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
around => { |
224
|
|
|
|
|
|
|
defaults => 'method', |
225
|
|
|
|
|
|
|
name => 'required', |
226
|
|
|
|
|
|
|
install_sub => 'around', |
227
|
|
|
|
|
|
|
shift => ['$orig', '$self'], |
228
|
|
|
|
|
|
|
runtime => 1, |
229
|
|
|
|
|
|
|
}, |
230
|
|
|
|
|
|
|
( |
231
|
|
|
|
|
|
|
map +( |
232
|
|
|
|
|
|
|
$_ => { |
233
|
|
|
|
|
|
|
defaults => 'method', |
234
|
|
|
|
|
|
|
name => 'required', |
235
|
|
|
|
|
|
|
install_sub => $_, |
236
|
|
|
|
|
|
|
runtime => 1, |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
), qw( |
239
|
|
|
|
|
|
|
before after augment override |
240
|
|
|
|
|
|
|
), |
241
|
|
|
|
|
|
|
), |
242
|
|
|
|
|
|
|
); |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
my %import_map = ( |
245
|
|
|
|
|
|
|
fun => 'function', |
246
|
|
|
|
|
|
|
( |
247
|
|
|
|
|
|
|
map +($_ => $_), |
248
|
|
|
|
|
|
|
qw( |
249
|
|
|
|
|
|
|
method |
250
|
|
|
|
|
|
|
classmethod |
251
|
|
|
|
|
|
|
before |
252
|
|
|
|
|
|
|
after |
253
|
|
|
|
|
|
|
around |
254
|
|
|
|
|
|
|
augment |
255
|
|
|
|
|
|
|
override |
256
|
|
|
|
|
|
|
) |
257
|
|
|
|
|
|
|
), |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
':strict' => { |
260
|
|
|
|
|
|
|
fun => 'function_strict', |
261
|
|
|
|
|
|
|
method => 'method_strict', |
262
|
|
|
|
|
|
|
}, |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
':lax' => { |
265
|
|
|
|
|
|
|
fun => 'function_lax', |
266
|
|
|
|
|
|
|
method => 'method_lax', |
267
|
|
|
|
|
|
|
}, |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
':std' => [qw(fun method)], |
270
|
|
|
|
|
|
|
':modifiers' => [qw( |
271
|
|
|
|
|
|
|
before |
272
|
|
|
|
|
|
|
after |
273
|
|
|
|
|
|
|
around |
274
|
|
|
|
|
|
|
augment |
275
|
|
|
|
|
|
|
override |
276
|
|
|
|
|
|
|
)], |
277
|
|
|
|
|
|
|
); |
278
|
|
|
|
|
|
|
for my $v (values %import_map) { |
279
|
|
|
|
|
|
|
if (ref $v eq 'ARRAY') { |
280
|
|
|
|
|
|
|
$v = { |
281
|
|
|
|
|
|
|
map +($_ => $import_map{$_} || die "Internal error: $v => $_"), |
282
|
|
|
|
|
|
|
@$v |
283
|
|
|
|
|
|
|
}; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub import { |
288
|
95
|
|
|
95
|
|
26087
|
my $class = shift; |
289
|
|
|
|
|
|
|
|
290
|
95
|
|
|
|
|
169
|
my %imports; |
291
|
95
|
100
|
|
|
|
336
|
@_ = qw(:std) if !@_; |
292
|
95
|
|
|
|
|
226
|
for my $item (@_) { |
293
|
101
|
|
|
|
|
174
|
my $part; |
294
|
101
|
100
|
|
|
|
288
|
if (ref $item) { |
295
|
51
|
|
|
|
|
96
|
$part = $item; |
296
|
|
|
|
|
|
|
} else { |
297
|
50
|
100
|
|
|
|
423
|
my $type = $import_map{$item} |
298
|
|
|
|
|
|
|
or croak qq{"$item" is not exported by the $class module}; |
299
|
48
|
100
|
|
|
|
177
|
$part = ref $type |
300
|
|
|
|
|
|
|
? $type |
301
|
|
|
|
|
|
|
: { $item => $type }; |
302
|
|
|
|
|
|
|
} |
303
|
99
|
|
|
|
|
526
|
@imports{keys %$part} = values %$part; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
93
|
|
|
|
|
178
|
my %spec; |
307
|
|
|
|
|
|
|
|
308
|
93
|
|
|
|
|
364
|
for my $name (sort keys %imports) { |
309
|
174
|
|
|
|
|
509
|
_assert_valid_identifier $name; |
310
|
169
|
|
|
|
|
478
|
my $proto_type = $imports{$name}; |
311
|
|
|
|
|
|
|
|
312
|
169
|
100
|
|
|
|
595
|
$proto_type = {defaults => $proto_type} unless ref $proto_type; |
313
|
|
|
|
|
|
|
|
314
|
169
|
|
|
|
|
633
|
my %type = %$proto_type; |
315
|
169
|
|
|
|
|
581
|
while (my $defaults = delete $type{defaults}) { |
316
|
340
|
100
|
|
|
|
923
|
my $base = $type_map{$defaults} |
317
|
1
|
|
|
|
|
191
|
or confess qq["$defaults" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; |
318
|
339
|
|
|
|
|
1458
|
%type = (%$base, %type); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
168
|
100
|
|
|
|
421
|
if (exists $type{strict}) { |
322
|
21
|
|
66
|
|
|
130
|
$type{check_argument_count} ||= $type{strict}; |
323
|
21
|
|
|
|
|
40
|
delete $type{strict}; |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
168
|
|
|
|
|
261
|
my %clean; |
327
|
|
|
|
|
|
|
|
328
|
168
|
|
100
|
|
|
738
|
$clean{name} = delete $type{name} // 'optional'; |
329
|
168
|
50
|
|
|
|
839
|
$clean{name} =~ /\A(?:optional|required|prohibited)\z/ |
330
|
|
|
|
|
|
|
or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; |
331
|
|
|
|
|
|
|
|
332
|
168
|
|
100
|
|
|
645
|
$clean{attrs} = delete $type{attributes} // ''; |
333
|
168
|
100
|
|
|
|
518
|
_assert_valid_attributes $clean{attrs} if $clean{attrs}; |
334
|
|
|
|
|
|
|
|
335
|
166
|
100
|
|
|
|
430
|
if (!exists $type{reify_type}) { |
336
|
162
|
|
|
|
|
371
|
$clean{reify_type} = \&_reify_type_auto; |
337
|
|
|
|
|
|
|
} else { |
338
|
4
|
|
50
|
|
|
15
|
my $rt = delete $type{reify_type} // '(undef)'; |
339
|
4
|
50
|
|
|
|
21
|
if (!ref $rt) { |
|
|
50
|
|
|
|
|
|
340
|
0
|
0
|
|
|
|
0
|
$rt = |
|
|
0
|
|
|
|
|
|
341
|
|
|
|
|
|
|
$rt eq 'auto' ? \&_reify_type_auto : |
342
|
|
|
|
|
|
|
$rt eq 'moose' ? \&_reify_type_moose : |
343
|
|
|
|
|
|
|
confess qq{"$rt" isn't a known predefined type reifier}; |
344
|
|
|
|
|
|
|
} elsif (ref $rt ne 'CODE') { |
345
|
0
|
|
|
|
|
0
|
confess qq{"$rt" doesn't look like a type reifier}; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
4
|
|
|
|
|
9
|
$clean{reify_type} = $rt; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
166
|
100
|
|
|
|
358
|
if (!exists $type{install_sub}) { |
352
|
148
|
|
|
|
|
289
|
$clean{install_sub} = ''; |
353
|
|
|
|
|
|
|
} else { |
354
|
18
|
|
|
|
|
32
|
my $is = delete $type{install_sub}; |
355
|
18
|
100
|
|
|
|
35
|
if (!ref $is) { |
|
|
50
|
|
|
|
|
|
356
|
17
|
|
|
|
|
40
|
_assert_valid_identifier $is; |
357
|
|
|
|
|
|
|
} elsif (ref $is ne 'CODE') { |
358
|
0
|
|
|
|
|
0
|
confess qq{"$is" doesn't look like a sub installer}; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
18
|
|
|
|
|
83
|
$clean{install_sub} = $is; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
166
|
|
|
|
|
248
|
$clean{shift} = do { |
365
|
166
|
|
100
|
|
|
549
|
my $shift = delete $type{shift} // []; |
366
|
166
|
100
|
|
|
|
503
|
$shift = [$shift] if !ref $shift; |
367
|
166
|
|
|
|
|
308
|
my $str = ''; |
368
|
166
|
|
|
|
|
447
|
my @shifty_types; |
369
|
166
|
|
|
|
|
400
|
for my $item (@$shift) { |
370
|
84
|
|
|
|
|
184
|
my ($name, $type); |
371
|
84
|
100
|
|
|
|
228
|
if (ref $item) { |
372
|
1
|
50
|
|
|
|
4
|
@$item == 2 or confess "A 'shift' item must have 2 elements, not " . @$item; |
373
|
1
|
|
|
|
|
3
|
($name, $type) = @$item; |
374
|
|
|
|
|
|
|
} else { |
375
|
83
|
|
|
|
|
157
|
$name = $item; |
376
|
|
|
|
|
|
|
} |
377
|
84
|
|
|
|
|
241
|
_assert_valid_identifier $name, 1; |
378
|
84
|
50
|
|
|
|
360
|
$name eq '$_' and confess q[Using "$_" as a parameter is not supported]; |
379
|
84
|
|
|
|
|
199
|
$str .= $name; |
380
|
84
|
100
|
|
|
|
226
|
if (defined $type) { |
381
|
1
|
50
|
|
|
|
7
|
blessed($type) or confess "${name}'s type must be an object, not $type"; |
382
|
1
|
|
|
|
|
4
|
my $index = _find_or_add_idx \@shifty_types, $type; |
383
|
1
|
|
|
|
|
3
|
$str .= "/$index"; |
384
|
|
|
|
|
|
|
} |
385
|
84
|
|
|
|
|
200
|
$str .= ' '; |
386
|
|
|
|
|
|
|
} |
387
|
166
|
|
|
|
|
360
|
$clean{shift_types} = \@shifty_types; |
388
|
166
|
|
|
|
|
489
|
$str |
389
|
|
|
|
|
|
|
}; |
390
|
|
|
|
|
|
|
|
391
|
166
|
|
|
|
|
430
|
$clean{default_arguments} = _delete_default \%type, 'default_arguments', 1; |
392
|
166
|
|
|
|
|
347
|
$clean{named_parameters} = _delete_default \%type, 'named_parameters', 1; |
393
|
166
|
|
|
|
|
379
|
$clean{types} = _delete_default \%type, 'types', 1; |
394
|
166
|
|
|
|
|
344
|
$clean{invocant} = _delete_default \%type, 'invocant', 0; |
395
|
166
|
|
|
|
|
350
|
$clean{runtime} = _delete_default \%type, 'runtime', 0; |
396
|
166
|
|
|
|
|
342
|
$clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 1; |
397
|
166
|
|
|
|
|
407
|
$clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 1; |
398
|
|
|
|
|
|
|
|
399
|
166
|
100
|
|
|
|
400
|
%type and confess "Invalid keyword property: @{[sort keys %type]}"; |
|
1
|
|
|
|
|
269
|
|
400
|
|
|
|
|
|
|
|
401
|
165
|
|
|
|
|
583
|
$spec{$name} = \%clean; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
84
|
|
100
|
|
|
174
|
my %config = %{$^H{+HINTK_CONFIG} // {}}; |
|
84
|
|
|
|
|
533
|
|
405
|
84
|
|
|
|
|
336
|
for my $kw (keys %spec) { |
406
|
165
|
|
|
|
|
316
|
my $type = $spec{$kw}; |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
my $flags = |
409
|
|
|
|
|
|
|
$type->{name} eq 'prohibited' ? FLAG_ANON_OK : |
410
|
165
|
100
|
|
|
|
526
|
$type->{name} eq 'required' ? FLAG_NAME_OK : |
|
|
100
|
|
|
|
|
|
411
|
|
|
|
|
|
|
FLAG_ANON_OK | FLAG_NAME_OK |
412
|
|
|
|
|
|
|
; |
413
|
165
|
100
|
|
|
|
389
|
$flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; |
414
|
165
|
100
|
|
|
|
359
|
$flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; |
415
|
165
|
50
|
|
|
|
383
|
$flags |= FLAG_CHECK_TARGS if $type->{check_argument_types}; |
416
|
165
|
100
|
|
|
|
348
|
$flags |= FLAG_INVOCANT if $type->{invocant}; |
417
|
165
|
50
|
|
|
|
346
|
$flags |= FLAG_NAMED_PARAMS if $type->{named_parameters}; |
418
|
165
|
50
|
|
|
|
388
|
$flags |= FLAG_TYPES_OK if $type->{types}; |
419
|
165
|
100
|
|
|
|
367
|
$flags |= FLAG_RUNTIME if $type->{runtime}; |
420
|
|
|
|
|
|
|
$config{$kw} = { |
421
|
|
|
|
|
|
|
HINTSK_FLAGS, => $flags, |
422
|
|
|
|
|
|
|
HINTSK_SHIFT, => $type->{shift}, |
423
|
|
|
|
|
|
|
HINTSK_ATTRS, => $type->{attrs}, |
424
|
|
|
|
|
|
|
HINTSK_REIFY, => $type->{reify_type}, |
425
|
|
|
|
|
|
|
HINTSK_INSTL, => $type->{install_sub}, |
426
|
165
|
|
|
|
|
860
|
!@{$type->{shift_types}} ? () : ( |
427
|
|
|
|
|
|
|
HINTSK_SHIF2, => $type->{shift_types}, |
428
|
165
|
100
|
|
|
|
307
|
), |
429
|
|
|
|
|
|
|
}; |
430
|
|
|
|
|
|
|
} |
431
|
84
|
|
|
|
|
14699
|
$^H{+HINTK_CONFIG} = \%config; |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
sub unimport { |
435
|
8
|
|
|
8
|
|
70
|
my $class = shift; |
436
|
|
|
|
|
|
|
|
437
|
8
|
100
|
|
|
|
26
|
if (!@_) { |
438
|
3
|
|
|
|
|
14
|
delete $^H{+HINTK_CONFIG}; |
439
|
3
|
|
|
|
|
267
|
return; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
5
|
|
|
|
|
8
|
my %config = %{$^H{+HINTK_CONFIG}}; |
|
5
|
|
|
|
|
48
|
|
443
|
5
|
|
|
|
|
19
|
delete @config{@_}; |
444
|
5
|
|
|
|
|
489
|
$^H{+HINTK_CONFIG} = \%config; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
our %metadata; |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
sub _register_info { |
451
|
|
|
|
|
|
|
my ( |
452
|
547
|
|
|
547
|
|
113141
|
$key, |
453
|
|
|
|
|
|
|
$declarator, |
454
|
|
|
|
|
|
|
$shift, |
455
|
|
|
|
|
|
|
$positional_required, |
456
|
|
|
|
|
|
|
$positional_optional, |
457
|
|
|
|
|
|
|
$named_required, |
458
|
|
|
|
|
|
|
$named_optional, |
459
|
|
|
|
|
|
|
$slurpy, |
460
|
|
|
|
|
|
|
$slurpy_type, |
461
|
|
|
|
|
|
|
) = @_; |
462
|
|
|
|
|
|
|
|
463
|
547
|
100
|
|
|
|
2874
|
my $info = { |
464
|
|
|
|
|
|
|
declarator => $declarator, |
465
|
|
|
|
|
|
|
shift => $shift, |
466
|
|
|
|
|
|
|
positional_required => $positional_required, |
467
|
|
|
|
|
|
|
positional_optional => $positional_optional, |
468
|
|
|
|
|
|
|
named_required => $named_required, |
469
|
|
|
|
|
|
|
named_optional => $named_optional, |
470
|
|
|
|
|
|
|
slurpy => defined $slurpy ? [$slurpy, $slurpy_type] : undef, |
471
|
|
|
|
|
|
|
}; |
472
|
|
|
|
|
|
|
|
473
|
547
|
|
|
|
|
121310
|
$metadata{$key} = $info; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub _mkparam1 { |
477
|
16
|
|
|
16
|
|
35
|
my ($pair) = @_; |
478
|
16
|
100
|
|
|
|
25
|
my ($v, $t) = @{$pair || []} or return undef; |
|
16
|
100
|
|
|
|
126
|
|
479
|
4
|
|
|
|
|
16
|
Function::Parameters::Param->new( |
480
|
|
|
|
|
|
|
name => $v, |
481
|
|
|
|
|
|
|
type => $t, |
482
|
|
|
|
|
|
|
) |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
sub _mkparams { |
486
|
64
|
|
|
64
|
|
87
|
my @r; |
487
|
64
|
|
|
|
|
176
|
while (my ($v, $t) = splice @_, 0, 2) { |
488
|
38
|
|
|
|
|
109
|
push @r, Function::Parameters::Param->new( |
489
|
|
|
|
|
|
|
name => $v, |
490
|
|
|
|
|
|
|
type => $t, |
491
|
|
|
|
|
|
|
); |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
\@r |
494
|
64
|
|
|
|
|
206
|
} |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
sub info { |
497
|
18
|
|
|
18
|
0
|
7912
|
my ($func) = @_; |
498
|
18
|
50
|
|
|
|
89
|
my $key = _cv_root $func or return undef; |
499
|
18
|
100
|
|
|
|
69
|
my $info = $metadata{$key} or return undef; |
500
|
16
|
|
|
|
|
2062
|
require Function::Parameters::Info; |
501
|
|
|
|
|
|
|
Function::Parameters::Info->new( |
502
|
|
|
|
|
|
|
keyword => $info->{declarator}, |
503
|
|
|
|
|
|
|
nshift => $info->{shift}, |
504
|
|
|
|
|
|
|
slurpy => _mkparam1($info->{slurpy}), |
505
|
|
|
|
|
|
|
( |
506
|
16
|
|
|
|
|
67
|
map +("_$_" => _mkparams @{$info->{$_}}), |
|
64
|
|
|
|
|
164
|
|
507
|
|
|
|
|
|
|
qw( |
508
|
|
|
|
|
|
|
positional_required |
509
|
|
|
|
|
|
|
positional_optional |
510
|
|
|
|
|
|
|
named_required |
511
|
|
|
|
|
|
|
named_optional |
512
|
|
|
|
|
|
|
) |
513
|
|
|
|
|
|
|
) |
514
|
|
|
|
|
|
|
) |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
'ok' |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
__END__ |