line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
our $DATE = '2021-08-01'; # DATE |
3
|
|
|
|
|
|
|
our $VERSION = '0.852'; # VERSION |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
use 5.010001; |
6
|
17
|
|
|
17
|
|
215
|
use strict; |
|
17
|
|
|
|
|
48
|
|
7
|
17
|
|
|
17
|
|
78
|
use warnings; |
|
17
|
|
|
|
|
172
|
|
|
17
|
|
|
|
|
212
|
|
8
|
17
|
|
|
15
|
|
1383
|
use experimental 'smartmatch'; |
|
15
|
|
|
|
|
159
|
|
|
15
|
|
|
|
|
372
|
|
9
|
15
|
|
|
15
|
|
5199
|
use Log::ger; |
|
15
|
|
|
|
|
36586
|
|
|
15
|
|
|
|
|
68
|
|
10
|
15
|
|
|
15
|
|
19466
|
|
|
15
|
|
|
|
|
713
|
|
|
15
|
|
|
|
|
58
|
|
11
|
|
|
|
|
|
|
use Data::Dmp qw(dmp); |
12
|
15
|
|
|
15
|
|
8094
|
use Function::Fallback::CoreOrPP qw(clone); |
|
15
|
|
|
|
|
21874
|
|
|
15
|
|
|
|
|
807
|
|
13
|
15
|
|
|
15
|
|
481
|
use Perinci::Sub::Normalize qw(normalize_function_metadata); |
|
15
|
|
|
|
|
96
|
|
|
15
|
|
|
|
|
478
|
|
14
|
15
|
|
|
15
|
|
5869
|
use Perinci::Sub::Util qw(err); |
|
15
|
|
|
|
|
12837
|
|
|
15
|
|
|
|
|
742
|
|
15
|
15
|
|
|
15
|
|
6004
|
|
|
15
|
|
|
|
|
26031
|
|
|
15
|
|
|
|
|
741
|
|
16
|
|
|
|
|
|
|
use Exporter qw(import); |
17
|
15
|
|
|
15
|
|
94
|
our @EXPORT_OK = qw(wrap_sub); |
|
15
|
|
|
|
|
106
|
|
|
15
|
|
|
|
|
77487
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our $Log_Wrapper_Code = $ENV{LOG_PERINCI_WRAPPER_CODE} // 0; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our %SPEC; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
$SPEC{':package'} = { |
24
|
|
|
|
|
|
|
v => 1.1, |
25
|
|
|
|
|
|
|
summary => 'A multi-purpose subroutine wrapping framework', |
26
|
|
|
|
|
|
|
}; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# "protocol version" (v). whenever there's a significant change in the basic |
29
|
|
|
|
|
|
|
# structure of the wrapper, which potentially cause some/a lot of property |
30
|
|
|
|
|
|
|
# handlers to stop working, we increase this. property handler must always state |
31
|
|
|
|
|
|
|
# which version it follows in its meta. if unspecified, it's assumed to be 1. |
32
|
|
|
|
|
|
|
our $protocol_version = 2; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
my ($class) = @_; |
35
|
|
|
|
|
|
|
bless {}, $class; |
36
|
113
|
|
|
113
|
0
|
229
|
} |
37
|
113
|
|
|
|
|
1745
|
|
38
|
|
|
|
|
|
|
my ($self, $mod) = @_; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
if ($self->{_args}{core}) { |
41
|
183
|
|
|
183
|
|
472
|
if ($mod =~ /\A(experimental|Scalar::Numeric::Util|Scalar::Util::Numeric::PP)\z/) { |
42
|
|
|
|
|
|
|
die "BUG: Requested non-core module '$mod' while wrap arg core=1"; |
43
|
183
|
50
|
|
|
|
751
|
} elsif ($mod =~ /\A(warnings|List::Util)\z/) { |
44
|
1
|
0
|
|
|
|
7
|
# core modules |
|
|
0
|
|
|
|
|
|
45
|
1
|
|
|
|
|
9
|
} else { |
46
|
|
|
|
|
|
|
die "BUG: Haven't noted whether module '$mod' is core/non-core"; |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
} |
49
|
1
|
|
|
|
|
4
|
|
50
|
|
|
|
|
|
|
if ($self->{_args}{pp}) { |
51
|
|
|
|
|
|
|
if ($mod =~ /\A(List::Util|Scalar::Numeric::Util)\z/) { |
52
|
|
|
|
|
|
|
die "BUG: Requested XS module '$mod' while wrap arg pp=1"; |
53
|
183
|
50
|
|
|
|
441
|
} elsif ($mod =~ /\A(experimental|warnings|Scalar::Util::Numeric::PP)\z/) { |
54
|
1
|
0
|
|
|
|
2
|
# pp modules |
|
|
0
|
|
|
|
|
|
55
|
1
|
|
|
|
|
301
|
} else { |
56
|
|
|
|
|
|
|
die "BUG: Haven't noted whether module '$mod' is pure-perl/XS"; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
} |
59
|
1
|
|
|
|
|
6
|
|
60
|
|
|
|
|
|
|
if ($self->{_args}{core_or_pp}) { |
61
|
|
|
|
|
|
|
if ($mod =~ /\A(Scalar::Numeric::Util)\z/) { |
62
|
|
|
|
|
|
|
die "BUG: Requested non-core XS module '$mod' while wrap arg core_or_pp=1"; |
63
|
183
|
50
|
|
|
|
398
|
} elsif ($mod =~ /\A(experimental|warnings|List::Util|Scalar::Util::Numeric::PP)\z/) { |
64
|
1
|
0
|
|
|
|
3
|
# core or pp modules |
|
|
0
|
|
|
|
|
|
65
|
1
|
|
|
|
|
66
|
} else { |
66
|
|
|
|
|
|
|
die "BUG: Haven't noted whether module '$mod' is non-core xs or not"; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
} |
69
|
1
|
|
|
|
|
3
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
my ($self, $mod) = @_; |
72
|
|
|
|
|
|
|
unless ($mod ~~ $self->{_modules}) { |
73
|
|
|
|
|
|
|
local $self->{_cur_section}; |
74
|
|
|
|
|
|
|
$self->select_section('before_sub_require_modules'); |
75
|
231
|
|
|
231
|
|
696
|
if ($mod =~ /\A(use|no) (\S+)/) { |
76
|
231
|
100
|
|
|
|
695
|
$self->_check_module($2); |
77
|
183
|
|
|
|
|
335
|
$self->push_lines("$mod;"); |
78
|
183
|
|
|
|
|
403
|
} elsif ($mod =~ /\A\w+(::\w+)*\z/) { |
79
|
183
|
100
|
|
|
|
1065
|
$self->_check_module($mod); |
|
|
50
|
|
|
|
|
|
80
|
125
|
|
|
|
|
365
|
$self->push_lines("require $mod;"); |
81
|
125
|
|
|
|
|
691
|
} else { |
82
|
|
|
|
|
|
|
die "BUG: Invalid module name/statement: $mod"; |
83
|
59
|
|
|
|
|
150
|
} |
84
|
59
|
|
|
|
|
224
|
push @{ $self->{_modules} }, $mod; |
85
|
|
|
|
|
|
|
} |
86
|
1
|
|
|
|
|
8
|
} |
87
|
|
|
|
|
|
|
|
88
|
183
|
|
|
|
|
375
|
my ($self, $var, $value) = @_; |
|
183
|
|
|
|
|
484
|
|
89
|
|
|
|
|
|
|
unless (exists $self->{_vars}{$var}) { |
90
|
|
|
|
|
|
|
local $self->{_cur_section}; |
91
|
|
|
|
|
|
|
$self->select_section('declare_vars'); |
92
|
|
|
|
|
|
|
$self->push_lines("my \$$var = ".dmp($value).";"); |
93
|
101
|
|
|
101
|
|
756
|
$self->{_vars}{$var} = $value; |
94
|
101
|
50
|
|
|
|
295
|
} |
95
|
101
|
|
|
|
|
177
|
} |
96
|
101
|
|
|
|
|
257
|
|
97
|
101
|
|
|
|
|
432
|
|
98
|
101
|
|
|
|
|
307
|
# order=>N regulates the order of code. embed=>1 means the code is for embed |
99
|
|
|
|
|
|
|
# mode only and should not be included in dynamic wrapper code. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
state $val = { |
102
|
|
|
|
|
|
|
before_sub_require_modules => {order=>1}, |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# reserved by wrapper for setting Perl package and declaring 'sub {' |
105
|
|
|
|
|
|
|
OPEN_SUB => {order=>4}, |
106
|
|
|
|
|
|
|
|
107
|
2455
|
|
|
2455
|
|
3673
|
# reserved to say 'my %args = @_;' or 'my @args = @_;' etc |
108
|
|
|
|
|
|
|
ACCEPT_ARGS => {order=>5}, |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# reserved to get args values if converted from array/arrayref |
111
|
|
|
|
|
|
|
ACCEPT_ARGS2 => {order=>6}, |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
declare_vars => {order=>7}, |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# for handlers to put stuffs right before eval. for example, 'timeout' |
116
|
|
|
|
|
|
|
# uses this to set ALRM signal handler. |
117
|
|
|
|
|
|
|
before_eval => {order=>10}, |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# reserved by wrapper for generating 'eval {' |
120
|
|
|
|
|
|
|
OPEN_EVAL => {order=>20}, |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
# used e.g. to load modules used by validation |
123
|
|
|
|
|
|
|
before_call_before_arg_validation => {order=>31}, |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
before_call_arg_validation => {order=>32}, |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# used e.g. by dependency checking |
128
|
|
|
|
|
|
|
before_call_after_arg_validation => {order=>33}, |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# feed arguments to sub |
131
|
|
|
|
|
|
|
before_call_feed_args => {order=>48}, |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# for handlers that *must* do stuffs right before call |
134
|
|
|
|
|
|
|
before_call_right_before_call => {order=>49}, |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# reserved by the wrapper for calling the sub |
137
|
|
|
|
|
|
|
CALL => {order=>50}, |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# for handlers that *must* do stuffs right after call |
140
|
|
|
|
|
|
|
after_call_right_after_call => {order=>51}, |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
# reserved by the wrapper for adding/stripping result envelope, this |
143
|
|
|
|
|
|
|
# happens before result validation |
144
|
|
|
|
|
|
|
AFTER_CALL_ADD_OR_STRIP_RESULT_ENVELOPE => {order=>52}, |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# used e.g. to load modules used by validation |
147
|
|
|
|
|
|
|
after_call_before_res_validation => {order=>61}, |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
after_call_res_validation => {order=>62}, |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
after_call_after_res_validation => {order=>63}, |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# reserved by wrapper to put eval end '}' and capturing result in |
154
|
|
|
|
|
|
|
# $_w_res and $@ in $eval_err |
155
|
|
|
|
|
|
|
CLOSE_EVAL => {order=>70}, |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# for handlers to put checks against $eval_err |
158
|
|
|
|
|
|
|
after_eval => {order=>80}, |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# reserved for returning final result '$_w_res' |
161
|
|
|
|
|
|
|
BEFORE_CLOSE_SUB => {order=>99}, |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# reserved for sub closing '}' line |
164
|
|
|
|
|
|
|
CLOSE_SUB => {order=>100}, |
165
|
|
|
|
|
|
|
}; |
166
|
|
|
|
|
|
|
$val; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
my ($self, $section) = @_; |
170
|
|
|
|
|
|
|
!$self->{_codes}{$section}; |
171
|
|
|
|
|
|
|
} |
172
|
2455
|
|
|
|
|
3995
|
|
173
|
|
|
|
|
|
|
my ($self) = @_; |
174
|
|
|
|
|
|
|
!($self->section_empty('before_eval') && |
175
|
|
|
|
|
|
|
$self->section_empty('after_eval')); |
176
|
4821
|
|
|
4821
|
0
|
6187
|
} |
177
|
4821
|
|
|
|
|
10185
|
|
178
|
|
|
|
|
|
|
# whether we need to store call result to a variable ($_w_res) |
179
|
|
|
|
|
|
|
my ($self) = @_; |
180
|
|
|
|
|
|
|
return 1 if $self->{_args}{validate_result}; |
181
|
111
|
|
|
111
|
|
182
|
return 1 if $self->_needs_eval; |
182
|
111
|
|
33
|
|
|
209
|
my $ks = $self->_known_sections; |
183
|
|
|
|
|
|
|
for (grep {/^after_call/} keys %$ks) { |
184
|
|
|
|
|
|
|
return 1 unless $self->section_empty($_); |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
0; |
187
|
|
|
|
|
|
|
} |
188
|
105
|
|
|
105
|
|
182
|
|
189
|
105
|
100
|
|
|
|
388
|
my ($self, $section) = @_; |
190
|
7
|
50
|
|
|
|
13
|
my $ks = $self->_known_sections; |
191
|
7
|
|
|
|
|
360
|
$ks->{$section} or die "BUG: Unknown code section '$section'"; |
192
|
6
|
|
|
|
|
23
|
} |
|
132
|
|
|
|
|
194
|
|
193
|
24
|
50
|
|
|
|
42
|
|
194
|
|
|
|
|
|
|
my ($self, $c_status, $c_msg) = @_; |
195
|
6
|
|
|
|
|
14
|
if ($self->{_meta}{result_naked}) { |
196
|
|
|
|
|
|
|
$self->push_lines( |
197
|
|
|
|
|
|
|
"warn 'ERROR ' . ($c_status) . ': '. ($c_msg);", |
198
|
|
|
|
|
|
|
'return undef;', |
199
|
1338
|
|
|
1339
|
|
1729
|
); |
200
|
1338
|
|
|
|
|
2271
|
} else { |
201
|
1338
|
50
|
|
|
|
2945
|
$self->push_lines("return [$c_status, $c_msg];"); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
366
|
|
|
367
|
|
611
|
my ($self, $c_status, $c_msg, $c_cond) = @_; |
206
|
366
|
100
|
|
|
|
698
|
$self->push_lines("if ($c_cond) {"); |
207
|
8
|
|
|
|
|
29
|
$self->indent; |
208
|
|
|
|
|
|
|
$self->_err($c_status, $c_msg); |
209
|
|
|
|
|
|
|
$self->unindent; |
210
|
|
|
|
|
|
|
$self->push_lines('}'); |
211
|
|
|
|
|
|
|
} |
212
|
358
|
|
|
|
|
1009
|
|
213
|
|
|
|
|
|
|
my ($self, $section) = @_; |
214
|
|
|
|
|
|
|
$self->_check_known_section($section); |
215
|
|
|
|
|
|
|
$self->{_cur_section} = $section; |
216
|
|
|
|
|
|
|
$self; |
217
|
270
|
|
|
271
|
|
5887
|
} |
218
|
270
|
|
|
|
|
762
|
|
219
|
270
|
|
|
|
|
567
|
my ($self) = @_; |
220
|
270
|
|
|
|
|
594
|
my $section = $self->{_cur_section}; |
221
|
270
|
|
|
|
|
632
|
$self->{_codes}{$section} //= undef; |
222
|
270
|
|
|
|
|
398
|
$self->{_levels}{$section}++; |
223
|
|
|
|
|
|
|
$self; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
1338
|
|
|
1339
|
0
|
2415
|
my ($self) = @_; |
227
|
1338
|
|
|
|
|
2482
|
my $section = $self->{_cur_section}; |
228
|
1338
|
|
|
|
|
1806
|
$self->{_codes}{$section} //= undef; |
229
|
1338
|
|
|
|
|
1611
|
$self->{_levels}{$section}--; |
230
|
|
|
|
|
|
|
$self; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
646
|
|
|
647
|
0
|
880
|
my ($self) = @_; |
234
|
646
|
|
|
|
|
867
|
my $section = $self->{_cur_section}; |
235
|
646
|
|
50
|
|
|
1230
|
$self->{_levels}{$section} // 0; |
236
|
646
|
|
|
|
|
861
|
} |
237
|
646
|
|
|
|
|
816
|
|
238
|
|
|
|
|
|
|
# line can be code or comment. code should not contain string literals that |
239
|
|
|
|
|
|
|
# cross lines (i.e. contain literal newlines) because push_lines() might add |
240
|
|
|
|
|
|
|
# comment at the end of each line. |
241
|
640
|
|
|
641
|
0
|
891
|
|
242
|
640
|
|
|
|
|
842
|
my ($self, @lines) = @_; |
243
|
640
|
|
100
|
|
|
1366
|
my $section = $self->{_cur_section}; |
244
|
640
|
|
|
|
|
840
|
|
245
|
640
|
|
|
|
|
823
|
unless (exists $self->{_codes}{$section}) { |
246
|
|
|
|
|
|
|
unshift @lines, "# * section: $section"; |
247
|
|
|
|
|
|
|
# don't give blank line for the top-most section (order=>0) |
248
|
|
|
|
|
|
|
unshift @lines, "" if $self->_known_sections->{$section}{order}; |
249
|
86
|
|
|
86
|
0
|
141
|
$self->{_codes}{$section} = []; |
250
|
86
|
|
|
|
|
138
|
$self->{_levels}{$section} = 0; |
251
|
86
|
|
50
|
|
|
337
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
@lines = map {[$self->{_levels}{$section}, $_]} @lines; |
254
|
|
|
|
|
|
|
if ($self->{_args}{debug}) { |
255
|
|
|
|
|
|
|
for my $l (@lines) { |
256
|
|
|
|
|
|
|
$l->[2] = |
257
|
|
|
|
|
|
|
$self->{_cur_handler} ? |
258
|
|
|
|
|
|
|
"$self->{_cur_handler} prio=".$self->{_cur_handler_meta}{prio} |
259
|
2606
|
|
|
2606
|
0
|
6694
|
: ""; |
260
|
2606
|
|
|
|
|
3276
|
} |
261
|
|
|
|
|
|
|
} |
262
|
2606
|
100
|
|
|
|
4557
|
push @{$self->{_codes}{$section}}, @lines; |
263
|
798
|
|
|
|
|
1573
|
$self; |
264
|
|
|
|
|
|
|
} |
265
|
798
|
50
|
|
|
|
1188
|
|
266
|
798
|
|
|
|
|
1593
|
my ($self, $crit, $prev_section_level) = @_; |
267
|
798
|
|
|
|
|
1192
|
my @lines; |
268
|
|
|
|
|
|
|
my $ks = $self->_known_sections; |
269
|
|
|
|
|
|
|
$prev_section_level //= 0; |
270
|
2606
|
|
|
|
|
3469
|
my $i = 0; |
|
4736
|
|
|
|
|
10069
|
|
271
|
2606
|
50
|
|
|
|
4652
|
for my $s (sort {$ks->{$a}{order} <=> $ks->{$b}{order}} |
272
|
0
|
|
|
|
|
0
|
keys %$ks) { |
273
|
|
|
|
|
|
|
next if $self->section_empty($s); |
274
|
|
|
|
|
|
|
next unless $crit->(section => $s); |
275
|
|
|
|
|
|
|
$i++; |
276
|
0
|
0
|
|
|
|
0
|
for my $l (@{ $self->{_codes}{$s} }) { |
277
|
|
|
|
|
|
|
$l->[0] += $prev_section_level; |
278
|
|
|
|
|
|
|
die "BUG: Negative indent level in line $i (section $s): '$l->[1]'" |
279
|
2606
|
|
|
|
|
2793
|
if $l->[0] < 0; |
|
2606
|
|
|
|
|
4681
|
|
280
|
2606
|
|
|
|
|
5068
|
my $s = ($self->{_args}{indent} x $l->[0]) . $l->[1]; |
281
|
|
|
|
|
|
|
if (defined $l->[2]) { |
282
|
|
|
|
|
|
|
my $num_ws = 80 - length($s); |
283
|
|
|
|
|
|
|
$num_ws = 1 if $num_ws < 1; |
284
|
208
|
|
|
208
|
|
402
|
$s .= (" " x $num_ws) . "## $l->[2]"; |
285
|
208
|
|
|
|
|
250
|
} |
286
|
208
|
|
|
|
|
313
|
push @lines, $s; |
287
|
208
|
|
100
|
|
|
591
|
} |
288
|
208
|
|
|
|
|
269
|
$prev_section_level += $self->{_levels}{$s}; |
289
|
208
|
|
|
|
|
938
|
} |
|
15048
|
|
|
|
|
18735
|
|
290
|
|
|
|
|
|
|
[join("\n", @lines), $prev_section_level]; |
291
|
4576
|
100
|
|
|
|
6429
|
} |
292
|
1772
|
100
|
|
|
|
2735
|
|
293
|
678
|
|
|
|
|
869
|
my ($self) = @_; |
294
|
678
|
|
|
|
|
783
|
my $ks = $self->_known_sections; |
|
678
|
|
|
|
|
1118
|
|
295
|
4015
|
|
|
|
|
4546
|
$self->_join_codes( |
296
|
4015
|
50
|
|
|
|
5622
|
sub { |
297
|
|
|
|
|
|
|
my %args = @_; |
298
|
4015
|
|
|
|
|
7266
|
my $section = $args{section}; |
299
|
4015
|
50
|
|
|
|
5983
|
!$ks->{$section}{embed}; |
300
|
0
|
|
|
|
|
0
|
})->[0]; |
301
|
0
|
0
|
|
|
|
0
|
} |
302
|
0
|
|
|
|
|
0
|
|
303
|
|
|
|
|
|
|
# for embedded, we need to produce three sections which will be inserted in |
304
|
4015
|
|
|
|
|
5862
|
# different places, demonstrated below: |
305
|
|
|
|
|
|
|
# |
306
|
678
|
|
|
|
|
1035
|
# $SPEC{foo} = { |
307
|
|
|
|
|
|
|
# ... |
308
|
208
|
|
|
|
|
1489
|
# }; |
309
|
|
|
|
|
|
|
# sub foo { |
310
|
|
|
|
|
|
|
# my %args = @_; |
311
|
|
|
|
|
|
|
# # do stuffs |
312
|
52
|
|
|
52
|
|
93
|
# } |
313
|
52
|
|
|
|
|
111
|
# |
314
|
|
|
|
|
|
|
# becomes: |
315
|
|
|
|
|
|
|
# |
316
|
443
|
|
|
443
|
|
740
|
# #PRESUB1: require modules (inserted before sub declaration) |
317
|
443
|
|
|
|
|
563
|
# require Data::Dumper; |
318
|
443
|
|
|
|
|
1004
|
# require Scalar::Util; |
319
|
52
|
|
|
|
|
276
|
# |
320
|
|
|
|
|
|
|
# $SPEC{foo} = { |
321
|
|
|
|
|
|
|
# ... |
322
|
|
|
|
|
|
|
# }; |
323
|
|
|
|
|
|
|
# #PRESUB2: modify metadata piece-by-piece (inserted before sub declaration & |
324
|
|
|
|
|
|
|
# #after $SPEC{foo}). we're avoiding dumping the new modified metadata because |
325
|
|
|
|
|
|
|
# #metadata might contain coderefs which is sometimes problematic when dumping |
326
|
|
|
|
|
|
|
# { |
327
|
|
|
|
|
|
|
# my $meta = $SPEC{foo}; |
328
|
|
|
|
|
|
|
# $meta->{v} = 1.1; |
329
|
|
|
|
|
|
|
# $meta->{result_naked} = 0; |
330
|
|
|
|
|
|
|
# } |
331
|
|
|
|
|
|
|
# |
332
|
|
|
|
|
|
|
# sub foo { |
333
|
|
|
|
|
|
|
# my %args = @_; |
334
|
|
|
|
|
|
|
# #PREAMBLE: before call sections (inserted after accept args), e.g. |
335
|
|
|
|
|
|
|
# #validate arguments, convert argument type, setup eval block |
336
|
|
|
|
|
|
|
# #... |
337
|
|
|
|
|
|
|
# |
338
|
|
|
|
|
|
|
# # do stuffs |
339
|
|
|
|
|
|
|
# |
340
|
|
|
|
|
|
|
# #POSTAMBLE: after call sections (inserted before sub end), e.g. |
341
|
|
|
|
|
|
|
# #validate result, close eval block and do retry/etc. |
342
|
|
|
|
|
|
|
# #... |
343
|
|
|
|
|
|
|
# } |
344
|
|
|
|
|
|
|
my ($self) = @_; |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
my $res = {}; |
347
|
|
|
|
|
|
|
my $ks = $self->_known_sections; |
348
|
|
|
|
|
|
|
my $j; |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
$j = $self->_join_codes( |
351
|
|
|
|
|
|
|
sub { |
352
|
|
|
|
|
|
|
my %args = @_; |
353
|
|
|
|
|
|
|
my $section = $args{section}; |
354
|
|
|
|
|
|
|
$section =~ /\A(before_sub_require_modules)\z/; |
355
|
|
|
|
|
|
|
}); |
356
|
|
|
|
|
|
|
$res->{presub1} = $j->[0]; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# no longer needed/produce, code to modify metadata |
359
|
|
|
|
|
|
|
$res->{presub2} = ''; |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
$j = $self->_join_codes( |
362
|
|
|
|
|
|
|
sub { |
363
|
|
|
|
|
|
|
my %args = @_; |
364
|
52
|
|
|
52
|
|
97
|
my $section = $args{section}; |
365
|
|
|
|
|
|
|
my $order = $ks->{$section}{order}; |
366
|
52
|
|
|
|
|
87
|
return 1 if $order > $ks->{ACCEPT_ARGS}{order} && |
367
|
52
|
|
|
|
|
99
|
$order < $ks->{CALL}{order}; |
368
|
52
|
|
|
|
|
73
|
0; |
369
|
|
|
|
|
|
|
}, 1); |
370
|
|
|
|
|
|
|
$res->{preamble} = $j->[0]; |
371
|
|
|
|
|
|
|
|
372
|
443
|
|
|
443
|
|
752
|
$j = $self->_join_codes( |
373
|
443
|
|
|
|
|
546
|
sub { |
374
|
443
|
|
|
|
|
1110
|
my %args = @_; |
375
|
52
|
|
|
|
|
257
|
my $section = $args{section}; |
376
|
52
|
|
|
|
|
257
|
my $order = $ks->{$section}{order}; |
377
|
|
|
|
|
|
|
return 1 if $order > $ks->{CALL}{order} && |
378
|
|
|
|
|
|
|
$order < $ks->{CLOSE_SUB}{order}; |
379
|
52
|
|
|
|
|
106
|
0; |
380
|
|
|
|
|
|
|
}, $j->[1]); |
381
|
|
|
|
|
|
|
$res->{postamble} = $j->[0]; |
382
|
|
|
|
|
|
|
|
383
|
443
|
|
|
443
|
|
736
|
$res; |
384
|
443
|
|
|
|
|
612
|
} |
385
|
443
|
|
|
|
|
1272
|
|
386
|
|
|
|
|
|
|
|
387
|
443
|
100
|
100
|
|
|
1225
|
# after args |
388
|
349
|
|
|
|
|
740
|
my ($self, %args) = @_; |
389
|
52
|
|
|
|
|
211
|
|
390
|
52
|
|
|
|
|
238
|
my $meta = $self->{_meta}; |
391
|
|
|
|
|
|
|
my $v = $meta->{features} // {}; |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
$self->select_section('before_call_before_arg_validation'); |
394
|
443
|
|
|
443
|
|
743
|
|
395
|
443
|
|
|
|
|
545
|
if ($v->{tx} && $v->{tx}{req}) { |
396
|
443
|
|
|
|
|
574
|
$self->push_lines('', '# check required transaction'); |
397
|
|
|
|
|
|
|
$self->_errif(412, '"Must run with transaction (pass -tx_manager)"', |
398
|
443
|
100
|
100
|
|
|
1119
|
'!$args{-tx_manager}'); |
399
|
337
|
|
|
|
|
681
|
} |
400
|
52
|
|
|
|
|
242
|
} |
401
|
52
|
|
|
|
|
240
|
|
402
|
|
|
|
|
|
|
# run before args |
403
|
52
|
|
|
|
|
139
|
my ($self, %args) = @_; |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
my $value = $args{value}; |
406
|
108
|
|
|
108
|
0
|
183
|
my $new = $args{new}; |
407
|
0
|
|
|
0
|
0
|
0
|
my $meta = $self->{_meta}; |
408
|
0
|
|
|
0
|
0
|
0
|
my $args_p = $meta->{args} // {}; |
409
|
0
|
|
|
0
|
0
|
0
|
my $opt_va = $self->{_args}{validate_args}; |
410
|
0
|
|
|
0
|
0
|
0
|
|
411
|
0
|
|
|
0
|
0
|
0
|
# We support conversion of arguments between hash/hashref/array/arrayref. To |
412
|
0
|
|
|
0
|
0
|
0
|
# make it simple, currently the algorithm is as follow: we first form the |
413
|
0
|
|
|
0
|
0
|
0
|
# %args hash. If args_as is already 'hash', we just do 'my %args = @_'. |
414
|
0
|
|
|
0
|
0
|
0
|
# Otherwise, we convert from the other forms. |
415
|
0
|
|
|
0
|
0
|
0
|
# |
416
|
0
|
|
|
0
|
0
|
0
|
# We then validate each argument in %args (code generated in 'args' |
417
|
0
|
|
|
0
|
0
|
0
|
# handler). |
418
|
|
|
|
|
|
|
# |
419
|
|
|
|
|
|
|
# Finally, unless original args_as is 'hash' we convert to the final form |
420
|
4
|
|
|
4
|
0
|
8
|
# that the wrapped sub expects. |
421
|
|
|
|
|
|
|
# |
422
|
4
|
|
|
4
|
0
|
13
|
# This setup is optimal when both the sub and generated wrapper accept |
423
|
|
|
|
|
|
|
# 'hash', but suboptimal for other cases (especially positional ones, as |
424
|
4
|
|
|
|
|
5
|
# they have to undergo a round-trip to hash even when both accept 'array'). |
425
|
4
|
|
50
|
|
|
9
|
# This will be rectified in the future. |
426
|
|
|
|
|
|
|
|
427
|
4
|
|
|
|
|
8
|
my $v = $new // $value; |
428
|
|
|
|
|
|
|
|
429
|
4
|
50
|
33
|
|
|
21
|
$self->select_section('ACCEPT_ARGS'); |
430
|
4
|
|
|
|
|
10
|
if ($v eq 'hash') { |
431
|
4
|
|
|
|
|
10
|
$self->push_lines(q{die 'BUG: Odd number of hash elements supplied' if @_ % 2;}) |
432
|
|
|
|
|
|
|
if $opt_va; |
433
|
|
|
|
|
|
|
$self->push_lines('my %args = @_;'); |
434
|
|
|
|
|
|
|
} elsif ($v eq 'hashref') { |
435
|
|
|
|
|
|
|
$self->push_lines(q{die 'BUG: $_[0] needs to be hashref' if @_ && ref($_[0]) ne "HASH";}) |
436
|
|
|
|
|
|
|
if $opt_va; |
437
|
108
|
|
|
108
|
0
|
333
|
$self->push_lines('my %args = %{$_[0] // {}};'); |
438
|
|
|
|
|
|
|
} elsif ($v =~ /\Aarray(ref)?\z/) { |
439
|
108
|
|
|
108
|
0
|
393
|
my $ref = $1 ? 1:0; |
440
|
|
|
|
|
|
|
if ($ref) { |
441
|
108
|
|
|
|
|
201
|
$self->push_lines(q{die 'BUG: $_[0] needs to be arrayref' if @_ && ref($_[0]) ne "ARRAY";}) |
442
|
108
|
|
|
|
|
186
|
if $opt_va; |
443
|
108
|
|
|
|
|
163
|
} |
444
|
108
|
|
100
|
|
|
310
|
$self->push_lines('my %args;'); |
445
|
108
|
|
|
|
|
195
|
$self->select_section('ACCEPT_ARGS2'); |
446
|
|
|
|
|
|
|
for my $a (sort keys %$args_p) { |
447
|
|
|
|
|
|
|
my $as = $args_p->{$a}; |
448
|
|
|
|
|
|
|
my $line = '$args{'.dmp($a).'} = '; |
449
|
|
|
|
|
|
|
defined($as->{pos}) or die "Error in args property for arg '$a': ". |
450
|
|
|
|
|
|
|
"no pos defined"; |
451
|
|
|
|
|
|
|
my $pos = int($as->{pos} + 0); |
452
|
|
|
|
|
|
|
$pos >= 0 or die "Error in args property for arg '$a': ". |
453
|
|
|
|
|
|
|
"negative value in pos"; |
454
|
|
|
|
|
|
|
if ($as->{slurpy} // $as->{greedy}) { |
455
|
|
|
|
|
|
|
if ($ref) { |
456
|
|
|
|
|
|
|
$line .= '[splice @{$_[0]}, '.$pos.'] if @{$_[0]} > '.$pos; |
457
|
|
|
|
|
|
|
} else { |
458
|
|
|
|
|
|
|
$line .= '[splice @_, '.$pos.'] if @_ > '.$pos; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
} else { |
461
|
|
|
|
|
|
|
if ($ref) { |
462
|
|
|
|
|
|
|
$line .= '$_[0]['.$pos.'] if @{$_[0]} > '.$pos; |
463
|
108
|
|
66
|
|
|
361
|
} else { |
464
|
|
|
|
|
|
|
$line .= '$_['.$pos.'] if @_ > '.$pos; |
465
|
108
|
|
|
|
|
266
|
} |
466
|
108
|
100
|
|
|
|
255
|
} |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
467
|
100
|
100
|
|
|
|
296
|
$self->push_lines("$line;"); |
468
|
|
|
|
|
|
|
} |
469
|
100
|
|
|
|
|
189
|
} else { |
470
|
|
|
|
|
|
|
die "Unknown args_as value '$v'"; |
471
|
2
|
50
|
|
|
|
8
|
} |
472
|
|
|
|
|
|
|
|
473
|
2
|
|
|
|
|
4
|
$self->select_section('ACCEPT_ARGS'); |
474
|
|
|
|
|
|
|
if ($value eq 'hashref') { |
475
|
6
|
100
|
|
|
|
19
|
$self->push_lines('my $args;'); |
476
|
6
|
100
|
|
|
|
11
|
} elsif ($value eq 'array') { |
477
|
2
|
50
|
|
|
|
6
|
$self->push_lines('my @args;'); |
478
|
|
|
|
|
|
|
} elsif ($value eq 'arrayref') { |
479
|
|
|
|
|
|
|
$self->push_lines('my $args;'); |
480
|
6
|
|
|
|
|
13
|
} |
481
|
6
|
|
|
|
|
14
|
|
482
|
6
|
|
|
|
|
19
|
my $tok; |
483
|
12
|
|
|
|
|
18
|
$self->select_section('before_call_feed_args'); |
484
|
12
|
|
|
|
|
23
|
$v = $value; |
485
|
12
|
50
|
|
|
|
363
|
if ($v eq 'hash') { |
486
|
|
|
|
|
|
|
$tok = '%args'; |
487
|
12
|
|
|
|
|
21
|
} elsif ($v eq 'hashref') { |
488
|
12
|
50
|
|
|
|
23
|
$tok = '$args'; |
489
|
|
|
|
|
|
|
$self->push_lines($tok.' = \%args;'); # XXX should we set each arg instead? |
490
|
12
|
50
|
33
|
|
|
40
|
} elsif ($v =~ /\Aarray(ref)?\z/) { |
491
|
0
|
0
|
|
|
|
0
|
my $ref = $1 ? 1:0; |
492
|
0
|
|
|
|
|
0
|
$tok = ($ref ? '$':'@') . 'args'; |
493
|
|
|
|
|
|
|
for my $a (sort {$args_p->{$a}{pos} <=> $args_p->{$b}{pos}} |
494
|
0
|
|
|
|
|
0
|
keys %$args_p) { |
495
|
|
|
|
|
|
|
my $as = $args_p->{$a}; |
496
|
|
|
|
|
|
|
my $t = '$args{'.dmp($a).'}'; |
497
|
12
|
100
|
|
|
|
18
|
my $line; |
498
|
4
|
|
|
|
|
9
|
defined($as->{pos}) or die "Error in args property for arg '$a': ". |
499
|
|
|
|
|
|
|
"no pos defined"; |
500
|
8
|
|
|
|
|
18
|
my $pos = int($as->{pos} + 0); |
501
|
|
|
|
|
|
|
$pos >= 0 or die "Error in args property for arg '$a': ". |
502
|
|
|
|
|
|
|
"negative value in pos"; |
503
|
12
|
|
|
|
|
27
|
if ($as->{slurpy} // $as->{greedy}) { |
504
|
|
|
|
|
|
|
$line = 'splice @args, '.$pos.', scalar(@args)-1, @{'.$t.'}'; |
505
|
|
|
|
|
|
|
} else { |
506
|
0
|
|
|
|
|
0
|
$line = '$args'.($ref ? '->':'').'['.$pos."] = $t if exists $t"; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
$self->push_lines("$line;"); |
509
|
108
|
|
|
|
|
272
|
} |
510
|
108
|
100
|
|
|
|
419
|
} else { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
511
|
2
|
|
|
|
|
4
|
die "Unknown args_as value '$v'"; |
512
|
|
|
|
|
|
|
} |
513
|
4
|
|
|
|
|
7
|
$self->{_args_token} = $tok; |
514
|
|
|
|
|
|
|
} |
515
|
2
|
|
|
|
|
5
|
|
516
|
|
|
|
|
|
|
require Data::Sah; |
517
|
|
|
|
|
|
|
|
518
|
108
|
|
|
|
|
158
|
my $self = shift; |
519
|
108
|
|
|
|
|
221
|
state $sah = Data::Sah->new; |
520
|
108
|
|
|
|
|
159
|
$sah; |
521
|
108
|
100
|
|
|
|
246
|
} |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
522
|
100
|
|
|
|
|
166
|
|
523
|
|
|
|
|
|
|
my $self = shift; |
524
|
2
|
|
|
|
|
2
|
state $plc = do { |
525
|
2
|
|
|
|
|
5
|
my $plc = $self->_sah->get_compiler("perl"); |
526
|
|
|
|
|
|
|
$plc->comment_style('shell2'); # to make all comment uses ## instead of # |
527
|
6
|
100
|
|
|
|
16
|
$plc; |
528
|
6
|
100
|
|
|
|
15
|
}; |
529
|
6
|
|
|
|
|
18
|
} |
|
6
|
|
|
|
|
19
|
|
530
|
|
|
|
|
|
|
|
531
|
12
|
|
|
|
|
16
|
my ($self, %args) = @_; |
532
|
12
|
|
|
|
|
24
|
|
533
|
12
|
|
|
|
|
306
|
my $v = $args{v} // $self->{_meta}{args}; |
534
|
12
|
50
|
|
|
|
22
|
return unless $v; |
535
|
|
|
|
|
|
|
|
536
|
12
|
|
|
|
|
23
|
my $opt_sin = $self->{_args}{_schema_is_normalized}; |
537
|
12
|
50
|
|
|
|
17
|
my $opt_va = $self->{_args}{validate_args}; |
538
|
|
|
|
|
|
|
|
539
|
12
|
50
|
33
|
|
|
46
|
my $prefix = $args{prefix} // ''; |
540
|
0
|
|
|
|
|
0
|
my $argsterm = $args{argsterm} // '%args'; |
541
|
|
|
|
|
|
|
|
542
|
12
|
100
|
|
|
|
35
|
if ($opt_va) { |
543
|
|
|
|
|
|
|
$self->_add_module("use experimental 'smartmatch'"); |
544
|
12
|
|
|
|
|
25
|
$self->select_section('before_call_arg_validation'); |
545
|
|
|
|
|
|
|
$self->push_lines('', '# check args') if $prefix eq ''; |
546
|
|
|
|
|
|
|
$self->push_lines("for (sort keys $argsterm) {"); |
547
|
0
|
|
|
|
|
0
|
$self->indent; |
548
|
|
|
|
|
|
|
$self->_errif(400, q["Invalid argument name (please use letters/numbers/underscores only)'].$prefix.q[$_'"], |
549
|
108
|
|
|
|
|
474
|
'!/\A(-?)\w+(\.\w+)*\z/o'); |
550
|
|
|
|
|
|
|
$self->_errif(400, q["Unknown argument '].$prefix.q[$_'"], |
551
|
|
|
|
|
|
|
'!($1 || $_ ~~ '.dmp([sort keys %$v]).')'); |
552
|
|
|
|
|
|
|
$self->unindent; |
553
|
11
|
|
|
11
|
|
2918
|
$self->push_lines('}'); |
554
|
|
|
|
|
|
|
} |
555
|
11
|
|
|
|
|
18408
|
|
556
|
11
|
|
|
|
|
47
|
for my $argname (sort keys %$v) { |
557
|
11
|
|
|
|
|
322
|
my $argspec = $v->{$argname}; |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
my $argterm = $argsterm; |
560
|
|
|
|
|
|
|
if ($argterm =~ /^%\{\s*(.+)\s*\}/) { |
561
|
86
|
|
|
86
|
|
129
|
$argterm = $1 . "->{'$argname'}"; |
562
|
86
|
|
|
|
|
393
|
} elsif ($argterm =~ s/^%/\$/) { |
563
|
7
|
|
|
|
|
31
|
$argterm .= "{'$argname'}"; |
564
|
7
|
|
|
|
|
150261
|
} else { |
565
|
7
|
|
|
|
|
87
|
$argterm .= "->{'$argname'}"; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
my $has_default_prop = exists($argspec->{default}); |
569
|
|
|
|
|
|
|
my $sch = $argspec->{schema}; |
570
|
78
|
|
|
78
|
|
236
|
|
571
|
|
|
|
|
|
|
if ($sch) { |
572
|
78
|
|
66
|
|
|
312
|
my $has_sch_default = ref($sch) eq 'ARRAY' && |
573
|
78
|
50
|
|
|
|
159
|
exists($sch->[1]{default}) ? 1:0; |
574
|
|
|
|
|
|
|
if ($opt_va) { |
575
|
78
|
|
|
|
|
146
|
|
576
|
78
|
|
|
|
|
128
|
$self->push_lines("if (exists($argterm)) {"); |
577
|
|
|
|
|
|
|
$self->indent; |
578
|
78
|
|
100
|
|
|
284
|
|
579
|
78
|
|
100
|
|
|
212
|
if ($argspec->{stream}) { |
580
|
|
|
|
|
|
|
die "Error in schema for argument '$argname': must be str/buf/array if stream=1" |
581
|
78
|
100
|
|
|
|
151
|
unless $sch->[0] =~ /\A(str|buf|array)\z/; # XXX allow 'any' if all of its 'of' values are str/buf/array |
582
|
76
|
|
|
|
|
210
|
die "Error in schema for argument '$argname': must specify 'of' array clause if stream=1" |
583
|
76
|
|
|
|
|
199
|
if $sch->[0] eq 'array' && !$sch->[1]{of}; |
584
|
76
|
100
|
|
|
|
252
|
|
585
|
76
|
|
|
|
|
234
|
$self->_errif( |
586
|
76
|
|
|
|
|
190
|
400, |
587
|
76
|
|
|
|
|
260
|
qq["Argument '$prefix$argname' (stream) fails validation: must be coderef"], |
588
|
|
|
|
|
|
|
"!(ref($argterm) eq 'CODE')", |
589
|
76
|
|
|
|
|
485
|
); |
590
|
|
|
|
|
|
|
$self->push_lines('{ ## introduce scope because we want to declare a generic variable $i'); |
591
|
76
|
|
|
|
|
226
|
$self->indent; |
592
|
76
|
|
|
|
|
178
|
$self->push_lines( |
593
|
|
|
|
|
|
|
'my $i = -1;', |
594
|
|
|
|
|
|
|
"my \$origsub = $argterm;", |
595
|
78
|
|
|
|
|
257
|
'# arg coderef wrapper for validation', |
596
|
108
|
|
|
|
|
189
|
"$argterm = sub {", |
597
|
|
|
|
|
|
|
); |
598
|
108
|
|
|
|
|
164
|
$self->indent; |
599
|
108
|
100
|
|
|
|
541
|
$self->push_lines( |
|
|
50
|
|
|
|
|
|
600
|
8
|
|
|
|
|
29
|
'$i++;', |
601
|
|
|
|
|
|
|
"my \$rec = \$origsub->();", |
602
|
100
|
|
|
|
|
214
|
'return undef unless defined $rec;', |
603
|
|
|
|
|
|
|
); |
604
|
0
|
|
|
|
|
0
|
} |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
my $dn = $argname; $dn =~ s/\W+/_/g; |
607
|
108
|
|
|
|
|
200
|
my $cd = $self->_plc->compile( |
608
|
108
|
|
|
|
|
154
|
data_name => $dn, |
609
|
|
|
|
|
|
|
data_term => $argspec->{stream} ? '$rec' : $argterm, |
610
|
108
|
100
|
|
|
|
245
|
schema => $argspec->{stream} && $sch->[0] eq 'array' ? $sch->[1]{of} : $sch, |
|
|
100
|
|
|
|
|
|
611
|
|
|
|
|
|
|
schema_is_normalized => $opt_sin, |
612
|
78
|
100
|
100
|
|
|
345
|
return_type => 'str', |
613
|
78
|
100
|
|
|
|
156
|
indent_level => $self->get_indent_level + 1, |
614
|
|
|
|
|
|
|
core => $self->{_args}{core}, |
615
|
74
|
|
|
|
|
226
|
core_or_pp => $self->{_args}{core_or_pp}, |
616
|
74
|
|
|
|
|
173
|
pp => $self->{_args}{pp}, |
617
|
|
|
|
|
|
|
%{ $self->{_args}{_extra_sah_compiler_args} // {}}, |
618
|
74
|
100
|
|
|
|
152
|
); |
619
|
2
|
50
|
|
|
|
14
|
die "Incompatible Data::Sah version (cd v=$cd->{v}, expected 2)" unless $cd->{v} == 2; |
620
|
|
|
|
|
|
|
for my $mod_rec (@{ $cd->{modules} }) { |
621
|
|
|
|
|
|
|
next unless $mod_rec->{phase} eq 'runtime'; |
622
|
2
|
50
|
33
|
|
|
10
|
$self->_add_module($mod_rec->{use_statement} // $mod_rec->{name}); |
623
|
|
|
|
|
|
|
} |
624
|
2
|
|
|
|
|
12
|
$self->_add_var($_, $cd->{vars}{$_}) |
625
|
|
|
|
|
|
|
for sort keys %{ $cd->{vars} }; |
626
|
|
|
|
|
|
|
$cd->{result} =~ s/\A\s+//; |
627
|
|
|
|
|
|
|
$self->push_lines( |
628
|
|
|
|
|
|
|
"my \$err_$dn;", |
629
|
2
|
|
|
|
|
5
|
"$cd->{result};", |
630
|
2
|
|
|
|
|
6
|
); |
631
|
2
|
|
|
|
|
9
|
if ($argspec->{stream}) { |
632
|
|
|
|
|
|
|
$self->push_lines( |
633
|
|
|
|
|
|
|
'if ('."\$err_$dn".') { die "Record #$i of streaming argument '."'$prefix$argname'".' ($rec) fails validation: '."\$err_$dn".'" }', |
634
|
|
|
|
|
|
|
'$rec;', |
635
|
|
|
|
|
|
|
); |
636
|
|
|
|
|
|
|
} else { |
637
|
2
|
|
|
|
|
6
|
$self->_errif( |
638
|
2
|
|
|
|
|
6
|
400, qq["Argument '$prefix$argname' fails validation: \$err_$dn"], |
639
|
|
|
|
|
|
|
"\$err_$dn"); |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
if ($argspec->{meta}) { |
642
|
|
|
|
|
|
|
$self->push_lines("# check subargs of $prefix$argname"); |
643
|
|
|
|
|
|
|
$self->_handle_args( |
644
|
|
|
|
|
|
|
%args, |
645
|
74
|
|
|
|
|
110
|
v => $argspec->{meta}{args}, |
|
74
|
|
|
|
|
155
|
|
646
|
|
|
|
|
|
|
prefix => ($prefix ? "$prefix/" : "") . "$argname/", |
647
|
|
|
|
|
|
|
argsterm => '%{'.$argterm.'}', |
648
|
|
|
|
|
|
|
); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
if ($argspec->{element_meta}) { |
651
|
|
|
|
|
|
|
$self->push_lines("# check element subargs of $prefix$argname"); |
652
|
|
|
|
|
|
|
my $indexterm = "$prefix$argname"; |
653
|
|
|
|
|
|
|
$indexterm =~ s/\W+/_/g; |
654
|
|
|
|
|
|
|
$indexterm = '$i_' . $indexterm; |
655
|
|
|
|
|
|
|
$self->push_lines('for my '.$indexterm.' (0..$#{ '.$argterm.' }) {'); |
656
|
74
|
100
|
66
|
|
|
185
|
$self->indent; |
|
74
|
100
|
50
|
|
|
446
|
|
657
|
|
|
|
|
|
|
$self->_errif( |
658
|
72
|
50
|
|
|
|
413747
|
400, qq("Argument '$prefix$argname\[).qq($indexterm]' fails validation: must be hash"), |
659
|
72
|
|
|
|
|
122
|
"ref($argterm\->[$indexterm]) ne 'HASH'"); |
|
72
|
|
|
|
|
187
|
|
660
|
208
|
100
|
|
|
|
436
|
$self->_handle_args( |
661
|
136
|
|
66
|
|
|
484
|
%args, |
662
|
|
|
|
|
|
|
v => $argspec->{element_meta}{args}, |
663
|
|
|
|
|
|
|
prefix => ($prefix ? "$prefix/" : "") . "$argname\[$indexterm]/", |
664
|
72
|
|
|
|
|
93
|
argsterm => '%{'.$argterm.'->['.$indexterm.']}', |
|
72
|
|
|
|
|
226
|
|
665
|
72
|
|
|
|
|
307
|
); |
666
|
72
|
|
|
|
|
294
|
$self->unindent; |
667
|
|
|
|
|
|
|
$self->push_lines('}'); |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
$self->unindent; |
670
|
72
|
100
|
|
|
|
173
|
if ($argspec->{stream}) { |
671
|
2
|
|
|
|
|
17
|
$self->push_lines('}; ## arg coderef wrapper'); |
672
|
|
|
|
|
|
|
$self->unindent; |
673
|
|
|
|
|
|
|
$self->push_lines('} ## close scope'); |
674
|
|
|
|
|
|
|
$self->unindent; |
675
|
|
|
|
|
|
|
} |
676
|
70
|
|
|
|
|
245
|
if ($has_default_prop) { |
677
|
|
|
|
|
|
|
$self->push_lines( |
678
|
|
|
|
|
|
|
'} else {', |
679
|
|
|
|
|
|
|
" $argterm //= ".dmp($argspec->{default}).";"); |
680
|
72
|
100
|
|
|
|
182
|
} elsif ($has_sch_default) { |
681
|
2
|
|
|
|
|
8
|
$self->push_lines( |
682
|
|
|
|
|
|
|
'} else {', |
683
|
|
|
|
|
|
|
" $argterm //= ".dmp($sch->[1]{default}).";"); |
684
|
|
|
|
|
|
|
} |
685
|
2
|
50
|
|
|
|
25
|
$self->push_lines("} ## if exists arg $prefix$argname"); |
686
|
|
|
|
|
|
|
} # if opt_va |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
} elsif ($has_default_prop) { |
689
|
72
|
100
|
|
|
|
203
|
# doesn't have schema but have 'default' property, we still need to |
690
|
2
|
|
|
|
|
8
|
# set default here |
691
|
2
|
|
|
|
|
7
|
$self->push_lines("$argterm = ".dmp($argspec->{default}). |
692
|
2
|
|
|
|
|
6
|
" if !exists($argterm);"); |
693
|
2
|
|
|
|
|
4
|
} |
694
|
2
|
|
|
|
|
9
|
if ($argspec->{req} && $opt_va) { |
695
|
2
|
|
|
|
|
8
|
$self->_errif( |
696
|
2
|
|
|
|
|
12
|
400, qq["Missing required argument: $argname"], |
697
|
|
|
|
|
|
|
"!exists($argterm)"); |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
} # for arg |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
2
|
50
|
|
|
|
18
|
my ($self, %args) = @_; |
703
|
|
|
|
|
|
|
$self->_handle_args(%args); |
704
|
|
|
|
|
|
|
} |
705
|
2
|
|
|
|
|
12
|
|
706
|
2
|
|
|
|
|
5
|
# after args |
707
|
|
|
|
|
|
|
my ($self, %args) = @_; |
708
|
72
|
|
|
|
|
166
|
|
709
|
72
|
100
|
|
|
|
172
|
my $v = $args{v} // $self->{_meta}{args_rels}; |
710
|
2
|
|
|
|
|
6
|
return unless $v; |
711
|
2
|
|
|
|
|
5
|
|
712
|
2
|
|
|
|
|
5
|
my $argsterm = $args{argsterm} // '%args'; |
713
|
2
|
|
|
|
|
7
|
|
714
|
|
|
|
|
|
|
$self->select_section('before_call_arg_validation'); |
715
|
72
|
100
|
|
|
|
196
|
$self->push_lines('', '# check args_rels'); |
|
|
100
|
|
|
|
|
|
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
my $dn = "args_rels"; |
718
|
8
|
|
|
|
|
28
|
my $hc = $self->_sah->get_compiler("human"); |
719
|
|
|
|
|
|
|
my $cd_h = $hc->init_cd; |
720
|
|
|
|
|
|
|
$cd_h->{args}{lang} //= $cd_h->{default_lang}; |
721
|
|
|
|
|
|
|
|
722
|
8
|
|
|
|
|
34
|
my $cd = $self->_plc->compile( |
723
|
|
|
|
|
|
|
data_name => $dn, |
724
|
72
|
|
|
|
|
188
|
data_term => "\\$argsterm", |
725
|
|
|
|
|
|
|
schema => ['hash', $v], |
726
|
|
|
|
|
|
|
return_type => 'str', |
727
|
|
|
|
|
|
|
indent_level => $self->get_indent_level + 1, |
728
|
|
|
|
|
|
|
human_hash_values => { |
729
|
|
|
|
|
|
|
field => $hc->_xlt($cd_h, "argument"), |
730
|
2
|
|
|
|
|
8
|
fields => $hc->_xlt($cd_h, "arguments"), |
731
|
|
|
|
|
|
|
}, |
732
|
|
|
|
|
|
|
core => $self->{_args}{core}, |
733
|
106
|
100
|
100
|
|
|
603
|
core_or_pp => $self->{_args}{core_or_pp}, |
734
|
18
|
|
|
|
|
90
|
pp => $self->{_args}{pp}, |
735
|
|
|
|
|
|
|
); |
736
|
|
|
|
|
|
|
die "Incompatible Data::Sah version (cd v=$cd->{v}, expected 2)" unless $cd->{v} == 2; |
737
|
|
|
|
|
|
|
for my $mod_rec (@{ $cd->{modules} }) { |
738
|
|
|
|
|
|
|
next unless $mod_rec->{phase} eq 'runtime'; |
739
|
|
|
|
|
|
|
$self->_add_module($mod_rec->{use_statement} // $mod_rec->{name}); |
740
|
|
|
|
|
|
|
} |
741
|
74
|
|
|
74
|
0
|
209
|
$self->_add_var($_, $cd->{vars}{$_}) for sort keys %{ $cd->{vars} }; |
742
|
|
|
|
|
|
|
$cd->{result} =~ s/\A\s+//; |
743
|
74
|
|
|
74
|
0
|
248
|
$self->push_lines( |
744
|
74
|
|
|
|
|
251
|
"my \$err_$dn;", |
745
|
|
|
|
|
|
|
"$cd->{result};", |
746
|
|
|
|
|
|
|
); |
747
|
|
|
|
|
|
|
$self->_errif( |
748
|
4
|
|
|
4
|
0
|
15
|
400, qq["\$err_$dn"], |
749
|
|
|
|
|
|
|
"\$err_$dn"); |
750
|
4
|
|
|
4
|
0
|
17
|
} |
751
|
|
|
|
|
|
|
|
752
|
4
|
|
33
|
|
|
18
|
require Data::Sah; |
753
|
4
|
50
|
|
|
|
16
|
|
754
|
|
|
|
|
|
|
my ($self, %args) = @_; |
755
|
4
|
|
50
|
|
|
13
|
|
756
|
|
|
|
|
|
|
my $meta = $self->{_meta}; |
757
|
4
|
|
|
|
|
9
|
my $v = $meta->{result}; |
758
|
4
|
|
|
|
|
9
|
return unless $v; |
759
|
|
|
|
|
|
|
|
760
|
4
|
|
|
|
|
5
|
my $opt_sin = $self->{_args}{_schema_is_normalized}; |
761
|
4
|
|
|
|
|
10
|
my $opt_vr = $self->{_args}{validate_result}; |
762
|
4
|
|
|
|
|
18975
|
|
763
|
4
|
|
33
|
|
|
172
|
my %schemas_by_status; # key = status, value = schema |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
# collect and check handlers |
766
|
|
|
|
|
|
|
my %handler_args; |
767
|
|
|
|
|
|
|
my %handler_metas; |
768
|
|
|
|
|
|
|
for my $k0 (keys %$v) { |
769
|
|
|
|
|
|
|
my $k = $k0; |
770
|
|
|
|
|
|
|
$k =~ s/\..+//; |
771
|
|
|
|
|
|
|
next if $k =~ /\A_/; |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
# check builtin result spec key |
774
|
|
|
|
|
|
|
next if $k =~ /\A( |
775
|
|
|
|
|
|
|
summary|description|tags|default_lang| |
776
|
|
|
|
|
|
|
schema|statuses|stream| |
777
|
|
|
|
|
|
|
x |
778
|
4
|
|
|
|
|
11
|
)\z/x; |
779
|
2
|
50
|
|
|
|
19476
|
# try a property module first |
780
|
2
|
|
|
|
|
5
|
require "Perinci/Sub/Property/result/$k.pm"; |
|
2
|
|
|
|
|
6
|
|
781
|
6
|
100
|
|
|
|
14
|
my $meth = "handlemeta_result__$k"; |
782
|
4
|
|
66
|
|
|
15
|
unless ($self->can($meth)) { |
783
|
|
|
|
|
|
|
die "No handler for property result/$k0 ($meth)"; |
784
|
2
|
|
|
|
|
5
|
} |
|
2
|
|
|
|
|
9
|
|
785
|
2
|
|
|
|
|
9
|
my $hm = $self->$meth; |
786
|
2
|
|
|
|
|
10
|
$hm->{v} //= 1; |
787
|
|
|
|
|
|
|
next unless defined $hm->{prio}; |
788
|
|
|
|
|
|
|
die "Please update property handler result/$k which is still at v=$hm->{v} ". |
789
|
|
|
|
|
|
|
"(needs v=$protocol_version)" |
790
|
2
|
|
|
|
|
8
|
unless $hm->{v} == $protocol_version; |
791
|
|
|
|
|
|
|
my $ha = { |
792
|
|
|
|
|
|
|
prio=>$hm->{prio}, value=>$v->{$k0}, property=>$k0, |
793
|
|
|
|
|
|
|
meth=>"handle_result__$k", |
794
|
|
|
|
|
|
|
}; |
795
|
14
|
|
|
14
|
0
|
29
|
$handler_args{$k} = $ha; |
796
|
|
|
|
|
|
|
$handler_metas{$k} = $hm; |
797
|
14
|
|
|
14
|
0
|
480
|
} |
798
|
|
|
|
|
|
|
|
799
|
14
|
|
|
|
|
3036
|
# call all the handlers in order |
800
|
|
|
|
|
|
|
for my $k (sort {$handler_args{$a}{prio} <=> $handler_args{$b}{prio}} |
801
|
14
|
|
|
|
|
24
|
keys %handler_args) { |
802
|
14
|
|
|
|
|
20
|
my $ha = $handler_args{$k}; |
803
|
14
|
50
|
|
|
|
27
|
my $meth = $ha->{meth}; |
804
|
|
|
|
|
|
|
local $self->{_cur_handler} = $meth; |
805
|
14
|
|
|
|
|
22
|
local $self->{_cur_handler_meta} = $handler_metas{$k}; |
806
|
14
|
|
|
|
|
20
|
local $self->{_cur_handler_args} = $ha; |
807
|
|
|
|
|
|
|
$self->$meth(args=>\%args, meta=>$meta, %$ha); |
808
|
14
|
|
|
|
|
28
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
# validate result |
811
|
|
|
|
|
|
|
my @modules; |
812
|
14
|
|
|
|
|
0
|
if ($v->{schema} && $opt_vr) { |
813
|
14
|
|
|
|
|
29
|
$schemas_by_status{200} = $v->{schema}; |
814
|
18
|
|
|
|
|
23
|
} |
815
|
18
|
|
|
|
|
34
|
if ($v->{statuses} && $opt_vr) { |
816
|
18
|
100
|
|
|
|
39
|
for my $s (keys %{$v->{statuses}}) { |
817
|
|
|
|
|
|
|
my $sv = $v->{statuses}{$s}; |
818
|
|
|
|
|
|
|
if ($sv->{schema}) { |
819
|
16
|
50
|
|
|
|
66
|
$schemas_by_status{$s} = $sv->{schema}; |
820
|
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
my $sub_name = $self->{_args}{sub_name}; |
825
|
0
|
|
|
|
|
0
|
|
826
|
0
|
|
|
|
|
0
|
if ($opt_vr) { |
827
|
0
|
0
|
|
|
|
0
|
$self->select_section('after_call_res_validation'); |
828
|
0
|
|
|
|
|
0
|
$self->push_lines( |
829
|
|
|
|
|
|
|
'my $_w_res2 = $_w_res->[2];', |
830
|
0
|
|
|
|
|
0
|
'my $_w_res_is_stream = $_w_res->[3]{stream} // ' . ($v->{stream} ? 1:0) . ';', |
831
|
0
|
|
0
|
|
|
0
|
); |
832
|
0
|
0
|
|
|
|
0
|
$self->_errif( |
833
|
|
|
|
|
|
|
500, |
834
|
|
|
|
|
|
|
q["Stream result must be coderef"], |
835
|
0
|
0
|
|
|
|
0
|
'$_w_res_is_stream && ref($_w_res2) ne "CODE"', |
836
|
|
|
|
|
|
|
); |
837
|
0
|
|
|
|
|
0
|
for my $s (sort keys %schemas_by_status) { |
838
|
|
|
|
|
|
|
my $sch = $schemas_by_status{$s}; |
839
|
|
|
|
|
|
|
if ($v->{stream}) { |
840
|
0
|
|
|
|
|
0
|
die "Error in result schema: must be str/buf/array if stream=1" |
841
|
0
|
|
|
|
|
0
|
unless $sch->[0] =~ /\A(str|buf|array)\z/; # XXX allow 'any' if all of its 'of' values are str/buf/array |
842
|
|
|
|
|
|
|
die "Error in result schema: must specify 'of' array clause if stream=1" |
843
|
|
|
|
|
|
|
if $sch->[0] eq 'array' && !$sch->[1]{of}; |
844
|
|
|
|
|
|
|
} |
845
|
14
|
|
|
|
|
33
|
$self->push_lines("if (\$_w_res->[0] == $s) {"); |
|
0
|
|
|
|
|
0
|
|
846
|
|
|
|
|
|
|
$self->indent; |
847
|
0
|
|
|
|
|
0
|
$self->push_lines('if (!$_w_res_is_stream) {'); |
848
|
0
|
|
|
|
|
0
|
$self->indent; |
849
|
0
|
|
|
|
|
0
|
|
850
|
0
|
|
|
|
|
0
|
# validation for when not a stream |
851
|
0
|
|
|
|
|
0
|
my $cd = $self->_plc->compile( |
852
|
0
|
|
|
|
|
0
|
data_name => '_w_res2', |
853
|
|
|
|
|
|
|
# err_res can clash on arg named 'res' |
854
|
|
|
|
|
|
|
err_term => '$_w_err2_res', |
855
|
|
|
|
|
|
|
schema => $sch, |
856
|
14
|
|
|
|
|
17
|
schema_is_normalized => $opt_sin, |
857
|
14
|
100
|
100
|
|
|
41
|
return_type => 'str', |
858
|
4
|
|
|
|
|
9
|
indent_level => $self->get_indent_level + 1, |
859
|
|
|
|
|
|
|
core => $self->{_args}{core}, |
860
|
14
|
50
|
33
|
|
|
28
|
core_or_pp => $self->{_args}{core_or_pp}, |
861
|
0
|
|
|
|
|
0
|
pp => $self->{_args}{pp}, |
|
0
|
|
|
|
|
0
|
|
862
|
0
|
|
|
|
|
0
|
%{ $self->{_args}{_extra_sah_compiler_args} // {}}, |
863
|
0
|
0
|
|
|
|
0
|
); |
864
|
0
|
|
|
|
|
0
|
die "Incompatible Data::Sah version (cd v=$cd->{v}, expected 2)" unless $cd->{v} == 2; |
865
|
|
|
|
|
|
|
for my $mod_rec (@{ $cd->{modules} }) { |
866
|
|
|
|
|
|
|
next unless $mod_rec->{phase} eq 'runtime'; |
867
|
|
|
|
|
|
|
$self->_add_module($mod_rec->{use_statement} // $mod_rec->{name}); |
868
|
|
|
|
|
|
|
} |
869
|
14
|
|
|
|
|
18
|
$self->_add_var($_, $cd->{vars}{$_}) |
870
|
|
|
|
|
|
|
for sort keys %{ $cd->{vars} }; |
871
|
14
|
100
|
|
|
|
31
|
$self->push_lines("my \$_w_err2_res;"); |
872
|
12
|
|
|
|
|
26
|
$cd->{result} =~ s/\A\s+//; |
873
|
|
|
|
|
|
|
$self->push_lines("$cd->{result};"); |
874
|
|
|
|
|
|
|
$self->_errif( |
875
|
12
|
100
|
|
|
|
46
|
500, |
876
|
|
|
|
|
|
|
qq["BUG: Result from sub $sub_name (\$_w_res2) fails validation: ]. |
877
|
12
|
|
|
|
|
35
|
qq[\$_w_err2_res"], |
878
|
|
|
|
|
|
|
"\$_w_err2_res"); |
879
|
|
|
|
|
|
|
$self->unindent; |
880
|
|
|
|
|
|
|
$self->push_lines("} else {"); # stream |
881
|
|
|
|
|
|
|
$self->indent; |
882
|
12
|
|
|
|
|
54
|
$self->push_lines( |
883
|
4
|
|
|
|
|
11
|
'my $i = -1;', |
884
|
4
|
100
|
|
|
|
14
|
'# wrap result coderef for validation', |
885
|
2
|
50
|
|
|
|
11
|
'$_w_res->[2] = sub {', |
886
|
|
|
|
|
|
|
); |
887
|
|
|
|
|
|
|
$self->indent; |
888
|
2
|
50
|
33
|
|
|
9
|
$self->push_lines( |
889
|
|
|
|
|
|
|
'$i++;', |
890
|
4
|
|
|
|
|
16
|
'my $rec = $_w_res2->();', |
891
|
4
|
|
|
|
|
13
|
'return undef unless defined $rec;', |
892
|
4
|
|
|
|
|
9
|
); |
893
|
4
|
|
|
|
|
15
|
# generate schema code once again, this time for when stream |
894
|
|
|
|
|
|
|
$cd = $self->_plc->compile( |
895
|
|
|
|
|
|
|
data_name => 'rec', |
896
|
|
|
|
|
|
|
# err_res can clash on arg named 'res' |
897
|
|
|
|
|
|
|
err_term => '$rec_err', |
898
|
|
|
|
|
|
|
schema => $sch->[0] eq 'array' ? $sch->[1]{of} : $sch, |
899
|
|
|
|
|
|
|
schema_is_normalized => $opt_sin, |
900
|
|
|
|
|
|
|
return_type => 'str', |
901
|
|
|
|
|
|
|
indent_level => $self->get_indent_level + 1, |
902
|
|
|
|
|
|
|
core => $self->{_args}{core}, |
903
|
|
|
|
|
|
|
core_or_pp => $self->{_args}{core_or_pp}, |
904
|
|
|
|
|
|
|
pp => $self->{_args}{pp}, |
905
|
|
|
|
|
|
|
%{ $self->{_args}{_extra_sah_compiler_args} // {}}, |
906
|
|
|
|
|
|
|
); |
907
|
4
|
|
50
|
|
|
12
|
die "Incompatible Data::Sah version (cd v=$cd->{v}, expected 2)" unless $cd->{v} == 2; |
|
4
|
|
|
|
|
26
|
|
908
|
|
|
|
|
|
|
# XXX no need to require modules required by validator? |
909
|
4
|
50
|
|
|
|
72609
|
$self->push_lines('my $rec_err;'); |
910
|
4
|
|
|
|
|
9
|
$cd->{result} =~ s/\A\s+//; |
|
4
|
|
|
|
|
11
|
|
911
|
16
|
100
|
|
|
|
34
|
$self->push_lines("$cd->{result};"); |
912
|
10
|
|
66
|
|
|
40
|
$self->push_lines('if ($rec_err) { die "BUG: Result stream record #$i ($rec) fails validation: $rec_err" }'); |
913
|
|
|
|
|
|
|
$self->push_lines('$rec;'); |
914
|
|
|
|
|
|
|
$self->unindent; |
915
|
4
|
|
|
|
|
7
|
$self->push_lines('}; ## result coderef wrapper'); |
|
4
|
|
|
|
|
17
|
|
916
|
4
|
|
|
|
|
12
|
$self->unindent; |
917
|
4
|
|
|
|
|
18
|
$self->push_lines("} ## if stream"); |
918
|
4
|
|
|
|
|
28
|
$self->unindent; |
919
|
4
|
|
|
|
|
18
|
$self->push_lines("} ## if status=$s"); |
920
|
|
|
|
|
|
|
} # for schemas_by_status |
921
|
|
|
|
|
|
|
} |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
|
924
|
4
|
|
|
|
|
10
|
my ($self, %args) = @_; |
925
|
4
|
|
|
|
|
10
|
|
926
|
4
|
|
|
|
|
10
|
my $old = $args{value}; |
927
|
4
|
|
|
|
|
10
|
my $v = $args{new} // $old; |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
return if !!$v == !!$old; |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
$self->select_section('AFTER_CALL_ADD_OR_STRIP_RESULT_ENVELOPE'); |
932
|
4
|
|
|
|
|
7
|
if ($v) { |
933
|
4
|
|
|
|
|
11
|
$self->push_lines( |
934
|
|
|
|
|
|
|
'', '# strip result envelope', |
935
|
|
|
|
|
|
|
'$_w_res = $_w_res->[2];', |
936
|
|
|
|
|
|
|
); |
937
|
|
|
|
|
|
|
} else { |
938
|
|
|
|
|
|
|
$self->push_lines( |
939
|
|
|
|
|
|
|
'', '# add result envelope', |
940
|
|
|
|
|
|
|
'$_w_res = [200, "OK", $_w_res];', |
941
|
|
|
|
|
|
|
); |
942
|
|
|
|
|
|
|
} |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
my ($self, %args) = @_; |
946
|
|
|
|
|
|
|
my $value = $args{value}; |
947
|
|
|
|
|
|
|
my $meta = $self->{_meta}; |
948
|
|
|
|
|
|
|
my $v = $self->{_args}{meta_name}; |
949
|
|
|
|
|
|
|
$self->select_section('before_call_after_arg_validation'); |
950
|
4
|
100
|
50
|
|
|
17
|
$self->push_lines('', '# check dependencies'); |
|
4
|
|
|
|
|
24
|
|
951
|
|
|
|
|
|
|
$self->_add_module("Perinci::Sub::DepChecker"); |
952
|
4
|
50
|
|
|
|
8869
|
#$self->push_lines('use Data::Dump; dd '.$v.';'); |
953
|
|
|
|
|
|
|
$self->push_lines('my $_w_deps_res = Perinci::Sub::DepChecker::check_deps('. |
954
|
4
|
|
|
|
|
12
|
$v.'->{deps});'); |
955
|
4
|
|
|
|
|
22
|
$self->_errif(412, '"Deps failed: $_w_deps_res"', '$_w_deps_res'); |
956
|
4
|
|
|
|
|
16
|
|
957
|
4
|
|
|
|
|
11
|
# we handle some deps our own |
958
|
4
|
|
|
|
|
10
|
if ($value->{tmp_dir}) { |
959
|
4
|
|
|
|
|
11
|
$self->_errif(412, '"Dep failed: please specify -tmp_dir"', |
960
|
4
|
|
|
|
|
9
|
'!$args{-tmp_dir}'); |
961
|
4
|
|
|
|
|
12
|
} |
962
|
4
|
|
|
|
|
10
|
if ($value->{trash_dir}) { |
963
|
4
|
|
|
|
|
9
|
$self->_errif(412, '"Dep failed: please specify -trash_dir"', |
964
|
4
|
|
|
|
|
12
|
'!$args{-trash_dir}'); |
965
|
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
if ($value->{undo_trash_dir}) { |
967
|
|
|
|
|
|
|
$self->_errif(412, '"Dep failed: please specify -undo_trash_dir"', |
968
|
|
|
|
|
|
|
'!($args{-undo_trash_dir} || $args{-tx_manager} || '. |
969
|
6
|
|
|
6
|
0
|
21
|
'$args{-undo_action} && $args{-undo_action}=~/\A(?:undo|redo)\z/)'); |
970
|
|
|
|
|
|
|
} |
971
|
6
|
|
|
6
|
0
|
23
|
} |
972
|
|
|
|
|
|
|
|
973
|
6
|
|
|
|
|
12
|
|
974
|
6
|
|
33
|
|
|
15
|
my ($self, %args) = @_; |
975
|
|
|
|
|
|
|
|
976
|
6
|
50
|
|
|
|
17
|
# to make it stand out more, all work/state data is prefixed with |
977
|
|
|
|
|
|
|
# underscore. |
978
|
6
|
|
|
|
|
13
|
|
979
|
6
|
100
|
|
|
|
13
|
$self->{_cur_section} = undef; |
980
|
2
|
|
|
|
|
5
|
$self->{_cur_handler} = undef; |
981
|
|
|
|
|
|
|
$self->{_cur_handler_args} = undef; |
982
|
|
|
|
|
|
|
$self->{_cur_handler_meta} = undef; |
983
|
|
|
|
|
|
|
$self->{_levels} = {}; |
984
|
|
|
|
|
|
|
$self->{_codes} = {}; |
985
|
4
|
|
|
|
|
10
|
$self->{_modules} = []; # modules loaded by wrapper sub |
986
|
|
|
|
|
|
|
$self->{$_} = $args{$_} for keys %args; |
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
require Scalar::Util; |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
my ($self, %args) = @_; |
992
|
4
|
|
|
4
|
0
|
16
|
|
993
|
|
|
|
|
|
|
my $wrap_log_prop = "x.perinci.sub.wrapper.logs"; |
994
|
4
|
|
|
4
|
0
|
14
|
|
995
|
4
|
|
|
|
|
6
|
# required arguments |
996
|
4
|
|
|
|
|
10
|
my $sub = $args{sub}; |
997
|
4
|
|
|
|
|
7
|
my $sub_name = $args{sub_name}; |
998
|
4
|
|
|
|
|
9
|
$sub || $sub_name or return [400, "Please specify sub or sub_name"]; |
999
|
4
|
|
|
|
|
11
|
$args{meta} or return [400, "Please specify meta"]; |
1000
|
4
|
|
|
|
|
9
|
my $meta_name = $args{meta_name}; |
1001
|
|
|
|
|
|
|
# we clone the meta because we'll replace stuffs |
1002
|
4
|
|
|
|
|
13
|
my $meta = clone($args{meta}); |
1003
|
|
|
|
|
|
|
my $wrap_logs = $meta->{$wrap_log_prop} // []; |
1004
|
4
|
|
|
|
|
9
|
|
1005
|
|
|
|
|
|
|
# currently internal args, not exposed/documented |
1006
|
|
|
|
|
|
|
$args{_compiled_package} //= 'Perinci::Sub::Wrapped'; |
1007
|
4
|
50
|
|
|
|
7
|
my $comppkg = $args{_compiled_package}; |
1008
|
0
|
|
|
|
|
0
|
$args{_schema_is_normalized} //= |
1009
|
|
|
|
|
|
|
$wrap_logs->[-1] && $wrap_logs->[-1]{normalize_schema} ? 1 : 0; |
1010
|
|
|
|
|
|
|
$args{_embed} //= 0; |
1011
|
4
|
50
|
|
|
|
13
|
$args{_extra_sah_compiler_args} //= undef; |
1012
|
0
|
|
|
|
|
0
|
|
1013
|
|
|
|
|
|
|
# defaults for arguments |
1014
|
|
|
|
|
|
|
$args{indent} //= " " x 4; |
1015
|
4
|
50
|
|
|
|
20
|
$args{convert} //= {}; |
1016
|
0
|
|
|
|
|
0
|
$args{compile} //= 1; |
1017
|
|
|
|
|
|
|
$args{log} //= 1; |
1018
|
|
|
|
|
|
|
$args{validate_args} //= 0 |
1019
|
|
|
|
|
|
|
# function states that it can validate args, so by default we don't have |
1020
|
|
|
|
|
|
|
# to do validation for it. |
1021
|
|
|
|
|
|
|
if $meta->{features} && $meta->{features}{validate_args}; |
1022
|
110
|
|
|
110
|
0
|
172
|
$args{validate_args} //= 0 |
1023
|
0
|
|
|
0
|
0
|
0
|
# function might want to disable validate_args by default, e.g. if |
1024
|
0
|
|
|
0
|
0
|
0
|
# source code has been processed with |
1025
|
|
|
|
|
|
|
# Dist::Zilla::Plugin::Rinci::Validate |
1026
|
|
|
|
|
|
|
if $meta->{'x.perinci.sub.wrapper.disable_validate_args'}; |
1027
|
108
|
|
|
108
|
|
339
|
$args{validate_args} //= 0 |
1028
|
|
|
|
|
|
|
# by default do not validate args again if previous wrapper(s) have |
1029
|
|
|
|
|
|
|
# already done it |
1030
|
|
|
|
|
|
|
if (grep {$_->{validate_args}} @$wrap_logs); |
1031
|
|
|
|
|
|
|
$args{validate_args} //= 1; |
1032
|
108
|
|
|
|
|
423
|
$args{validate_result} //= 0 |
1033
|
108
|
|
|
|
|
214
|
# function might want to disable validate_result by default, e.g. if |
1034
|
108
|
|
|
|
|
189
|
# source code has been processed with |
1035
|
108
|
|
|
|
|
163
|
# Dist::Zilla::Plugin::Rinci::Validate |
1036
|
108
|
|
|
|
|
243
|
if $meta->{'x.perinci.sub.wrapper.disable_validate_result'}; |
1037
|
108
|
|
|
|
|
216
|
$args{validate_result} //= 0 |
1038
|
108
|
|
|
|
|
205
|
# by default do not validate result again if previous wrapper(s) have |
1039
|
108
|
|
|
|
|
495
|
# already done it |
1040
|
|
|
|
|
|
|
if (grep {$_->{validate_result}} @$wrap_logs); |
1041
|
|
|
|
|
|
|
$args{validate_result} //= 1; |
1042
|
|
|
|
|
|
|
$args{core} //= $ENV{PERINCI_WRAPPER_CORE}; |
1043
|
112
|
|
|
112
|
0
|
597
|
$args{core_or_pp} //= $ENV{PERINCI_WRAPPER_CORE_OR_PP}; |
1044
|
|
|
|
|
|
|
$args{pp} //= $ENV{PERINCI_WRAPPER_PP}; |
1045
|
112
|
|
|
|
|
337
|
|
1046
|
|
|
|
|
|
|
my $sub_ref_name; |
1047
|
112
|
|
|
|
|
194
|
# if sub_name is not provided, create a unique name for it. it is needed by |
1048
|
|
|
|
|
|
|
# the wrapper-generated code (e.g. printing error messages) |
1049
|
|
|
|
|
|
|
if (!$sub_name || $sub) { |
1050
|
112
|
|
|
|
|
179
|
my $n = $comppkg . "::sub".Scalar::Util::refaddr($sub); |
1051
|
112
|
|
|
|
|
185
|
no strict 'refs'; no warnings; ${$n} = $sub; |
1052
|
112
|
50
|
66
|
|
|
331
|
use experimental 'smartmatch'; |
1053
|
112
|
50
|
|
|
|
224
|
if (!$sub_name) { |
1054
|
112
|
|
|
|
|
172
|
$args{sub_name} = $sub_name = '$' . $n; |
1055
|
|
|
|
|
|
|
} |
1056
|
112
|
|
|
|
|
271
|
$sub_ref_name = '$' . $n; |
1057
|
112
|
|
100
|
|
|
1737
|
} |
1058
|
|
|
|
|
|
|
# if meta name is not provided, we store the meta somewhere, it is needed by |
1059
|
|
|
|
|
|
|
# the wrapper-generated code (e.g. deps clause). |
1060
|
112
|
|
50
|
|
|
483
|
if (!$meta_name) { |
1061
|
112
|
|
|
|
|
202
|
my $n = $comppkg . "::meta".Scalar::Util::refaddr($meta); |
1062
|
|
|
|
|
|
|
no strict 'refs'; no warnings; ${$n} = $meta; |
1063
|
112
|
100
|
66
|
|
|
606
|
use experimental 'smartmatch'; |
|
|
|
100
|
|
|
|
|
1064
|
112
|
|
50
|
|
|
396
|
$args{meta_name} = $meta_name = '$' . $n; |
1065
|
112
|
|
50
|
|
|
431
|
} |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
# shallow copy |
1068
|
112
|
|
50
|
|
|
489
|
my $opt_cvt = { %{ $args{convert} } }; |
1069
|
112
|
|
100
|
|
|
395
|
my $opt_sin = $args{_schema_is_normalized}; |
1070
|
112
|
|
50
|
|
|
388
|
|
1071
|
112
|
|
100
|
|
|
392
|
$meta = normalize_function_metadata($meta) |
1072
|
|
|
|
|
|
|
unless $opt_sin; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
$self->_reset_work_data(_args=>\%args, _meta=>$meta); |
1075
|
112
|
50
|
0
|
|
|
244
|
|
|
|
|
66
|
|
|
|
|
1076
|
|
|
|
|
|
|
# add properties from convert, if not yet mentioned in meta |
1077
|
|
|
|
|
|
|
for (keys %$opt_cvt) { |
1078
|
|
|
|
|
|
|
$meta->{$_} = undef unless exists $meta->{$_}; |
1079
|
|
|
|
|
|
|
} |
1080
|
112
|
100
|
50
|
|
|
278
|
|
1081
|
|
|
|
|
|
|
# mark in the metadata that we have done the wrapping, so future wrapping |
1082
|
|
|
|
|
|
|
# can avoid needless duplicated functionality (like validating args twice). |
1083
|
|
|
|
|
|
|
# note that handler can log their mark too. |
1084
|
112
|
100
|
50
|
|
|
300
|
{ |
|
2
|
|
|
|
|
11
|
|
1085
|
112
|
|
100
|
|
|
438
|
my @wrap_log = @{ $meta->{$wrap_log_prop} // [] }; |
1086
|
|
|
|
|
|
|
push @wrap_log, { |
1087
|
|
|
|
|
|
|
validate_args => $args{validate_args}, |
1088
|
|
|
|
|
|
|
validate_result => $args{validate_result}, |
1089
|
|
|
|
|
|
|
normalize_schema => !$opt_sin, |
1090
|
112
|
100
|
50
|
|
|
220
|
}; |
1091
|
|
|
|
|
|
|
if ($args{log}) { |
1092
|
|
|
|
|
|
|
$meta->{$wrap_log_prop} = \@wrap_log; |
1093
|
|
|
|
|
|
|
} |
1094
|
112
|
100
|
50
|
|
|
245
|
} |
|
2
|
|
|
|
|
10
|
|
1095
|
112
|
|
100
|
|
|
387
|
|
1096
|
112
|
|
33
|
|
|
435
|
# start iterating over properties |
1097
|
112
|
|
33
|
|
|
418
|
|
1098
|
112
|
|
33
|
|
|
525
|
$self->select_section('OPEN_SUB'); |
1099
|
|
|
|
|
|
|
$self->push_lines( |
1100
|
112
|
|
|
|
|
143
|
"package $comppkg;", 'sub {'); |
1101
|
|
|
|
|
|
|
$self->indent; |
1102
|
|
|
|
|
|
|
|
1103
|
112
|
100
|
66
|
|
|
271
|
$meta->{args_as} //= "hash"; |
1104
|
110
|
|
|
|
|
404
|
|
1105
|
15
|
|
|
14
|
|
504
|
if ($meta->{args_as} =~ /hash/) { |
|
14
|
|
|
14
|
|
99
|
|
|
14
|
|
|
|
|
473
|
|
|
14
|
|
|
|
|
369
|
|
|
14
|
|
|
|
|
33
|
|
|
14
|
|
|
|
|
551
|
|
|
110
|
|
|
|
|
182
|
|
|
110
|
|
|
|
|
393
|
|
1106
|
14
|
|
|
14
|
|
71
|
$self->select_section('before_call_after_arg_validation'); |
|
14
|
|
|
|
|
89
|
|
|
14
|
|
|
|
|
135
|
|
1107
|
110
|
50
|
|
|
|
254
|
# tell function it's being wrapped, currently disabled |
1108
|
110
|
|
|
|
|
280
|
#$self->push_lines('$args{-wrapped} = 1;'); |
1109
|
|
|
|
|
|
|
} |
1110
|
110
|
|
|
|
|
206
|
|
1111
|
|
|
|
|
|
|
my %props = map {$_=>1} keys %$meta; |
1112
|
|
|
|
|
|
|
$props{$_} = 1 for keys %$opt_cvt; |
1113
|
|
|
|
|
|
|
|
1114
|
112
|
50
|
|
|
|
221
|
# collect and check handlers |
1115
|
112
|
|
|
|
|
263
|
my %handler_args; |
1116
|
14
|
|
|
14
|
|
1407
|
my %handler_metas; |
|
14
|
|
|
14
|
|
42
|
|
|
14
|
|
|
|
|
355
|
|
|
14
|
|
|
|
|
66
|
|
|
14
|
|
|
|
|
105
|
|
|
14
|
|
|
|
|
503
|
|
|
112
|
|
|
|
|
158
|
|
|
112
|
|
|
|
|
484
|
|
1117
|
14
|
|
|
14
|
|
371
|
for my $k0 (keys %props) { |
|
14
|
|
|
|
|
42
|
|
|
14
|
|
|
|
|
54
|
|
1118
|
112
|
|
|
|
|
297
|
my $k = $k0; |
1119
|
|
|
|
|
|
|
$k =~ s/\..+//; |
1120
|
|
|
|
|
|
|
next if $k =~ /\A_/; |
1121
|
|
|
|
|
|
|
next if $handler_args{$k}; |
1122
|
112
|
|
|
|
|
154
|
#if ($k ~~ $self->{_args}{skip}) { |
|
112
|
|
|
|
|
261
|
|
1123
|
112
|
|
|
|
|
182
|
# $log->tracef("Skipped property %s (mentioned in skip)", $k); |
1124
|
|
|
|
|
|
|
# next; |
1125
|
112
|
100
|
|
|
|
493
|
#} |
1126
|
|
|
|
|
|
|
return [500, "Invalid property name $k"] unless $k =~ /\A\w+\z/; |
1127
|
|
|
|
|
|
|
my $meth = "handlemeta_$k"; |
1128
|
108
|
|
|
|
|
52825
|
unless ($self->can($meth)) { |
1129
|
|
|
|
|
|
|
# try a property module first |
1130
|
|
|
|
|
|
|
require "Perinci/Sub/Property/$k.pm"; |
1131
|
108
|
|
|
|
|
274
|
unless ($self->can($meth)) { |
1132
|
10
|
100
|
|
|
|
30
|
return [500, "No handler for property $k0 ($meth)"]; |
1133
|
|
|
|
|
|
|
} |
1134
|
|
|
|
|
|
|
} |
1135
|
|
|
|
|
|
|
my $hm = $self->$meth; |
1136
|
|
|
|
|
|
|
$hm->{v} //= 1; |
1137
|
|
|
|
|
|
|
next unless defined $hm->{prio}; |
1138
|
|
|
|
|
|
|
die "Please update property handler $k which is still at v=$hm->{v} ". |
1139
|
108
|
|
100
|
|
|
180
|
"(needs v=$protocol_version)" |
|
108
|
|
|
|
|
159
|
|
|
108
|
|
|
|
|
469
|
|
1140
|
|
|
|
|
|
|
unless $hm->{v} == $protocol_version; |
1141
|
|
|
|
|
|
|
my $ha = { |
1142
|
|
|
|
|
|
|
prio=>$hm->{prio}, value=>$meta->{$k0}, property=>$k0, |
1143
|
108
|
|
|
|
|
432
|
meth=>"handle_$k", |
1144
|
|
|
|
|
|
|
}; |
1145
|
108
|
100
|
|
|
|
246
|
if (exists $opt_cvt->{$k0}) { |
1146
|
106
|
|
|
|
|
375
|
return [501, "Property '$k0' does not support conversion"] |
1147
|
|
|
|
|
|
|
unless $hm->{convert}; |
1148
|
|
|
|
|
|
|
$ha->{new} = $opt_cvt->{$k0}; |
1149
|
|
|
|
|
|
|
$meta->{$k0} = $opt_cvt->{$k0}; |
1150
|
|
|
|
|
|
|
} |
1151
|
|
|
|
|
|
|
$handler_args{$k} = $ha; |
1152
|
108
|
|
|
|
|
344
|
$handler_metas{$k} = $hm; |
1153
|
108
|
|
|
|
|
401
|
} |
1154
|
|
|
|
|
|
|
|
1155
|
108
|
|
|
|
|
272
|
# call all the handlers in order |
1156
|
|
|
|
|
|
|
for my $k (sort {$handler_args{$a}{prio} <=> $handler_args{$b}{prio}} |
1157
|
108
|
|
100
|
|
|
423
|
keys %handler_args) { |
1158
|
|
|
|
|
|
|
my $ha = $handler_args{$k}; |
1159
|
108
|
100
|
|
|
|
426
|
my $meth = $ha->{meth}; |
1160
|
102
|
|
|
|
|
209
|
local $self->{_cur_handler} = $meth; |
1161
|
|
|
|
|
|
|
local $self->{_cur_handler_meta} = $handler_metas{$k}; |
1162
|
|
|
|
|
|
|
local $self->{_cur_handler_args} = $ha; |
1163
|
|
|
|
|
|
|
$self->$meth(args=>\%args, meta=>$meta, %$ha); |
1164
|
|
|
|
|
|
|
} |
1165
|
108
|
|
|
|
|
352
|
|
|
434
|
|
|
|
|
776
|
|
1166
|
108
|
|
|
|
|
289
|
my $needs_store_res = $self->_needs_store_res; |
1167
|
|
|
|
|
|
|
if ($needs_store_res) { |
1168
|
|
|
|
|
|
|
$self->_add_var('_w_res'); |
1169
|
108
|
|
|
|
|
202
|
} |
1170
|
|
|
|
|
|
|
|
1171
|
108
|
|
|
|
|
242
|
$self->select_section('CALL'); |
1172
|
434
|
|
|
|
|
532
|
my $sn = $sub_ref_name // $sub_name; |
1173
|
434
|
|
|
|
|
843
|
$self->push_lines( |
1174
|
434
|
100
|
|
|
|
802
|
($needs_store_res ? '$_w_res = ' : "") . |
1175
|
432
|
50
|
|
|
|
716
|
$sn. ($sn =~ /^\$/ ? "->" : ""). |
1176
|
|
|
|
|
|
|
"(".$self->{_args_token}.");"); |
1177
|
|
|
|
|
|
|
if ($args{validate_result}) { |
1178
|
|
|
|
|
|
|
$self->select_section('after_call_before_res_validation'); |
1179
|
|
|
|
|
|
|
unless ($meta->{result_naked}) { |
1180
|
432
|
50
|
|
|
|
1176
|
$self->push_lines( |
1181
|
432
|
|
|
|
|
752
|
'', |
1182
|
432
|
50
|
|
|
|
1303
|
'# check that sub produces enveloped result', |
1183
|
|
|
|
|
|
|
'unless (ref($_w_res) eq "ARRAY" && $_w_res->[0]) {', |
1184
|
0
|
|
|
|
|
0
|
); |
1185
|
0
|
0
|
|
|
|
0
|
$self->indent; |
1186
|
0
|
|
|
|
|
0
|
if (log_is_trace) { |
1187
|
|
|
|
|
|
|
$self->_add_module('Data::Dumper'); |
1188
|
|
|
|
|
|
|
$self->push_lines( |
1189
|
432
|
|
|
|
|
1036
|
'local $Data::Dumper::Purity = 1;', |
1190
|
432
|
|
100
|
|
|
1157
|
'local $Data::Dumper::Terse = 1;', |
1191
|
432
|
100
|
|
|
|
929
|
'local $Data::Dumper::Indent = 0;', |
1192
|
|
|
|
|
|
|
); |
1193
|
|
|
|
|
|
|
$self->_err(500, |
1194
|
214
|
50
|
|
|
|
455
|
qq['BUG: Sub $sub_name does not produce envelope: '.]. |
1195
|
|
|
|
|
|
|
qq[Data::Dumper::Dumper(\$_w_res)]); |
1196
|
214
|
|
|
|
|
758
|
} else { |
1197
|
|
|
|
|
|
|
$self->_err(500, |
1198
|
|
|
|
|
|
|
qq['BUG: Sub $sub_name does not produce envelope']); |
1199
|
214
|
100
|
|
|
|
441
|
} |
1200
|
|
|
|
|
|
|
$self->unindent; |
1201
|
10
|
50
|
|
|
|
29
|
$self->push_lines('}'); |
1202
|
10
|
|
|
|
|
21
|
} |
1203
|
10
|
|
|
|
|
14
|
} |
1204
|
|
|
|
|
|
|
|
1205
|
214
|
|
|
|
|
288
|
my $use_eval = $self->_needs_eval; |
1206
|
214
|
|
|
|
|
445
|
if ($use_eval) { |
1207
|
|
|
|
|
|
|
$self->select_section('CLOSE_EVAL'); |
1208
|
|
|
|
|
|
|
$self->push_lines('return $_w_res;'); |
1209
|
|
|
|
|
|
|
$self->unindent; |
1210
|
108
|
|
|
|
|
487
|
$self->_add_var('_w_eval_err'); |
|
118
|
|
|
|
|
385
|
|
1211
|
|
|
|
|
|
|
$self->push_lines( |
1212
|
214
|
|
|
|
|
329
|
'};', |
1213
|
214
|
|
|
|
|
309
|
'$_w_eval_err = $@;'); |
1214
|
214
|
|
|
|
|
386
|
|
1215
|
214
|
|
|
|
|
366
|
# _needs_eval will automatically be enabled here, due after_eval being |
1216
|
214
|
|
|
|
|
320
|
# filled |
1217
|
214
|
|
|
|
|
937
|
$self->select_section('after_eval'); |
1218
|
|
|
|
|
|
|
$self->push_lines('warn $_w_eval_err if $_w_eval_err;'); |
1219
|
|
|
|
|
|
|
$self->_errif(500, '"Function died: $_w_eval_err"', '$_w_eval_err'); |
1220
|
104
|
|
|
|
|
286
|
|
1221
|
104
|
100
|
|
|
|
233
|
$self->select_section('OPEN_EVAL'); |
1222
|
98
|
|
|
|
|
218
|
$self->push_lines('eval {'); |
1223
|
|
|
|
|
|
|
$self->indent; |
1224
|
|
|
|
|
|
|
} |
1225
|
104
|
|
|
|
|
256
|
|
1226
|
104
|
|
66
|
|
|
232
|
# return sub result |
1227
|
|
|
|
|
|
|
$self->select_section('BEFORE_CLOSE_SUB'); |
1228
|
|
|
|
|
|
|
$self->push_lines('return $_w_res;') if $needs_store_res; |
1229
|
|
|
|
|
|
|
$self->select_section('CLOSE_SUB'); |
1230
|
104
|
100
|
|
|
|
757
|
$self->unindent; |
|
|
100
|
|
|
|
|
|
1231
|
104
|
100
|
|
|
|
278
|
$self->push_lines('}'); # wrapper sub |
1232
|
98
|
|
|
|
|
259
|
|
1233
|
98
|
100
|
|
|
|
235
|
# return wrap result |
1234
|
96
|
|
|
|
|
235
|
my $result = { |
1235
|
|
|
|
|
|
|
sub_name => $sub_name, |
1236
|
|
|
|
|
|
|
sub_ref_name => $sub_ref_name, |
1237
|
|
|
|
|
|
|
meta => $meta, |
1238
|
|
|
|
|
|
|
meta_name => $meta_name, |
1239
|
96
|
|
|
|
|
257
|
use_eval => $use_eval, |
1240
|
96
|
50
|
|
|
|
289
|
}; |
1241
|
0
|
|
|
|
|
0
|
if ($args{embed}) { |
1242
|
0
|
|
|
|
|
0
|
$result->{source} = $self->_format_embed_wrapper_code; |
1243
|
|
|
|
|
|
|
} else { |
1244
|
|
|
|
|
|
|
my $source = $self->_format_dyn_wrapper_code; |
1245
|
|
|
|
|
|
|
if ($Log_Wrapper_Code && log_is_trace()) { |
1246
|
|
|
|
|
|
|
require String::LineNumber; |
1247
|
0
|
|
|
|
|
0
|
log_trace("wrapper code:\n%s", |
1248
|
|
|
|
|
|
|
$ENV{LINENUM} // 1 ? |
1249
|
|
|
|
|
|
|
String::LineNumber::linenum($source) : |
1250
|
|
|
|
|
|
|
$source); |
1251
|
96
|
|
|
|
|
501
|
} |
1252
|
|
|
|
|
|
|
$result->{source} = $source; |
1253
|
|
|
|
|
|
|
if ($args{compile}) { |
1254
|
96
|
|
|
|
|
261
|
my $wrapped = eval $source; |
1255
|
96
|
|
|
|
|
185
|
die "BUG: Wrapper code can't be compiled: $@" if $@ || !$wrapped; |
1256
|
|
|
|
|
|
|
$result->{sub} = $wrapped; |
1257
|
|
|
|
|
|
|
} |
1258
|
|
|
|
|
|
|
} |
1259
|
104
|
|
|
|
|
244
|
|
1260
|
104
|
50
|
|
|
|
242
|
[200, "OK", $result]; |
1261
|
0
|
|
|
|
|
0
|
} |
1262
|
0
|
|
|
|
|
0
|
|
1263
|
0
|
|
|
|
|
0
|
$SPEC{wrap_sub} = { |
1264
|
0
|
|
|
|
|
0
|
v => 1.1, |
1265
|
0
|
|
|
|
|
0
|
summary => 'Wrap subroutine to do various things, '. |
1266
|
|
|
|
|
|
|
'like enforcing Rinci properties', |
1267
|
|
|
|
|
|
|
result => { |
1268
|
|
|
|
|
|
|
summary => 'The wrapped subroutine along with its new metadata', |
1269
|
|
|
|
|
|
|
description => <<'_', |
1270
|
|
|
|
|
|
|
|
1271
|
0
|
|
|
|
|
0
|
Aside from wrapping the subroutine, the wrapper will also create a new metadata |
1272
|
0
|
|
|
|
|
0
|
for the subroutine. The new metadata is a clone of the original, with some |
1273
|
0
|
|
|
|
|
0
|
properties changed, e.g. schema in `args` and `result` normalized, some values |
1274
|
|
|
|
|
|
|
changed according to the `convert` argument, some defaults set, etc. |
1275
|
0
|
|
|
|
|
0
|
|
1276
|
0
|
|
|
|
|
0
|
The new metadata will also contain (or append) the wrapping log located in the |
1277
|
0
|
|
|
|
|
0
|
`x.perinci.sub.wrapper.logs` attribute. The wrapping log marks that the wrapper |
1278
|
|
|
|
|
|
|
has added some functionality (like validating arguments or result) so that |
1279
|
|
|
|
|
|
|
future nested wrapper can choose to avoid duplicating the same functionality. |
1280
|
|
|
|
|
|
|
|
1281
|
104
|
|
|
|
|
242
|
_ |
1282
|
104
|
100
|
|
|
|
291
|
schema=>['hash*'=>{keys=>{ |
1283
|
104
|
|
|
|
|
239
|
sub=>'code*', |
1284
|
104
|
|
|
|
|
221
|
source=>['any*' => of => ['str*', ['hash*' => each_value=>'str*']]], |
1285
|
104
|
|
|
|
|
229
|
meta=>'hash*', |
1286
|
|
|
|
|
|
|
}}], |
1287
|
|
|
|
|
|
|
}, |
1288
|
104
|
|
|
|
|
476
|
args => { |
1289
|
|
|
|
|
|
|
sub => { |
1290
|
|
|
|
|
|
|
schema => 'str*', |
1291
|
|
|
|
|
|
|
summary => 'The code to be wrapped', |
1292
|
|
|
|
|
|
|
description => <<'_', |
1293
|
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
|
At least one of `sub` or `sub_name` must be specified. |
1295
|
104
|
100
|
|
|
|
251
|
|
1296
|
52
|
|
|
|
|
148
|
_ |
1297
|
|
|
|
|
|
|
}, |
1298
|
52
|
|
|
|
|
153
|
sub_name => { |
1299
|
52
|
50
|
33
|
|
|
301
|
schema => 'str*', |
1300
|
0
|
|
|
|
|
0
|
summary => 'The name of the subroutine, '. |
1301
|
|
|
|
|
|
|
'e.g. func or Foo::func (qualified)', |
1302
|
0
|
0
|
0
|
|
|
0
|
description => <<'_', |
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
At least one of `sub` or `sub_name` must be specified. |
1305
|
|
|
|
|
|
|
|
1306
|
52
|
|
|
|
|
108
|
_ |
1307
|
52
|
50
|
|
|
|
137
|
}, |
1308
|
52
|
|
|
8
|
|
5806
|
meta => { |
|
8
|
|
|
8
|
|
68
|
|
|
8
|
|
|
|
|
12
|
|
|
8
|
|
|
|
|
61
|
|
|
8
|
|
|
|
|
519
|
|
|
8
|
|
|
|
|
26
|
|
|
8
|
|
|
|
|
2291
|
|
1309
|
52
|
50
|
33
|
|
|
357
|
schema => 'hash*', |
1310
|
52
|
|
|
|
|
173
|
summary => 'The function metadata', |
1311
|
|
|
|
|
|
|
req => 1, |
1312
|
|
|
|
|
|
|
}, |
1313
|
|
|
|
|
|
|
meta_name => { |
1314
|
104
|
|
|
|
|
964
|
schema => 'str*', |
1315
|
|
|
|
|
|
|
summary => 'Where to find the metadata, e.g. "$SPEC{foo}"', |
1316
|
|
|
|
|
|
|
description => <<'_', |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
Some wrapper code (e.g. handler for `dep` property) needs to refer to the |
1319
|
|
|
|
|
|
|
function metadata. If not provided, the wrapper will store the function metadata |
1320
|
|
|
|
|
|
|
in a unique variable (e.g. `$Perinci::Sub::Wrapped::meta34127816`). |
1321
|
|
|
|
|
|
|
|
1322
|
|
|
|
|
|
|
_ |
1323
|
|
|
|
|
|
|
}, |
1324
|
|
|
|
|
|
|
convert => { |
1325
|
|
|
|
|
|
|
schema => 'hash*', |
1326
|
|
|
|
|
|
|
summary => 'Properties to convert to new value', |
1327
|
|
|
|
|
|
|
description => <<'_', |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
Not all properties can be converted, but these are a partial list of those that |
1330
|
|
|
|
|
|
|
can: v (usually do not need to be specified when converting from 1.0 to 1.1, |
1331
|
|
|
|
|
|
|
will be done automatically), args_as, result_naked, default_lang. |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
_ |
1334
|
|
|
|
|
|
|
}, |
1335
|
|
|
|
|
|
|
compile => { |
1336
|
|
|
|
|
|
|
schema => ['bool' => {default=>1}], |
1337
|
|
|
|
|
|
|
summary => 'Whether to compile the generated wrapper', |
1338
|
|
|
|
|
|
|
description => <<'_', |
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
Can be set to 0 to not actually wrap but just return the generated wrapper |
1341
|
|
|
|
|
|
|
source code. |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
_ |
1344
|
|
|
|
|
|
|
}, |
1345
|
|
|
|
|
|
|
compile => { |
1346
|
|
|
|
|
|
|
schema => ['bool' => {default=>1}], |
1347
|
|
|
|
|
|
|
summary => 'Whether to compile the generated wrapper', |
1348
|
|
|
|
|
|
|
description => <<'_', |
1349
|
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
|
Can be set to 0 to not actually wrap but just return the generated wrapper |
1351
|
|
|
|
|
|
|
source code. |
1352
|
|
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
_ |
1354
|
|
|
|
|
|
|
}, |
1355
|
|
|
|
|
|
|
debug => { |
1356
|
|
|
|
|
|
|
schema => [bool => {default=>0}], |
1357
|
|
|
|
|
|
|
summary => 'Generate code with debugging', |
1358
|
|
|
|
|
|
|
description => <<'_', |
1359
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
If turned on, will produce various debugging in the generated code. Currently |
1361
|
|
|
|
|
|
|
what this does: |
1362
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
* add more comments (e.g. for each property handler) |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
_ |
1366
|
|
|
|
|
|
|
}, |
1367
|
|
|
|
|
|
|
validate_args => { |
1368
|
|
|
|
|
|
|
schema => ['bool'], |
1369
|
|
|
|
|
|
|
summary => 'Whether wrapper should validate arguments', |
1370
|
|
|
|
|
|
|
description => <<'_', |
1371
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
If set to true, will validate arguments. Validation error will cause status 400 |
1373
|
|
|
|
|
|
|
to be returned. The default is to enable this unless previous wrapper(s) have |
1374
|
|
|
|
|
|
|
already done this. |
1375
|
|
|
|
|
|
|
|
1376
|
|
|
|
|
|
|
_ |
1377
|
|
|
|
|
|
|
}, |
1378
|
|
|
|
|
|
|
validate_result => { |
1379
|
|
|
|
|
|
|
schema => ['bool'], |
1380
|
|
|
|
|
|
|
summary => 'Whether wrapper should validate arguments', |
1381
|
|
|
|
|
|
|
description => <<'_', |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
If set to true, will validate sub's result. Validation error will cause wrapper |
1384
|
|
|
|
|
|
|
to return status 500 instead of sub's result. The default is to enable this |
1385
|
|
|
|
|
|
|
unless previous wrapper(s) have already done this. |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
_ |
1388
|
|
|
|
|
|
|
}, |
1389
|
|
|
|
|
|
|
core => { |
1390
|
|
|
|
|
|
|
summary => 'If set to true, will avoid the use of non-core modules', |
1391
|
|
|
|
|
|
|
schema => 'bool', |
1392
|
|
|
|
|
|
|
}, |
1393
|
|
|
|
|
|
|
core_or_pp => { |
1394
|
|
|
|
|
|
|
summary => 'If set to true, will avoid the use of non-core XS modules', |
1395
|
|
|
|
|
|
|
schema => 'bool', |
1396
|
|
|
|
|
|
|
description => <<'_', |
1397
|
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
|
In other words, will stick to core or pure-perl modules only. |
1399
|
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
|
_ |
1401
|
|
|
|
|
|
|
}, |
1402
|
|
|
|
|
|
|
pp => { |
1403
|
|
|
|
|
|
|
summary => 'If set to true, will avoid the use of XS modules', |
1404
|
|
|
|
|
|
|
schema => 'bool', |
1405
|
|
|
|
|
|
|
}, |
1406
|
|
|
|
|
|
|
}, |
1407
|
|
|
|
|
|
|
}; |
1408
|
|
|
|
|
|
|
__PACKAGE__->new->wrap(@_); |
1409
|
|
|
|
|
|
|
} |
1410
|
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
|
1; |
1412
|
|
|
|
|
|
|
# ABSTRACT: A multi-purpose subroutine wrapping framework |
1413
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
=pod |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
=encoding UTF-8 |
1418
|
|
|
|
|
|
|
|
1419
|
|
|
|
|
|
|
=head1 NAME |
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
Perinci::Sub::Wrapper - A multi-purpose subroutine wrapping framework |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
=head1 VERSION |
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
This document describes version 0.852 of Perinci::Sub::Wrapper (from Perl distribution Perinci-Sub-Wrapper), released on 2021-08-01. |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
=head1 SYNOPSIS |
1428
|
|
|
|
|
|
|
|
1429
|
|
|
|
|
|
|
For dynamic usage: |
1430
|
|
|
|
|
|
|
|
1431
|
|
|
|
|
|
|
use Perinci::Sub::Wrapper qw(wrap_sub); |
1432
|
|
|
|
|
|
|
my $res = wrap_sub(sub_name => "mysub", meta=>{...}); |
1433
|
|
|
|
|
|
|
my ($wrapped_sub, $meta) = ($res->[2]{sub}, $res->[2]{meta}); |
1434
|
|
|
|
|
|
|
$wrapped_sub->(); # call the wrapped function |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
=head1 DESCRIPTION |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
Perinci::Sub::Wrapper (PSW for short) is an extensible subroutine wrapping |
1439
|
|
|
|
|
|
|
framework. It generates code to do stuffs before calling your subroutine, like |
1440
|
|
|
|
|
|
|
validate arguments, convert arguments from positional/array to named/hash or |
1441
|
|
|
|
|
|
|
vice versa, etc; as well as generate code to do stuffs after calling your |
1442
|
|
|
|
|
|
|
subroutine, like retry calling for a number of times if subroutine returns a |
1443
|
|
|
|
|
|
|
non-success status, check subroutine result against a schema, etc). Some other |
1444
|
|
|
|
|
|
|
things it can do: apply a timeout, currying, and so on. |
1445
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
PSW differs from other function composition or decoration system like Python |
1447
|
|
|
|
|
|
|
decorators (or its Perl equivalent L<Python::Decorator>) in a couple of ways: |
1448
|
|
|
|
|
|
|
|
1449
|
|
|
|
|
|
|
=over |
1450
|
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
|
=item * Single wrapper |
1452
|
|
|
|
|
|
|
|
1453
|
|
|
|
|
|
|
Instead of multiple/nested wrapping for implementing different features, PSW |
1454
|
|
|
|
|
|
|
is designed to generate a single large wrapper around your code, i.e.: |
1455
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
sub _wrapper_for_your_sub { |
1457
|
|
|
|
|
|
|
... |
1458
|
|
|
|
|
|
|
# do various stuffs before calling: |
1459
|
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
|
# e.g. start timer |
1461
|
|
|
|
|
|
|
# e.g. convert, prefill, validate arguments |
1462
|
|
|
|
|
|
|
my @args = ...; |
1463
|
112
|
|
|
112
|
1
|
424
|
... |
1464
|
|
|
|
|
|
|
your_sub(@args); |
1465
|
|
|
|
|
|
|
... |
1466
|
|
|
|
|
|
|
# do various stuffs after calling |
1467
|
|
|
|
|
|
|
... |
1468
|
|
|
|
|
|
|
# e.g. report times |
1469
|
|
|
|
|
|
|
# e.g. perform retry |
1470
|
|
|
|
|
|
|
# e.g. convert or envelope results |
1471
|
|
|
|
|
|
|
|
1472
|
|
|
|
|
|
|
# return result |
1473
|
|
|
|
|
|
|
} |
1474
|
|
|
|
|
|
|
|
1475
|
|
|
|
|
|
|
Multiple functionalities will be added and combined in this single wrapper |
1476
|
|
|
|
|
|
|
subroutine in the appropriate location. This is done to reduce function call |
1477
|
|
|
|
|
|
|
overhead or depth of nested call levels. And also to make it easier to embed the |
1478
|
|
|
|
|
|
|
wrapping code to your source code (see L<Dist::Zilla::Plugin::Rinci::Wrap>). |
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
Of course, you can still wrap multiple times if wanted. |
1481
|
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
|
=item * Rinci |
1483
|
|
|
|
|
|
|
|
1484
|
|
|
|
|
|
|
The wrapper code is built according to the L<Rinci> metadata you provide. Rinci |
1485
|
|
|
|
|
|
|
allows you to specify various things for your function, e.g. list of arguments |
1486
|
|
|
|
|
|
|
including the expected data type of each argument and whether an argument is |
1487
|
|
|
|
|
|
|
required or optional. PSW can then be used to generate the necessary code to |
1488
|
|
|
|
|
|
|
enforce this specification, e.g. generate validator for the function arguments. |
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
Since Rinci specification is extensible, you can describe additional stuffs for |
1491
|
|
|
|
|
|
|
your function and write a PSW plugin to generate the necessary code to implement |
1492
|
|
|
|
|
|
|
your specification. An example is C<timeout> to specify execution time limit, |
1493
|
|
|
|
|
|
|
implemented by L<Perinci::Sub::Property::timeout> which generates code to call |
1494
|
|
|
|
|
|
|
function inside an C<eval()> block and use C<alarm()> to limit the execution. |
1495
|
|
|
|
|
|
|
Another example is C<retry> property, implemented by |
1496
|
|
|
|
|
|
|
L<Perinci::Sub::Property::retry> which generates code to call function inside a |
1497
|
|
|
|
|
|
|
simple retry loop. |
1498
|
|
|
|
|
|
|
|
1499
|
|
|
|
|
|
|
=back |
1500
|
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
|
Normally you do not use PSW directly in your applications. You might want to |
1502
|
|
|
|
|
|
|
check out L<Perinci::Access::Perl> and L<Perinci::Exporter> on examples of |
1503
|
|
|
|
|
|
|
wrapping function dynamically (during runtime), or |
1504
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::Rinci::Wrap> on an example of embedding the generated |
1505
|
|
|
|
|
|
|
wrapping code to source code during build. |
1506
|
|
|
|
|
|
|
|
1507
|
|
|
|
|
|
|
=head1 EXTENDING |
1508
|
|
|
|
|
|
|
|
1509
|
|
|
|
|
|
|
The framework is simple and extensible. Please delve directly into the source |
1510
|
|
|
|
|
|
|
code for now. Some notes: |
1511
|
|
|
|
|
|
|
|
1512
|
|
|
|
|
|
|
The internal uses OO. |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
The main wrapper building mechanism is in the C<wrap()> method. |
1515
|
|
|
|
|
|
|
|
1516
|
|
|
|
|
|
|
For each Rinci property, it will call C<handle_NAME()> wrapper handler method. |
1517
|
|
|
|
|
|
|
The C<handlemeta_NAME()> methods are called first, to determine order of |
1518
|
|
|
|
|
|
|
processing. You can supply these methods either by subclassing the class or, |
1519
|
|
|
|
|
|
|
more simply, monkeypatching the method in the C<Perinci::Sub::Wrapper> package. |
1520
|
|
|
|
|
|
|
|
1521
|
|
|
|
|
|
|
The wrapper handler method will be called with a hash argument, containing these |
1522
|
|
|
|
|
|
|
keys: B<value> (property value), B<new> (this key will exist if C<convert> |
1523
|
|
|
|
|
|
|
argument of C<wrap()> exists, to convert a property to a new value). |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
For properties that have name in the form of C<NAME1.NAME2.NAME3> (i.e., dotted) |
1526
|
|
|
|
|
|
|
only the first part of the name will be used (i.e., C<handle_NAME1()>). |
1527
|
|
|
|
|
|
|
|
1528
|
|
|
|
|
|
|
=head1 VARIABLES |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
=head2 $Log_Wrapper_Code (BOOL) |
1531
|
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
|
Whether to log wrapper result. Default is from environment variable |
1533
|
|
|
|
|
|
|
LOG_PERINCI_WRAPPER_CODE, or false. Logging is done with L<Log::ger> at trace |
1534
|
|
|
|
|
|
|
level. |
1535
|
|
|
|
|
|
|
|
1536
|
|
|
|
|
|
|
=head1 RINCI FUNCTION METADATA |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
=head2 x.perinci.sub.wrapper.disable_validate_args => bool |
1539
|
|
|
|
|
|
|
|
1540
|
|
|
|
|
|
|
Can be set to 1 to set C<validate_args> to 0 by default. This is used e.g. if |
1541
|
|
|
|
|
|
|
you already embed/insert code to validate arguments by other means and do not |
1542
|
|
|
|
|
|
|
want to repeat validating arguments. E.g. used if you use |
1543
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::Rinci::Validate>. |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
=head2 x.perinci.sub.wrapper.disable_validate_result => bool |
1546
|
|
|
|
|
|
|
|
1547
|
|
|
|
|
|
|
Can be set to 1 to set C<validate_result> to 0 by default. This is used e.g. if |
1548
|
|
|
|
|
|
|
you already embed/insert code to validate result by other means and do not want |
1549
|
|
|
|
|
|
|
to repeat validating result. E.g. used if you use |
1550
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::Rinci::Validate>. |
1551
|
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
|
=head2 x.perinci.sub.wrapper.logs => array |
1553
|
|
|
|
|
|
|
|
1554
|
|
|
|
|
|
|
Generated/added by this module to the function metadata for every wrapping done. |
1555
|
|
|
|
|
|
|
Used to avoid adding repeated code, e.g. to validate result or arguments. |
1556
|
|
|
|
|
|
|
|
1557
|
|
|
|
|
|
|
=head1 PERFORMANCE NOTES |
1558
|
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
|
The following numbers are produced on an Intel Core i5-2400 3.1GHz desktop using |
1560
|
|
|
|
|
|
|
PSW v0.51 and Perl v5.18.2. Operating system is Debian sid (64bit). |
1561
|
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
|
For perspective, empty subroutine (C<< sub {} >>) as well as C<< sub { [200, |
1563
|
|
|
|
|
|
|
"OK"] } >> can be called around 5.3 mil/sec. |
1564
|
|
|
|
|
|
|
|
1565
|
|
|
|
|
|
|
Wrapping this subroutine C<< sub { [200, "OK"] } >> and this simple metadata C<< |
1566
|
|
|
|
|
|
|
{v=>1.1} >> using default options yields call performance for C<< $sub->() >> of |
1567
|
|
|
|
|
|
|
about 0.9 mil/sec. With C<< validate_args=>0 >> and C<< validate_result=>0 >>, |
1568
|
|
|
|
|
|
|
it's 1.5 mil/sec. |
1569
|
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
|
As more (and more complex) arguments are introduced and validated, overhead will |
1571
|
|
|
|
|
|
|
increase. The significant portion of the overhead is in argument validation. For |
1572
|
|
|
|
|
|
|
example, this metadata C<< {v=>1.1, args=>{a=>{schema=>"int"}}} >> yields 0.5 |
1573
|
|
|
|
|
|
|
mil/sec. |
1574
|
|
|
|
|
|
|
|
1575
|
|
|
|
|
|
|
=head1 FUNCTIONS |
1576
|
|
|
|
|
|
|
|
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
=head2 wrap_sub |
1579
|
|
|
|
|
|
|
|
1580
|
|
|
|
|
|
|
Usage: |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
wrap_sub(%args) -> [$status_code, $reason, $payload, \%result_meta] |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
Wrap subroutine to do various things, like enforcing Rinci properties. |
1585
|
|
|
|
|
|
|
|
1586
|
|
|
|
|
|
|
This function is not exported by default, but exportable. |
1587
|
|
|
|
|
|
|
|
1588
|
|
|
|
|
|
|
Arguments ('*' denotes required arguments): |
1589
|
|
|
|
|
|
|
|
1590
|
|
|
|
|
|
|
=over 4 |
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
=item * B<compile> => I<bool> (default: 1) |
1593
|
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
|
Whether to compile the generated wrapper. |
1595
|
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
|
Can be set to 0 to not actually wrap but just return the generated wrapper |
1597
|
|
|
|
|
|
|
source code. |
1598
|
|
|
|
|
|
|
|
1599
|
|
|
|
|
|
|
=item * B<convert> => I<hash> |
1600
|
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
|
Properties to convert to new value. |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
Not all properties can be converted, but these are a partial list of those that |
1604
|
|
|
|
|
|
|
can: v (usually do not need to be specified when converting from 1.0 to 1.1, |
1605
|
|
|
|
|
|
|
will be done automatically), args_as, result_naked, default_lang. |
1606
|
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
|
=item * B<core> => I<bool> |
1608
|
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
If set to true, will avoid the use of non-core modules. |
1610
|
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
|
=item * B<core_or_pp> => I<bool> |
1612
|
|
|
|
|
|
|
|
1613
|
|
|
|
|
|
|
If set to true, will avoid the use of non-core XS modules. |
1614
|
|
|
|
|
|
|
|
1615
|
|
|
|
|
|
|
In other words, will stick to core or pure-perl modules only. |
1616
|
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
|
=item * B<debug> => I<bool> (default: 0) |
1618
|
|
|
|
|
|
|
|
1619
|
|
|
|
|
|
|
Generate code with debugging. |
1620
|
|
|
|
|
|
|
|
1621
|
|
|
|
|
|
|
If turned on, will produce various debugging in the generated code. Currently |
1622
|
|
|
|
|
|
|
what this does: |
1623
|
|
|
|
|
|
|
|
1624
|
|
|
|
|
|
|
=over |
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
=item * add more comments (e.g. for each property handler) |
1627
|
|
|
|
|
|
|
|
1628
|
|
|
|
|
|
|
=back |
1629
|
|
|
|
|
|
|
|
1630
|
|
|
|
|
|
|
=item * B<meta>* => I<hash> |
1631
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
The function metadata. |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
=item * B<meta_name> => I<str> |
1635
|
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
|
Where to find the metadata, e.g. "$SPEC{foo}". |
1637
|
|
|
|
|
|
|
|
1638
|
|
|
|
|
|
|
Some wrapper code (e.g. handler for C<dep> property) needs to refer to the |
1639
|
|
|
|
|
|
|
function metadata. If not provided, the wrapper will store the function metadata |
1640
|
|
|
|
|
|
|
in a unique variable (e.g. C<$Perinci::Sub::Wrapped::meta34127816>). |
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
=item * B<pp> => I<bool> |
1643
|
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
|
If set to true, will avoid the use of XS modules. |
1645
|
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
|
=item * B<sub> => I<str> |
1647
|
|
|
|
|
|
|
|
1648
|
|
|
|
|
|
|
The code to be wrapped. |
1649
|
|
|
|
|
|
|
|
1650
|
|
|
|
|
|
|
At least one of C<sub> or C<sub_name> must be specified. |
1651
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
=item * B<sub_name> => I<str> |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
The name of the subroutine, e.g. func or Foo::func (qualified). |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
At least one of C<sub> or C<sub_name> must be specified. |
1657
|
|
|
|
|
|
|
|
1658
|
|
|
|
|
|
|
=item * B<validate_args> => I<bool> |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
Whether wrapper should validate arguments. |
1661
|
|
|
|
|
|
|
|
1662
|
|
|
|
|
|
|
If set to true, will validate arguments. Validation error will cause status 400 |
1663
|
|
|
|
|
|
|
to be returned. The default is to enable this unless previous wrapper(s) have |
1664
|
|
|
|
|
|
|
already done this. |
1665
|
|
|
|
|
|
|
|
1666
|
|
|
|
|
|
|
=item * B<validate_result> => I<bool> |
1667
|
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
|
Whether wrapper should validate arguments. |
1669
|
|
|
|
|
|
|
|
1670
|
|
|
|
|
|
|
If set to true, will validate sub's result. Validation error will cause wrapper |
1671
|
|
|
|
|
|
|
to return status 500 instead of sub's result. The default is to enable this |
1672
|
|
|
|
|
|
|
unless previous wrapper(s) have already done this. |
1673
|
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
|
|
1675
|
|
|
|
|
|
|
=back |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
Returns an enveloped result (an array). |
1678
|
|
|
|
|
|
|
|
1679
|
|
|
|
|
|
|
First element ($status_code) is an integer containing HTTP-like status code |
1680
|
|
|
|
|
|
|
(200 means OK, 4xx caller error, 5xx function error). Second element |
1681
|
|
|
|
|
|
|
($reason) is a string containing error message, or something like "OK" if status is |
1682
|
|
|
|
|
|
|
200. Third element ($payload) is the actual result, but usually not present when enveloped result is an error response ($status_code is not 2xx). Fourth |
1683
|
|
|
|
|
|
|
element (%result_meta) is called result metadata and is optional, a hash |
1684
|
|
|
|
|
|
|
that contains extra information, much like how HTTP response headers provide additional metadata. |
1685
|
|
|
|
|
|
|
|
1686
|
|
|
|
|
|
|
Return value: The wrapped subroutine along with its new metadata (hash) |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
|
1689
|
|
|
|
|
|
|
Aside from wrapping the subroutine, the wrapper will also create a new metadata |
1690
|
|
|
|
|
|
|
for the subroutine. The new metadata is a clone of the original, with some |
1691
|
|
|
|
|
|
|
properties changed, e.g. schema in C<args> and C<result> normalized, some values |
1692
|
|
|
|
|
|
|
changed according to the C<convert> argument, some defaults set, etc. |
1693
|
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
The new metadata will also contain (or append) the wrapping log located in the |
1695
|
|
|
|
|
|
|
C<x.perinci.sub.wrapper.logs> attribute. The wrapping log marks that the wrapper |
1696
|
|
|
|
|
|
|
has added some functionality (like validating arguments or result) so that |
1697
|
|
|
|
|
|
|
future nested wrapper can choose to avoid duplicating the same functionality. |
1698
|
|
|
|
|
|
|
|
1699
|
|
|
|
|
|
|
=for Pod::Coverage ^(new|handle(meta)?_.+|wrap|add_.+|section_empty|indent|unindent|get_indent_level|select_section|push_lines)$ |
1700
|
|
|
|
|
|
|
|
1701
|
|
|
|
|
|
|
=head1 METHODS |
1702
|
|
|
|
|
|
|
|
1703
|
|
|
|
|
|
|
The OO interface is only used internally or when you want to extend the wrapper. |
1704
|
|
|
|
|
|
|
|
1705
|
|
|
|
|
|
|
=head1 FAQ |
1706
|
|
|
|
|
|
|
|
1707
|
|
|
|
|
|
|
=head2 General |
1708
|
|
|
|
|
|
|
|
1709
|
|
|
|
|
|
|
=over |
1710
|
|
|
|
|
|
|
|
1711
|
|
|
|
|
|
|
=item * What is a function wrapper? |
1712
|
|
|
|
|
|
|
|
1713
|
|
|
|
|
|
|
A wrapper function calls the target function but with additional behaviors. The |
1714
|
|
|
|
|
|
|
goal is similar to function composition or decorator system like in Python (or |
1715
|
|
|
|
|
|
|
its Perl equivalent L<Python::Decorator>) where you use a higher-order function |
1716
|
|
|
|
|
|
|
which accepts another function and modifies it. |
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
It is used to add various functionalities, e.g.: cache/memoization, singleton, |
1719
|
|
|
|
|
|
|
adding benchmarking/timing around function call, logging, argument validation |
1720
|
|
|
|
|
|
|
(parameter checking), checking pre/post-condition, authentication/authorization |
1721
|
|
|
|
|
|
|
checking, etc. The Python folks use decorators quite a bit; see discussions on |
1722
|
|
|
|
|
|
|
the Internet on those. |
1723
|
|
|
|
|
|
|
|
1724
|
|
|
|
|
|
|
=item * How is PSW different from Python::Decorator? |
1725
|
|
|
|
|
|
|
|
1726
|
|
|
|
|
|
|
PSW uses dynamic code generation (it generates Perl code on the fly). It also |
1727
|
|
|
|
|
|
|
creates a single large wrapper instead of nested wrappers. It builds wrapper |
1728
|
|
|
|
|
|
|
code according to L<Rinci> specification. |
1729
|
|
|
|
|
|
|
|
1730
|
|
|
|
|
|
|
=item * Why use code generation? |
1731
|
|
|
|
|
|
|
|
1732
|
|
|
|
|
|
|
Mainly because L<Data::Sah>, which is the module used to do argument validation, |
1733
|
|
|
|
|
|
|
also uses code generation. Data::Sah allows us to do data validation at full |
1734
|
|
|
|
|
|
|
Perl speed, which can be one or two orders of magnitude faster than |
1735
|
|
|
|
|
|
|
"interpreter" modules like L<Data::FormValidator>. |
1736
|
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
|
=item * Why use a single large wrapper? |
1738
|
|
|
|
|
|
|
|
1739
|
|
|
|
|
|
|
This is just a design approach. It can impose some restriction for wrapper code |
1740
|
|
|
|
|
|
|
authors, since everything needs to be put in a single subroutine, but has nice |
1741
|
|
|
|
|
|
|
properties like less stack trace depth and less function call overhead. |
1742
|
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
|
=back |
1744
|
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
|
=head2 Debugging |
1746
|
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
|
=over |
1748
|
|
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
=item * How to display the wrapper code being generated? |
1750
|
|
|
|
|
|
|
|
1751
|
|
|
|
|
|
|
If environment variable L<LOG_PERINCI_WRAPPER_CODE> or package variable |
1752
|
|
|
|
|
|
|
$Log_Perinci_Wrapper_Code is set to true, generated wrapper source code is |
1753
|
|
|
|
|
|
|
logged at trace level using L<Log::ger>. It can be displayed, for example: |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
% LOG_PERINCI_WRAPPER_CODE=1 TRACE=1 \ |
1756
|
|
|
|
|
|
|
perl -MLog::ger::LevelFromEnv -MLog::ger::Output=Screen \ |
1757
|
|
|
|
|
|
|
-MPerinci::Sub::Wrapper=wrap_sub \ |
1758
|
|
|
|
|
|
|
-e 'wrap_sub(sub=>sub{}, meta=>{v=>1.1, args=>{a=>{schema=>"int"}}});' |
1759
|
|
|
|
|
|
|
|
1760
|
|
|
|
|
|
|
Note that L<Data::Sah> (the module used to generate validator code) observes |
1761
|
|
|
|
|
|
|
C<LOG_SAH_VALIDATOR_CODE>, but during wrapping this environment flag is |
1762
|
|
|
|
|
|
|
currently disabled by this module, so you need to set |
1763
|
|
|
|
|
|
|
L<LOG_PERINCI_WRAPPER_CODE> instead. |
1764
|
|
|
|
|
|
|
|
1765
|
|
|
|
|
|
|
=back |
1766
|
|
|
|
|
|
|
|
1767
|
|
|
|
|
|
|
=head2 caller() doesn't work from inside my wrapped code! |
1768
|
|
|
|
|
|
|
|
1769
|
|
|
|
|
|
|
Wrapping adds at least one or two levels of calls: one for the wrapper |
1770
|
|
|
|
|
|
|
subroutine itself, the other is for the eval trap when necessary. |
1771
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
This poses a problem if you need to call caller() from within your wrapped code; |
1773
|
|
|
|
|
|
|
it will also be off by at least one or two. |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
The solution is for your function to use the caller() replacement, provided by |
1776
|
|
|
|
|
|
|
L<Perinci::Sub::Util>. Or use embedded mode, where the wrapper code won't add |
1777
|
|
|
|
|
|
|
extra subroutine calls. |
1778
|
|
|
|
|
|
|
|
1779
|
|
|
|
|
|
|
=head1 ENVIRONMENT |
1780
|
|
|
|
|
|
|
|
1781
|
|
|
|
|
|
|
=head2 LOG_PERINCI_WRAPPER_CODE (bool) |
1782
|
|
|
|
|
|
|
|
1783
|
|
|
|
|
|
|
If set to 1, will log the generated wrapper code. This value is used to set |
1784
|
|
|
|
|
|
|
C<$Log_Wrapper_Code> if it is not already set. |
1785
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
=head2 PERINCI_WRAPPER_CORE => bool |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
Set default for wrap argument C<core>. |
1789
|
|
|
|
|
|
|
|
1790
|
|
|
|
|
|
|
=head2 PERINCI_WRAPPER_CORE_OR_PP => bool |
1791
|
|
|
|
|
|
|
|
1792
|
|
|
|
|
|
|
Set default for wrap argument C<core_or_pp>. |
1793
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
=head2 PERINCI_WRAPPER_PP => bool |
1795
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
Set default for wrap argument C<pp>. |
1797
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
=head1 HOMEPAGE |
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Wrapper>. |
1801
|
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
|
=head1 SOURCE |
1803
|
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
|
Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-Wrapper>. |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
=head1 BUGS |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Wrapper> |
1809
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
When submitting a bug or request, please include a test-file or a |
1811
|
|
|
|
|
|
|
patch to an existing test-file that illustrates the bug or desired |
1812
|
|
|
|
|
|
|
feature. |
1813
|
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
|
=head1 SEE ALSO |
1815
|
|
|
|
|
|
|
|
1816
|
|
|
|
|
|
|
L<Perinci>, L<Rinci> |
1817
|
|
|
|
|
|
|
|
1818
|
|
|
|
|
|
|
L<Python::Decorator> |
1819
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::Rinci::Wrap> |
1821
|
|
|
|
|
|
|
|
1822
|
|
|
|
|
|
|
L<Dist::Zilla::Plugin::Rinci::Validate> |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
=head1 AUTHOR |
1825
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
perlancar <perlancar@cpan.org> |
1827
|
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
|
=head1 CONTRIBUTORS |
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
=for stopwords s1 Steven Haryanto |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
=over 4 |
1833
|
|
|
|
|
|
|
|
1834
|
|
|
|
|
|
|
=item * |
1835
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
s1 <s1@backpacker.localdomain> |
1837
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
=item * |
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
Steven Haryanto <sharyanto@cpan.org> |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
=back |
1843
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
This software is copyright (c) 2021, 2019, 2017, 2016, 2015, 2014, 2013, 2012, 2011 by perlancar@cpan.org. |
1847
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
1849
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
1850
|
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
|
=cut |