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.010; |
6
|
17
|
|
|
17
|
|
1096218
|
use strict; |
|
17
|
|
|
|
|
203
|
|
7
|
17
|
|
|
17
|
|
80
|
use warnings; |
|
17
|
|
|
|
|
192
|
|
|
17
|
|
|
|
|
239
|
|
8
|
17
|
|
|
15
|
|
1314
|
|
|
15
|
|
|
|
|
133
|
|
|
15
|
|
|
|
|
320
|
|
9
|
|
|
|
|
|
|
use Function::Fallback::CoreOrPP qw(clone); |
10
|
15
|
|
|
15
|
|
5874
|
#use List::Util qw(shuffle); |
|
15
|
|
|
|
|
8056
|
|
|
15
|
|
|
|
|
707
|
|
11
|
|
|
|
|
|
|
use Perinci::Sub::Wrapper qw(wrap_sub); |
12
|
15
|
|
|
15
|
|
7410
|
use Test::More 0.96; |
|
15
|
|
|
|
|
117
|
|
|
15
|
|
|
|
|
777
|
|
13
|
15
|
|
|
15
|
|
393
|
|
|
15
|
|
|
|
|
268
|
|
|
15
|
|
|
|
|
80
|
|
14
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
15
|
|
|
|
|
|
|
our @EXPORT_OK = qw(test_wrap); |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
my %test_args = @_; |
18
|
|
|
|
|
|
|
$test_args{wrap_args} or die "BUG: wrap_args not defined"; |
19
|
59
|
|
|
59
|
0
|
181299
|
my $test_name = $test_args{name} or die "BUG: test_name not defined"; |
20
|
59
|
50
|
|
|
|
638
|
|
21
|
59
|
50
|
|
|
|
168
|
for my $wrapper_type (qw/dynamic embed/) { |
22
|
|
|
|
|
|
|
next if $wrapper_type eq 'dynamic' && $test_args{skip_dynamic}; |
23
|
59
|
|
|
|
|
410
|
next if $wrapper_type eq 'embed' && $test_args{skip_embed}; |
24
|
116
|
100
|
100
|
|
|
153393
|
subtest "$test_name ($wrapper_type)" => sub { |
25
|
115
|
100
|
100
|
|
|
452
|
|
26
|
|
|
|
|
|
|
if ($test_args{pretest}) { |
27
|
|
|
|
|
|
|
$test_args{pretest}->(); |
28
|
114
|
50
|
|
114
|
|
106450
|
} |
29
|
2
|
|
|
|
|
4
|
|
30
|
|
|
|
|
|
|
my $wrap_args = clone($test_args{wrap_args}); |
31
|
|
|
|
|
|
|
die "BUG: embed must not be specified in wrap_args, test_wrap() ". |
32
|
114
|
|
|
|
|
427
|
"will always test dynamic (embed=0) *and* embed mode" |
33
|
|
|
|
|
|
|
if exists $wrap_args->{embed}; |
34
|
|
|
|
|
|
|
if ($wrapper_type eq 'embed') { |
35
|
114
|
50
|
|
|
|
21303
|
$wrap_args->{embed} = 1; |
36
|
114
|
100
|
|
|
|
304
|
#diag explain $wrap_args->{meta}; |
37
|
58
|
|
|
|
|
466
|
} else { |
38
|
|
|
|
|
|
|
$wrap_args->{embed} = 0; |
39
|
|
|
|
|
|
|
} |
40
|
57
|
|
|
|
|
189
|
|
41
|
|
|
|
|
|
|
my $wrap_res; |
42
|
|
|
|
|
|
|
eval { $wrap_res = wrap_sub(%$wrap_args) }; |
43
|
113
|
|
|
|
|
155
|
my $wrap_eval_err = $@; |
44
|
113
|
|
|
|
|
447
|
if ($test_args{wrap_dies}) { |
|
113
|
|
|
|
|
438
|
|
45
|
113
|
|
|
|
|
40689
|
ok($wrap_eval_err, "wrap dies"); |
46
|
113
|
100
|
|
|
|
423
|
return; |
47
|
9
|
|
|
|
|
122
|
} else { |
48
|
9
|
|
|
|
|
4575
|
ok(!$wrap_eval_err, "wrap doesn't die") or do { |
49
|
|
|
|
|
|
|
diag $wrap_eval_err; |
50
|
105
|
50
|
|
|
|
863
|
return; |
51
|
1
|
|
|
|
|
6
|
}; |
52
|
1
|
|
|
|
|
2
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
if (defined $test_args{wrap_status}) { |
55
|
|
|
|
|
|
|
is(ref($wrap_res), 'ARRAY', 'wrap res is array'); |
56
|
105
|
100
|
|
|
|
45041
|
is($wrap_res->[0], $test_args{wrap_status}, |
57
|
27
|
|
|
|
|
214
|
"wrap status is $test_args{wrap_status}") |
58
|
|
|
|
|
|
|
or diag "wrap res: ", explain($wrap_res); |
59
|
27
|
50
|
|
|
|
9757
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
return unless $wrap_res->[0] == 200; |
62
|
|
|
|
|
|
|
|
63
|
105
|
50
|
|
|
|
10149
|
my $sub; |
64
|
|
|
|
|
|
|
if ($wrapper_type eq 'embed') { |
65
|
105
|
|
|
|
|
168
|
my $src = $wrap_res->[2]{source}; |
66
|
105
|
100
|
|
|
|
266
|
my $meta = $wrap_res->[2]{meta}; |
67
|
53
|
|
|
|
|
122
|
my $args_as = $meta->{args_as}; |
68
|
53
|
|
|
|
|
247
|
my $orig_args_as = $wrap_args->{meta}{args_as} // 'hash'; |
69
|
53
|
|
|
|
|
99
|
my $sub_name = $wrap_res->[2]{sub_name}; |
70
|
53
|
|
100
|
|
|
515
|
my $eval_src = join( |
71
|
53
|
|
|
|
|
127
|
"\n", |
72
|
|
|
|
|
|
|
$src->{presub1}, |
73
|
|
|
|
|
|
|
$src->{presub2}, |
74
|
|
|
|
|
|
|
'sub {', |
75
|
|
|
|
|
|
|
' my %args;', |
76
|
|
|
|
|
|
|
(' my @args;') x !!($orig_args_as eq 'array' || $args_as eq 'array'), |
77
|
|
|
|
|
|
|
(' my $args;') x !!($orig_args_as =~ /ref/ || $args_as =~ /ref/), |
78
|
|
|
|
|
|
|
' '. |
79
|
|
|
|
|
|
|
($args_as eq 'hash' ? '%args = @_;' : |
80
|
|
|
|
|
|
|
$args_as eq 'hashref' ? '$args = $_[0] // {}; %args = %$args;' : |
81
|
|
|
|
|
|
|
$args_as eq 'array' ? '@args = @_;' : |
82
|
|
|
|
|
|
|
'$args = $_[0] // [];'), |
83
|
|
|
|
|
|
|
$src->{preamble}, |
84
|
|
|
|
|
|
|
($src->{postamble} ? ' $_w_res = do {' : ''), |
85
|
|
|
|
|
|
|
$sub_name. ($sub_name =~ /\A\$/ ? '->':'').'('. |
86
|
|
|
|
|
|
|
($orig_args_as eq 'hash' ? '%args' : |
87
|
|
|
|
|
|
|
$orig_args_as eq 'hashref' ? '$args' : |
88
|
|
|
|
|
|
|
$orig_args_as eq 'array' ? '@args' : |
89
|
|
|
|
|
|
|
'$args').');', |
90
|
|
|
|
|
|
|
($src->{postamble} ? '}; # do' : ''), |
91
|
|
|
|
|
|
|
$src->{postamble}, |
92
|
|
|
|
|
|
|
'}; # sub', |
93
|
|
|
|
|
|
|
); |
94
|
53
|
100
|
100
|
|
|
1912
|
$sub = eval $eval_src; |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
95
|
|
|
|
|
|
|
my $eval_err = $@; |
96
|
53
|
|
|
10
|
|
5397
|
ok(!$eval_err, "embed code compiles ok") or do { |
|
8
|
|
|
10
|
|
59
|
|
|
8
|
|
|
1
|
|
14
|
|
|
8
|
|
|
1
|
|
40
|
|
|
8
|
|
|
1
|
|
515
|
|
|
8
|
|
|
1
|
|
14
|
|
|
8
|
|
|
1
|
|
2012
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
|
|
|
|
1
|
|
|
|
97
|
53
|
|
|
|
|
216
|
diag "eval err: ", $eval_err; |
98
|
53
|
50
|
|
|
|
199
|
diag "eval source: ", $eval_src; |
99
|
1
|
|
|
|
|
289
|
return; |
100
|
1
|
|
|
|
|
7
|
}; |
101
|
1
|
|
|
|
|
2
|
diag "eval source: ", $eval_src |
102
|
|
|
|
|
|
|
if $ENV{LOG_PERINCI_WRAPPER_CODE}; |
103
|
|
|
|
|
|
|
} else { |
104
|
53
|
50
|
|
|
|
19767
|
|
105
|
|
|
|
|
|
|
# check that we don't generate comment after code (unless it |
106
|
|
|
|
|
|
|
# uses '##' instead of '#'), because this makes cutting comments |
107
|
|
|
|
|
|
|
# easier. XXX this is using a simple regex and misses some. |
108
|
|
|
|
|
|
|
for my $line (split /^/, $wrap_res->[2]{source}) { |
109
|
|
|
|
|
|
|
if ($line =~ /(.*?)\s+#\s+(.*)/) { |
110
|
53
|
|
|
|
|
676
|
my ($before, $after) = ($1, $2); |
111
|
2539
|
100
|
|
|
|
4675
|
next unless $before =~ /\S/; |
112
|
400
|
|
|
|
|
1119
|
ok 0; diag "Source code contains comment line after some code '$line' (if you do this, you must use ## instead of # to help ease removing comment lines (e.g. in Dist::Zilla::Plugin::Rinci::Wrap))"; |
113
|
400
|
50
|
|
|
|
790
|
} |
114
|
1
|
|
|
|
|
2
|
} |
|
1
|
|
|
|
|
4
|
|
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
$sub = $wrap_res->[2]{sub}; |
117
|
|
|
|
|
|
|
} |
118
|
53
|
|
|
|
|
301
|
|
119
|
|
|
|
|
|
|
# testing a single sub call |
120
|
|
|
|
|
|
|
my $call_argsr = $test_args{call_argsr}; |
121
|
|
|
|
|
|
|
my $call_res; |
122
|
105
|
|
|
|
|
200
|
if ($call_argsr) { |
123
|
105
|
|
|
|
|
454
|
eval { $call_res = $sub->(@$call_argsr) }; |
124
|
105
|
100
|
|
|
|
227
|
my $call_eval_err = $@; |
125
|
11
|
|
|
|
|
16
|
if ($test_args{call_dies}) { |
|
11
|
|
|
|
|
249
|
|
126
|
11
|
|
|
|
|
94
|
ok($call_eval_err, "call dies"); |
127
|
11
|
50
|
|
|
|
54
|
if ($test_args{call_die_message}) { |
128
|
1
|
|
|
|
|
513
|
like($call_eval_err, $test_args{call_die_message}, |
129
|
1
|
0
|
|
|
|
6
|
"call die message"); |
130
|
|
|
|
|
|
|
} |
131
|
1
|
|
|
|
|
2
|
return; |
132
|
|
|
|
|
|
|
} else { |
133
|
1
|
|
|
|
|
5
|
ok(!$call_eval_err, "call doesn't die") |
134
|
|
|
|
|
|
|
or diag $call_eval_err; |
135
|
11
|
50
|
|
|
|
101
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
if (defined $test_args{call_status}) { |
138
|
|
|
|
|
|
|
is(ref($call_res), 'ARRAY', 'call res is array') |
139
|
11
|
50
|
|
|
|
3408
|
or diag "call res = ", explain($call_res); |
140
|
11
|
50
|
|
|
|
656
|
is($call_res->[0], $test_args{call_status}, |
141
|
|
|
|
|
|
|
"call status is $test_args{call_status}") |
142
|
|
|
|
|
|
|
or diag "call res = ", explain($call_res); |
143
|
11
|
50
|
|
|
|
3532
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
if (exists $test_args{call_res}) { |
146
|
|
|
|
|
|
|
is_deeply($call_res, $test_args{call_res}, |
147
|
11
|
100
|
|
|
|
3483
|
"call res") |
148
|
|
|
|
|
|
|
or diag explain $call_res; |
149
|
3
|
50
|
|
|
|
18
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
if (exists $test_args{call_actual_res}) { |
152
|
|
|
|
|
|
|
is_deeply($call_res->[2], $test_args{call_actual_res}, |
153
|
11
|
50
|
|
|
|
1393
|
"call actual res") |
154
|
|
|
|
|
|
|
or diag explain $call_res->[2]; |
155
|
1
|
0
|
|
|
|
2
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
if (exists $test_args{call_actual_res_re}) { |
158
|
|
|
|
|
|
|
like($call_res->[2], $test_args{call_actual_res_re}, |
159
|
11
|
100
|
|
|
|
34
|
"call actual res"); |
160
|
|
|
|
|
|
|
} |
161
|
3
|
|
|
|
|
81
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# testing multiple sub calls |
164
|
|
|
|
|
|
|
if ($test_args{calls}) { |
165
|
|
|
|
|
|
|
my $i = 0; |
166
|
105
|
100
|
|
|
|
932
|
for my $call (@{$test_args{calls}}) { |
167
|
67
|
|
|
|
|
443
|
$i++; |
168
|
66
|
|
|
|
|
93
|
subtest "call #$i: ".($call->{name} // "") => sub { |
|
66
|
|
|
|
|
151
|
|
169
|
170
|
|
|
|
|
189280
|
my $res; |
170
|
|
|
|
|
|
|
eval { $res = $sub->(@{$call->{argsr}}) }; |
171
|
170
|
|
|
|
|
164678
|
my $eval_err = $@; |
172
|
170
|
|
|
|
|
300
|
if ($call->{dies}) { |
|
170
|
|
|
|
|
280
|
|
|
170
|
|
|
|
|
4581
|
|
173
|
170
|
|
|
|
|
343
|
ok($eval_err, "dies"); |
174
|
170
|
100
|
|
|
|
410
|
if ($call->{die_message}) { |
175
|
2
|
|
|
|
|
7
|
like($eval_err, $call->{die_message}, |
176
|
2
|
50
|
|
|
|
770
|
"die message"); |
177
|
|
|
|
|
|
|
} |
178
|
0
|
|
|
|
|
0
|
return; |
179
|
|
|
|
|
|
|
} else { |
180
|
2
|
|
|
|
|
4
|
ok(!$eval_err, "doesn't die") |
181
|
|
|
|
|
|
|
or diag $eval_err; |
182
|
168
|
50
|
|
|
|
469
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
if (defined $call->{status}) { |
185
|
|
|
|
|
|
|
is(ref($res), 'ARRAY', 'res is array') |
186
|
168
|
100
|
|
|
|
66423
|
or diag "res = ", explain($res); |
187
|
154
|
50
|
|
|
|
516
|
is($res->[0], $call->{status}, |
188
|
|
|
|
|
|
|
"status is $call->{status}") |
189
|
|
|
|
|
|
|
or diag "res = ", explain($res); |
190
|
154
|
50
|
|
|
|
62699
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
if (exists $call->{res}) { |
193
|
|
|
|
|
|
|
is_deeply($res, $call->{res}, "res") |
194
|
168
|
100
|
|
|
|
61914
|
or diag explain $res; |
195
|
16
|
50
|
|
|
|
59
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
if (exists $call->{actual_res}) { |
198
|
|
|
|
|
|
|
is_deeply($res->[2], $call->{actual_res}, "actual res") |
199
|
168
|
100
|
|
|
|
12253
|
or diag explain $res->[2]; |
200
|
32
|
50
|
|
|
|
97
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
if (exists $call->{actual_res_re}) { |
203
|
|
|
|
|
|
|
like($res->[2], $call->{actual_res_re}, |
204
|
168
|
100
|
|
|
|
13045
|
"actual res re"); |
205
|
|
|
|
|
|
|
} |
206
|
4
|
|
|
|
|
13
|
}; # subtest call #$i |
207
|
|
|
|
|
|
|
} |
208
|
170
|
|
100
|
|
|
1642
|
} # if calls |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
if ($test_args{posttest}) { |
211
|
|
|
|
|
|
|
$test_args{posttest}->($wrap_res, $call_res, $sub); |
212
|
104
|
100
|
|
|
|
115959
|
} |
213
|
24
|
|
|
|
|
85
|
|
214
|
|
|
|
|
|
|
done_testing(); |
215
|
|
|
|
|
|
|
|
216
|
104
|
|
|
|
|
18700
|
}; # subtest |
217
|
|
|
|
|
|
|
} # for $wrapper_type |
218
|
114
|
|
|
|
|
1404
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
1; |
221
|
|
|
|
|
|
|
# ABSTRACT: Provide test_wrap() to test wrapper |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=pod |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=encoding UTF-8 |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
=head1 NAME |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
Test::Perinci::Sub::Wrapper - Provide test_wrap() to test wrapper |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=head1 VERSION |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
This document describes version 0.852 of Test::Perinci::Sub::Wrapper (from Perl distribution Perinci-Sub-Wrapper), released on 2021-08-01. |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=for Pod::Coverage test_wrap |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=head1 HOMEPAGE |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
Please visit the project's homepage at L<https://metacpan.org/release/Perinci-Sub-Wrapper>. |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
=head1 SOURCE |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
Source repository is at L<https://github.com/perlancar/perl-Perinci-Sub-Wrapper>. |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
=head1 BUGS |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perinci-Sub-Wrapper> |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
When submitting a bug or request, please include a test-file or a |
251
|
|
|
|
|
|
|
patch to an existing test-file that illustrates the bug or desired |
252
|
|
|
|
|
|
|
feature. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=head1 AUTHOR |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
perlancar <perlancar@cpan.org> |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
This software is copyright (c) 2021, 2019, 2017, 2016, 2015, 2014, 2013, 2012, 2011 by perlancar@cpan.org. |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
263
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=cut |