line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Perinci::Sub::ValidateArgs; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY |
4
|
|
|
|
|
|
|
our $DATE = '2020-03-10'; # DATE |
5
|
|
|
|
|
|
|
our $DIST = 'Perinci-Sub-ValidateArgs'; # DIST |
6
|
|
|
|
|
|
|
our $VERSION = '0.013'; # VERSION |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
108619
|
use 5.010001; |
|
1
|
|
|
|
|
14
|
|
9
|
1
|
|
|
1
|
|
7
|
use strict 'subs', 'vars'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
38
|
|
10
|
1
|
|
|
1
|
|
6
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
27
|
|
11
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
548
|
use Data::Dmp; |
|
1
|
|
|
|
|
1843
|
|
|
1
|
|
|
|
|
60
|
|
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
7
|
use Exporter qw(import); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1863
|
|
15
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
16
|
|
|
|
|
|
|
gen_args_validator |
17
|
|
|
|
|
|
|
gen_args_validator_from_meta |
18
|
|
|
|
|
|
|
validate_args_using_meta |
19
|
|
|
|
|
|
|
); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# old name, deprecated |
22
|
|
|
|
|
|
|
*gen_args_validator = \&gen_args_validator_from_meta; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# XXX cache key should also contain data_term |
25
|
|
|
|
|
|
|
#my %dsah_compile_cache; # key = schema (C<string> or R<refaddr>), value = compilation result |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
our %SPEC; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our %arg_meta = ( |
30
|
|
|
|
|
|
|
meta => { |
31
|
|
|
|
|
|
|
schema => 'hash*', # XXX rinci::function_meta |
32
|
|
|
|
|
|
|
req => 1, |
33
|
|
|
|
|
|
|
}, |
34
|
|
|
|
|
|
|
); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
our %argopt_meta = ( |
37
|
|
|
|
|
|
|
meta => { |
38
|
|
|
|
|
|
|
schema => 'hash*', # XXX rinci::function_meta |
39
|
|
|
|
|
|
|
description => <<'_', |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
If not specified, will be searched from caller's `%SPEC` package variable. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
_ |
44
|
|
|
|
|
|
|
}, |
45
|
|
|
|
|
|
|
); |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
our %argopt_die = ( |
48
|
|
|
|
|
|
|
die => { |
49
|
|
|
|
|
|
|
summary => 'Whether validator should die or just return '. |
50
|
|
|
|
|
|
|
'an error message/response', |
51
|
|
|
|
|
|
|
schema => 'bool', |
52
|
|
|
|
|
|
|
}, |
53
|
|
|
|
|
|
|
); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
our %args_gen_args = ( |
56
|
|
|
|
|
|
|
%argopt_meta, |
57
|
|
|
|
|
|
|
%argopt_die, |
58
|
|
|
|
|
|
|
source => { |
59
|
|
|
|
|
|
|
summary => 'Whether we want to get the source code instead', |
60
|
|
|
|
|
|
|
schema => 'bool', |
61
|
|
|
|
|
|
|
description => <<'_', |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
The default is to generate Perl validator code, compile it with `eval()`, and |
64
|
|
|
|
|
|
|
return the resulting coderef. When this option is set to true, the generated |
65
|
|
|
|
|
|
|
source string will be returned instead. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
_ |
68
|
|
|
|
|
|
|
}, |
69
|
|
|
|
|
|
|
); |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
$SPEC{gen_args_validator_from_meta} = { |
72
|
|
|
|
|
|
|
v => 1.1, |
73
|
|
|
|
|
|
|
summary => 'Generate argument validator from Rinci function metadata', |
74
|
|
|
|
|
|
|
description => <<'_', |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
If you don't intend to reuse the generated validator, you can also use |
77
|
|
|
|
|
|
|
`validate_args_using_meta`. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
_ |
80
|
|
|
|
|
|
|
args => { |
81
|
|
|
|
|
|
|
%args_gen_args, |
82
|
|
|
|
|
|
|
}, |
83
|
|
|
|
|
|
|
result_naked => 1, |
84
|
|
|
|
|
|
|
}; |
85
|
|
|
|
|
|
|
sub gen_args_validator_from_meta { |
86
|
20
|
|
|
20
|
1
|
26832
|
my %args = @_; |
87
|
|
|
|
|
|
|
|
88
|
20
|
|
|
|
|
43
|
my $meta = $args{meta}; |
89
|
20
|
100
|
|
|
|
56
|
unless ($meta) { |
90
|
7
|
50
|
|
|
|
24
|
my @caller = caller(1) or die "Call gen_args_validator_from_meta() inside ". |
91
|
|
|
|
|
|
|
"your function or provide 'meta'"; |
92
|
7
|
|
|
|
|
231
|
my ($pkg, $func) = $caller[3] =~ /(.+)::(.+)/; |
93
|
7
|
50
|
|
|
|
14
|
$meta = ${"$pkg\::SPEC"}{$func} |
|
7
|
|
|
|
|
44
|
|
94
|
|
|
|
|
|
|
or die "No metadata for $caller[3]"; |
95
|
|
|
|
|
|
|
} |
96
|
20
|
|
100
|
|
|
79
|
my $args_as = $meta->{args_as} // 'hash'; |
97
|
20
|
|
100
|
|
|
73
|
my $meta_args = $meta->{args} // {}; |
98
|
20
|
|
|
|
|
102
|
my @meta_args = sort keys %$meta_args; |
99
|
|
|
|
|
|
|
|
100
|
20
|
|
|
|
|
69
|
my @code; |
101
|
|
|
|
|
|
|
my @modules_for_all_args; |
102
|
20
|
|
|
|
|
0
|
my @mod_stmts; |
103
|
|
|
|
|
|
|
|
104
|
20
|
|
|
|
|
0
|
my $use_dpath; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
my $gencode_err = sub { |
107
|
72
|
|
|
72
|
|
168
|
my ($status, $term_msg) = @_; |
108
|
72
|
100
|
|
|
|
212
|
if ($args{die}) { |
|
|
100
|
|
|
|
|
|
109
|
16
|
|
|
|
|
58
|
return "die $term_msg;"; |
110
|
|
|
|
|
|
|
} elsif ($meta->{result_naked}) { |
111
|
|
|
|
|
|
|
# perhaps if result_naked=1, die by default? |
112
|
4
|
|
|
|
|
14
|
return "return $term_msg;"; |
113
|
|
|
|
|
|
|
} else { |
114
|
52
|
|
|
|
|
261
|
return "return [$status, $term_msg];"; |
115
|
|
|
|
|
|
|
} |
116
|
20
|
|
|
|
|
89
|
}; |
117
|
|
|
|
|
|
|
my $addcode_validator = sub { |
118
|
38
|
|
|
38
|
|
61
|
state $plc = do { |
119
|
19
|
|
|
|
|
1154
|
require Data::Sah; |
120
|
19
|
|
|
|
|
7788
|
Data::Sah->new->get_compiler("perl"); |
121
|
|
|
|
|
|
|
}; |
122
|
38
|
|
|
|
|
37021
|
my ($schema, $data_name, $data_term) = @_; |
123
|
38
|
|
|
|
|
62
|
my $cd; |
124
|
38
|
100
|
|
|
|
129
|
my $cache_key = ref($schema) ? "R$schema" : "S$schema"; |
125
|
|
|
|
|
|
|
#unless ($cd = $dsah_compile_cache{$cache_key}) { |
126
|
38
|
|
|
|
|
116
|
$cd = $plc->compile( |
127
|
|
|
|
|
|
|
schema => $schema, |
128
|
|
|
|
|
|
|
data_name => $data_name, |
129
|
|
|
|
|
|
|
data_term => $data_term, |
130
|
|
|
|
|
|
|
err_term => '$err', |
131
|
|
|
|
|
|
|
return_type => 'str', |
132
|
|
|
|
|
|
|
indent_level => 2, |
133
|
|
|
|
|
|
|
); |
134
|
38
|
50
|
|
|
|
250031
|
die "Incompatible Data::Sah version (cd v=$cd->{v}, expected 2)" unless $cd->{v} == 2; |
135
|
|
|
|
|
|
|
# $dsah_compile_cache{$cache_key} = $cd; |
136
|
|
|
|
|
|
|
#} |
137
|
38
|
|
|
|
|
93
|
push @code, " \$err = undef;\n"; |
138
|
38
|
100
|
|
|
|
102
|
push @code, " \$_sahv_dpath = [];\n" if $cd->{use_dpath}; |
139
|
38
|
|
|
|
|
55
|
push @code, " unless (\n"; |
140
|
38
|
|
|
|
|
131
|
push @code, $cd->{result}, ") { ".$gencode_err->(400, "\"Validation failed for argument '$data_name': \$err\"")." }\n"; |
141
|
38
|
|
|
|
|
68
|
for my $mod_rec (@{ $cd->{modules} }) { |
|
38
|
|
|
|
|
109
|
|
142
|
150
|
100
|
|
|
|
613
|
next unless $mod_rec->{phase} eq 'runtime'; |
143
|
94
|
100
|
|
|
|
169
|
next if grep { ($mod_rec->{use_statement} && $_->{use_statement} && $_->{use_statement} eq $mod_rec->{use_statement}) || |
144
|
149
|
100
|
100
|
|
|
731
|
$_->{name} eq $mod_rec->{name} } @modules_for_all_args; |
|
|
|
66
|
|
|
|
|
145
|
56
|
|
|
|
|
103
|
push @modules_for_all_args, $mod_rec; |
146
|
56
|
|
|
|
|
155
|
push @mod_stmts, $plc->stmt_require_module($mod_rec)."\n"; |
147
|
|
|
|
|
|
|
} |
148
|
38
|
100
|
|
|
|
566
|
if ($cd->{use_dpath}) { |
149
|
18
|
|
|
|
|
411
|
$use_dpath = 1; |
150
|
|
|
|
|
|
|
} |
151
|
20
|
|
|
|
|
81
|
}; |
152
|
|
|
|
|
|
|
|
153
|
20
|
100
|
100
|
|
|
96
|
if ($args_as eq 'hash' || $args_as eq 'hashref') { |
|
|
50
|
66
|
|
|
|
|
154
|
15
|
|
|
|
|
36
|
push @code, " # check unknown args\n"; |
155
|
15
|
|
|
|
|
31
|
push @code, " for (keys %\$args) { unless (/\\A(".join("|", map { quotemeta } @meta_args).")\\z/) { ".$gencode_err->(400, '"Unknown argument \'$_\'"')." } }\n"; |
|
28
|
|
|
|
|
101
|
|
156
|
15
|
|
|
|
|
34
|
push @code, "\n"; |
157
|
|
|
|
|
|
|
|
158
|
15
|
|
|
|
|
34
|
for my $arg_name (@meta_args) { |
159
|
28
|
|
|
|
|
70
|
my $arg_spec = $meta_args->{$arg_name}; |
160
|
28
|
|
|
|
|
54
|
my $term_arg = "\$args->{'$arg_name'}"; |
161
|
28
|
|
|
|
|
64
|
push @code, " # check argument $arg_name\n"; |
162
|
28
|
100
|
|
|
|
91
|
if (defined $arg_spec->{default}) { |
163
|
14
|
|
|
|
|
52
|
push @code, " $term_arg //= ".dmp($arg_spec->{default}).";\n"; |
164
|
|
|
|
|
|
|
} |
165
|
28
|
|
|
|
|
878
|
push @code, " if (exists $term_arg) {\n"; |
166
|
28
|
50
|
|
|
|
137
|
$addcode_validator->($arg_spec->{schema}, $arg_name, $term_arg) if $arg_spec->{schema}; |
167
|
28
|
100
|
|
|
|
86
|
if ($arg_spec->{req}) { |
168
|
14
|
|
|
|
|
27
|
push @code, " } else {\n"; |
169
|
14
|
|
|
|
|
42
|
push @code, " ".$gencode_err->(400, "\"Missing required argument '$arg_name'\"")."\n"; |
170
|
|
|
|
|
|
|
} |
171
|
28
|
|
|
|
|
75
|
push @code, " }\n"; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
15
|
100
|
|
|
|
42
|
push @code, "\n" if @meta_args; |
175
|
|
|
|
|
|
|
} elsif ($args_as eq 'array' || $args_as eq 'arrayref') { |
176
|
|
|
|
|
|
|
# map the arguments' position |
177
|
|
|
|
|
|
|
my @arg_names = sort { |
178
|
5
|
|
50
|
|
|
21
|
($meta_args->{$a}{pos}//9999) <=> ($meta_args->{$b}{pos}//9999) |
|
5
|
|
50
|
|
|
55
|
|
179
|
|
|
|
|
|
|
} keys %$meta_args; |
180
|
5
|
100
|
66
|
|
|
36
|
if (@arg_names && ($meta_args->{$arg_names[-1]}{slurpy} // $meta_args->{$arg_names[-1]}{greedy})) { |
|
|
|
66
|
|
|
|
|
181
|
4
|
|
|
|
|
8
|
my $pos = @arg_names - 1; |
182
|
4
|
|
|
|
|
11
|
push @code, " # handle slurpy last arg\n"; |
183
|
4
|
|
|
|
|
17
|
push @code, " if (\@\$args >= $pos) { \$args->[$pos] = [splice \@\$args, $pos] }\n\n"; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
5
|
|
|
|
|
8
|
my $start_of_optional; |
187
|
5
|
|
|
|
|
14
|
for my $i (0..$#arg_names) { |
188
|
10
|
|
|
|
|
18
|
my $arg_name = $arg_names[$i]; |
189
|
10
|
|
|
|
|
18
|
my $arg_spec = $meta_args->{$arg_name}; |
190
|
10
|
100
|
|
|
|
22
|
if ($arg_spec->{req}) { |
191
|
5
|
50
|
|
|
|
16
|
if (defined $start_of_optional) { |
192
|
0
|
|
|
|
|
0
|
die "Error in metadata: after a param is optional ". |
193
|
|
|
|
|
|
|
"(#$start_of_optional) the rest (#$i) must also be optional"; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
} else { |
196
|
5
|
|
33
|
|
|
20
|
$start_of_optional //= $i; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
5
|
|
|
|
|
12
|
push @code, " # check number of args\n"; |
201
|
5
|
50
|
|
|
|
12
|
if ($start_of_optional) { |
|
|
0
|
|
|
|
|
|
202
|
5
|
|
|
|
|
25
|
push @code, " if (\@\$args < $start_of_optional || \@\$args > ".(@arg_names).") { ".$gencode_err->(400, "\"Wrong number of arguments (expected $start_of_optional..".(@arg_names).", got \".(\@\$args).\")\"") . " }\n"; |
203
|
|
|
|
|
|
|
} elsif (defined $start_of_optional) { |
204
|
0
|
|
|
|
|
0
|
push @code, " if (\@\$args > ".(@arg_names).") { ".$gencode_err->(400, "\"Wrong number of arguments (expected 0..".(@arg_names).", got \".(\@\$args).\")\"") . " }\n"; |
205
|
|
|
|
|
|
|
} else { |
206
|
0
|
|
|
|
|
0
|
push @code, " if (\@\$args != ".(@arg_names).") { ".$gencode_err->(400, "\"Wrong number of arguments (expected ".(@arg_names).", got \".(\@\$args).\")\"") . " }\n"; |
207
|
|
|
|
|
|
|
} |
208
|
5
|
|
|
|
|
13
|
push @code, "\n"; |
209
|
|
|
|
|
|
|
|
210
|
5
|
|
|
|
|
10
|
for my $i (0..$#arg_names) { |
211
|
10
|
|
|
|
|
21
|
my $arg_name = $arg_names[$i]; |
212
|
10
|
|
|
|
|
18
|
my $arg_spec = $meta_args->{$arg_name}; |
213
|
10
|
|
|
|
|
21
|
my $term_arg = "\$args->[$i]"; |
214
|
10
|
50
|
66
|
|
|
74
|
if (!defined($arg_spec->{pos})) { |
|
|
50
|
66
|
|
|
|
|
|
|
50
|
|
|
|
|
|
215
|
0
|
|
|
|
|
0
|
die "Error in metadata: argument '$arg_name' does not ". |
216
|
|
|
|
|
|
|
"have pos property set"; |
217
|
|
|
|
|
|
|
} elsif ($arg_spec->{pos} != $i) { |
218
|
0
|
|
|
|
|
0
|
die "Error in metadata: argument '$arg_name' does not ". |
219
|
|
|
|
|
|
|
"the correct pos value ($arg_spec->{pos}, should be $i)"; |
220
|
|
|
|
|
|
|
} elsif (($arg_spec->{slurpy} // $arg_spec->{greedy}) && $i < $#arg_names) { |
221
|
0
|
|
|
|
|
0
|
die "Error in metadata: argument '$arg_name' has slurpy=1 ". |
222
|
|
|
|
|
|
|
"but is not the last argument"; |
223
|
|
|
|
|
|
|
} |
224
|
10
|
|
|
|
|
30
|
push @code, " # check argument $arg_name\n"; |
225
|
10
|
100
|
|
|
|
26
|
if (defined $arg_spec->{default}) { |
226
|
5
|
|
|
|
|
19
|
push @code, " $term_arg //= ".dmp($arg_spec->{default}).";\n"; |
227
|
|
|
|
|
|
|
} |
228
|
10
|
|
|
|
|
268
|
my $open_block; |
229
|
10
|
100
|
66
|
|
|
43
|
if (defined($start_of_optional) && $i >= $start_of_optional) { |
230
|
5
|
|
|
|
|
10
|
$open_block++; |
231
|
5
|
|
|
|
|
15
|
push @code, " if (\@\$args > $i) {\n"; |
232
|
|
|
|
|
|
|
} |
233
|
10
|
50
|
|
|
|
39
|
$addcode_validator->($arg_spec->{schema}, $arg_name, $term_arg) if $arg_spec->{schema}; |
234
|
10
|
100
|
|
|
|
28
|
push @code, " }\n" if $open_block; |
235
|
|
|
|
|
|
|
|
236
|
10
|
|
|
|
|
30
|
push @code, "\n"; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
} else { |
239
|
0
|
|
|
|
|
0
|
die "Unsupported args_as '$args_as'"; |
240
|
|
|
|
|
|
|
} |
241
|
20
|
|
|
|
|
40
|
push @code, " return undef;\n"; |
242
|
20
|
|
|
|
|
35
|
push @code, "}\n"; |
243
|
|
|
|
|
|
|
|
244
|
20
|
|
|
|
|
73
|
unshift @code, ( |
245
|
|
|
|
|
|
|
"sub {\n", |
246
|
|
|
|
|
|
|
" my \$args = shift;\n", |
247
|
|
|
|
|
|
|
" my \$err;\n", |
248
|
|
|
|
|
|
|
(" my \$_sahv_dpath;\n") x !!$use_dpath, |
249
|
|
|
|
|
|
|
"\n" |
250
|
|
|
|
|
|
|
); |
251
|
|
|
|
|
|
|
|
252
|
20
|
|
|
|
|
130
|
my $code = join("", @mod_stmts, @code); |
253
|
20
|
100
|
|
|
|
48
|
if ($args{source}) { |
254
|
1
|
|
|
|
|
16
|
return $code; |
255
|
|
|
|
|
|
|
} else { |
256
|
|
|
|
|
|
|
#use String::LineNumber 'linenum'; say linenum $code; |
257
|
1
|
|
|
1
|
|
11
|
my $sub = eval $code; |
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
658
|
|
|
1
|
|
|
1
|
|
7
|
|
|
1
|
|
|
1
|
|
3
|
|
|
1
|
|
|
1
|
|
617
|
|
|
1
|
|
|
1
|
|
8
|
|
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
598
|
|
|
1
|
|
|
1
|
|
7
|
|
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
605
|
|
|
1
|
|
|
1
|
|
7
|
|
|
1
|
|
|
1
|
|
3
|
|
|
1
|
|
|
1
|
|
628
|
|
|
1
|
|
|
1
|
|
8
|
|
|
1
|
|
|
1
|
|
3
|
|
|
1
|
|
|
1
|
|
621
|
|
|
1
|
|
|
1
|
|
9
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
602
|
|
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
631
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
639
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
616
|
|
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
560
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
555
|
|
|
1
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
241
|
|
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
550
|
|
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
539
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
650
|
|
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
594
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
618
|
|
|
1
|
|
|
|
|
10
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
618
|
|
|
19
|
|
|
|
|
1755
|
|
258
|
19
|
50
|
|
|
|
74
|
die if $@; |
259
|
19
|
|
|
|
|
397
|
return $sub; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
$SPEC{validate_args_using_meta} = { |
264
|
|
|
|
|
|
|
v => 1.1, |
265
|
|
|
|
|
|
|
summary => 'Validate arguments using Rinci function metadata', |
266
|
|
|
|
|
|
|
description => <<'_', |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
If you intend to reuse the generated validator, you can also use |
269
|
|
|
|
|
|
|
`gen_args_validator_from_meta`. |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
Note: currently cannot handle `args_as => 'array'`, only `args_as => 'arrayref`. |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
_ |
274
|
|
|
|
|
|
|
args => { |
275
|
|
|
|
|
|
|
%arg_meta, |
276
|
|
|
|
|
|
|
%argopt_die, |
277
|
|
|
|
|
|
|
args => { |
278
|
|
|
|
|
|
|
schema => ['any*', of=>['hash*', 'array*']], |
279
|
|
|
|
|
|
|
req => 1, |
280
|
|
|
|
|
|
|
}, |
281
|
|
|
|
|
|
|
}, |
282
|
|
|
|
|
|
|
}; |
283
|
|
|
|
|
|
|
sub validate_args_using_meta { |
284
|
12
|
|
|
12
|
1
|
7628
|
my %args = @_; |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
my $validator = gen_args_validator_from_meta( |
287
|
|
|
|
|
|
|
meta => $args{meta}, |
288
|
|
|
|
|
|
|
die => $args{die}, |
289
|
12
|
|
|
|
|
48
|
); |
290
|
12
|
|
100
|
|
|
394
|
$validator->($args{args}) // [200, "OK"]; |
291
|
|
|
|
|
|
|
}; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
1; |
294
|
|
|
|
|
|
|
# ABSTRACT: Validate function arguments using schemas in Rinci function metadata |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
__END__ |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=pod |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=encoding UTF-8 |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=head1 NAME |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
Perinci::Sub::ValidateArgs - Validate function arguments using schemas in Rinci function metadata |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=head1 VERSION |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
This document describes version 0.013 of Perinci::Sub::ValidateArgs (from Perl distribution Perinci-Sub-ValidateArgs), released on 2020-03-10. |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=head1 SYNOPSIS |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
use Perinci::Sub::ValidateArgs qw(gen_args_validator_from_meta); |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
our %SPEC; |
315
|
|
|
|
|
|
|
$SPEC{foo} = { |
316
|
|
|
|
|
|
|
v => 1.1, |
317
|
|
|
|
|
|
|
args => { |
318
|
|
|
|
|
|
|
a1 => { |
319
|
|
|
|
|
|
|
schema => 'int*', |
320
|
|
|
|
|
|
|
req => 1, |
321
|
|
|
|
|
|
|
}, |
322
|
|
|
|
|
|
|
a2 => { |
323
|
|
|
|
|
|
|
schema => [array => of=>'int*'], |
324
|
|
|
|
|
|
|
default => 'peach', |
325
|
|
|
|
|
|
|
}, |
326
|
|
|
|
|
|
|
}, |
327
|
|
|
|
|
|
|
'x.func.validate_args' => 1, |
328
|
|
|
|
|
|
|
}; |
329
|
|
|
|
|
|
|
sub foo { |
330
|
|
|
|
|
|
|
state $validator = gen_args_validator_from_meta(); |
331
|
|
|
|
|
|
|
my %args = @_; |
332
|
|
|
|
|
|
|
if (my $err = $validator->(\%args)) { return $err } |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
... |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
or, if you want the validator to die on failure: |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
... |
340
|
|
|
|
|
|
|
sub foo { |
341
|
|
|
|
|
|
|
state $validator = gen_args_validator_from_meta(die => 1); |
342
|
|
|
|
|
|
|
my %args = @_; |
343
|
|
|
|
|
|
|
$validator->(\%args); |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
... |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
=head1 DESCRIPTION |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
This module (PSV for short) can be used to validate function arguments using |
351
|
|
|
|
|
|
|
schema information in Rinci function metadata. |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
There are other ways if you want to validate function arguments using Sah |
354
|
|
|
|
|
|
|
schemas. See L<Data::Sah::Manual::ParamsValidating>. |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=head1 FUNCTIONS |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
=head2 gen_args_validator_from_meta |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
Usage: |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
gen_args_validator_from_meta(%args) -> any |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
Generate argument validator from Rinci function metadata. |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
If you don't intend to reuse the generated validator, you can also use |
368
|
|
|
|
|
|
|
C<validate_args_using_meta>. |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
This function is not exported by default, but exportable. |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
Arguments ('*' denotes required arguments): |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
=over 4 |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
=item * B<die> => I<bool> |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
Whether validator should die or just return an error messageE<sol>response. |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
=item * B<meta> => I<hash> |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
If not specified, will be searched from caller's C<%SPEC> package variable. |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
=item * B<source> => I<bool> |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
Whether we want to get the source code instead. |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
The default is to generate Perl validator code, compile it with C<eval()>, and |
389
|
|
|
|
|
|
|
return the resulting coderef. When this option is set to true, the generated |
390
|
|
|
|
|
|
|
source string will be returned instead. |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=back |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
Return value: (any) |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
=head2 validate_args_using_meta |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
Usage: |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
validate_args_using_meta(%args) -> [status, msg, payload, meta] |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
Validate arguments using Rinci function metadata. |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
If you intend to reuse the generated validator, you can also use |
408
|
|
|
|
|
|
|
C<gen_args_validator_from_meta>. |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
Note: currently cannot handle C<< args_as =E<gt> 'array' >>, only C<< args_as =E<gt> 'arrayref >>. |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
This function is not exported by default, but exportable. |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
Arguments ('*' denotes required arguments): |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=over 4 |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=item * B<args>* => I<hash|array> |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=item * B<die> => I<bool> |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
Whether validator should die or just return an error messageE<sol>response. |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=item * B<meta>* => I<hash> |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
=back |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
Returns an enveloped result (an array). |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
First element (status) is an integer containing HTTP status code |
432
|
|
|
|
|
|
|
(200 means OK, 4xx caller error, 5xx function error). Second element |
433
|
|
|
|
|
|
|
(msg) is a string containing error message, or 'OK' if status is |
434
|
|
|
|
|
|
|
200. Third element (payload) is optional, the actual result. Fourth |
435
|
|
|
|
|
|
|
element (meta) is called result metadata and is optional, a hash |
436
|
|
|
|
|
|
|
that contains extra information. |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
Return value: (any) |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
=for Pod::Coverage ^(gen_args_validator)$ |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
=head1 HOMEPAGE |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-ValidateArgs>. |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head1 SOURCE |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-ValidateArgs>. |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=head1 BUGS |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-ValidateArgs> |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
When submitting a bug or request, please include a test-file or a |
455
|
|
|
|
|
|
|
patch to an existing test-file that illustrates the bug or desired |
456
|
|
|
|
|
|
|
feature. |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
=head1 SEE ALSO |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
L<Rinci>, L<Data::Sah> |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::IfBuilt> |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::Rinci::Validate> |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=head1 AUTHOR |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
perlancar <perlancar@cpan.org> |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
This software is copyright (c) 2020, 2016 by perlancar@cpan.org. |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
475
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=cut |