line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# t/test.pl - most of Test::More functionality without the fuss |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
# NOTE: |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# It's best to not features found only in more modern Perls here, as some cpan |
8
|
|
|
|
|
|
|
# distributions copy this file and operate on older Perls. Similarly keep |
9
|
|
|
|
|
|
|
# things simple as this may be run under fairly broken circumstances. For |
10
|
|
|
|
|
|
|
# example, increment ($x++) has a certain amount of cleverness for things like |
11
|
|
|
|
|
|
|
# |
12
|
|
|
|
|
|
|
# $x = 'zz'; |
13
|
|
|
|
|
|
|
# $x++; # $x eq 'aaa'; |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# This stands more chance of breaking than just a simple |
16
|
|
|
|
|
|
|
# |
17
|
|
|
|
|
|
|
# $x = $x + 1 |
18
|
|
|
|
|
|
|
# |
19
|
|
|
|
|
|
|
# In this file, we use the latter "Baby Perl" approach, and increment |
20
|
|
|
|
|
|
|
# will be worked over by t/op/inc.t |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
$Level = 1; |
23
|
|
|
|
|
|
|
my $test = 1; |
24
|
|
|
|
|
|
|
my $planned; |
25
|
|
|
|
|
|
|
my $noplan; |
26
|
|
|
|
|
|
|
my $Perl; # Safer version of $^X set by which_perl() |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC |
29
|
|
|
|
|
|
|
$::IS_ASCII = ord 'A' == 65; |
30
|
|
|
|
|
|
|
$::IS_EBCDIC = ord 'A' == 193; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
$TODO = 0; |
33
|
|
|
|
|
|
|
$NO_ENDING = 0; |
34
|
|
|
|
|
|
|
$Tests_Are_Passing = 1; |
35
|
|
|
|
|
|
|
|
36
|
0
|
|
|
|
|
0
|
BEGIN { |
37
|
1
|
|
|
1
|
|
14037
|
eval 'sub OPV () {'.$].'}'; |
38
|
|
|
|
|
|
|
sub OPV(); |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# Use this instead of print to avoid interference while testing globals. |
42
|
|
|
|
|
|
|
sub _print { |
43
|
172
|
|
|
172
|
|
697
|
local($\, $", $,) = (undef, ' ', ''); |
44
|
172
|
|
|
|
|
669
|
print STDOUT @_; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub _print_stderr { |
48
|
0
|
|
|
0
|
|
0
|
local($\, $", $,) = (undef, ' ', ''); |
49
|
0
|
|
|
|
|
0
|
print STDERR @_; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub plan { |
53
|
1
|
|
|
1
|
|
9
|
my $n; |
54
|
1
|
50
|
|
|
|
5
|
if (@_ == 1) { |
55
|
1
|
|
|
|
|
3
|
$n = shift; |
56
|
1
|
50
|
|
|
|
5
|
if ($n eq 'no_plan') { |
57
|
1
|
|
|
|
|
2
|
undef $n; |
58
|
1
|
|
|
|
|
3
|
$noplan = 1; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
} else { |
61
|
0
|
|
|
|
|
0
|
my %plan = @_; |
62
|
0
|
0
|
|
|
|
0
|
$plan{skip_all} and skip_all($plan{skip_all}); |
63
|
0
|
|
|
|
|
0
|
$n = $plan{tests}; |
64
|
|
|
|
|
|
|
} |
65
|
1
|
50
|
|
|
|
5
|
_print "1..$n\n" unless $noplan; |
66
|
1
|
|
|
|
|
3
|
$planned = $n; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# Set the plan at the end. See Test::More::done_testing. |
71
|
|
|
|
|
|
|
sub done_testing { |
72
|
0
|
|
|
0
|
|
0
|
my $n = $test - 1; |
73
|
0
|
0
|
|
|
|
0
|
$n = shift if @_; |
74
|
|
|
|
|
|
|
|
75
|
0
|
|
|
|
|
0
|
_print "1..$n\n"; |
76
|
0
|
|
|
|
|
0
|
$planned = $n; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
END { |
81
|
1
|
|
|
1
|
|
3
|
my $ran = $test - 1; |
82
|
1
|
50
|
|
|
|
11
|
if (!$NO_ENDING) { |
83
|
1
|
50
|
33
|
|
|
9
|
if (defined $planned && $planned != $ran) { |
|
|
50
|
|
|
|
|
|
84
|
0
|
|
|
|
|
0
|
_print_stderr |
85
|
|
|
|
|
|
|
"# Looks like you planned $planned tests but ran $ran.\n"; |
86
|
|
|
|
|
|
|
} elsif ($noplan) { |
87
|
1
|
|
|
|
|
11
|
_print "1..$ran\n"; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
sub _diag { |
93
|
0
|
0
|
|
0
|
|
0
|
return unless @_; |
94
|
0
|
|
|
|
|
0
|
my @mess = _comment(@_); |
95
|
0
|
0
|
|
|
|
0
|
$TODO ? _print(@mess) : _print_stderr(@mess); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
# Use this instead of "print STDERR" when outputting failure diagnostic |
99
|
|
|
|
|
|
|
# messages |
100
|
|
|
|
|
|
|
sub diag { |
101
|
0
|
|
|
0
|
|
0
|
_diag(@_); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Use this instead of "print" when outputting informational messages |
105
|
|
|
|
|
|
|
sub note { |
106
|
167
|
100
|
|
167
|
|
341
|
return unless @_; |
107
|
1
|
|
|
|
|
4
|
_print( _comment(@_) ); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub is_miniperl { |
111
|
0
|
|
|
0
|
|
0
|
return !defined &DynaLoader::boot_DynaLoader; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub set_up_inc { |
115
|
|
|
|
|
|
|
# Don’t clobber @INC under miniperl |
116
|
0
|
0
|
|
0
|
|
0
|
@INC = () unless is_miniperl; |
117
|
0
|
|
|
|
|
0
|
unshift @INC, @_; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub _comment { |
121
|
1
|
50
|
|
|
|
8
|
return map { /^#/ ? "$_\n" : "# $_\n" } |
122
|
1
|
|
|
1
|
|
3
|
map { split /\n/ } @_; |
|
1
|
|
|
|
|
5
|
|
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub _have_dynamic_extension { |
126
|
0
|
|
|
0
|
|
0
|
my $extension = shift; |
127
|
0
|
0
|
|
|
|
0
|
unless (eval {require Config; 1}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
128
|
0
|
|
|
|
|
0
|
warn "test.pl had problems loading Config: $@"; |
129
|
0
|
|
|
|
|
0
|
return 1; |
130
|
|
|
|
|
|
|
} |
131
|
0
|
|
|
|
|
0
|
$extension =~ s!::!/!g; |
132
|
0
|
0
|
|
|
|
0
|
return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub skip_all { |
136
|
0
|
0
|
|
0
|
|
0
|
if (@_) { |
137
|
0
|
|
|
|
|
0
|
_print "1..0 # Skip @_\n"; |
138
|
|
|
|
|
|
|
} else { |
139
|
0
|
|
|
|
|
0
|
_print "1..0\n"; |
140
|
|
|
|
|
|
|
} |
141
|
0
|
|
|
|
|
0
|
exit(0); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
sub skip_all_if_miniperl { |
145
|
0
|
0
|
|
0
|
|
0
|
skip_all(@_) if is_miniperl(); |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub skip_all_without_dynamic_extension { |
149
|
0
|
|
|
0
|
|
0
|
my ($extension) = @_; |
150
|
0
|
0
|
|
|
|
0
|
skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); |
151
|
0
|
0
|
|
|
|
0
|
return if &_have_dynamic_extension; |
152
|
0
|
|
|
|
|
0
|
skip_all("$extension was not built"); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub skip_all_without_perlio { |
156
|
0
|
0
|
|
0
|
|
0
|
skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub skip_all_without_config { |
160
|
0
|
0
|
|
0
|
|
0
|
unless (eval {require Config; 1}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
161
|
0
|
|
|
|
|
0
|
warn "test.pl had problems loading Config: $@"; |
162
|
0
|
|
|
|
|
0
|
return; |
163
|
|
|
|
|
|
|
} |
164
|
0
|
|
|
|
|
0
|
foreach (@_) { |
165
|
0
|
0
|
|
|
|
0
|
next if $Config::Config{$_}; |
166
|
0
|
|
|
|
|
0
|
my $key = $_; # Need to copy, before trying to modify. |
167
|
0
|
|
|
|
|
0
|
$key =~ s/^use//; |
168
|
0
|
|
|
|
|
0
|
$key =~ s/^d_//; |
169
|
0
|
|
|
|
|
0
|
skip_all("no $key"); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub skip_all_without_unicode_tables { # (but only under miniperl) |
174
|
0
|
0
|
|
0
|
|
0
|
if (is_miniperl()) { |
175
|
0
|
0
|
|
|
|
0
|
skip_all_if_miniperl("Unicode tables not built yet") |
176
|
|
|
|
|
|
|
unless eval 'require "unicore/Heavy.pl"'; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub find_git_or_skip { |
181
|
0
|
|
|
0
|
|
0
|
my ($source_dir, $reason); |
182
|
0
|
0
|
0
|
|
|
0
|
if (-d '.git') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
183
|
0
|
|
|
|
|
0
|
$source_dir = '.'; |
184
|
|
|
|
|
|
|
} elsif (-l 'MANIFEST' && -l 'AUTHORS') { |
185
|
0
|
|
|
|
|
0
|
my $where = readlink 'MANIFEST'; |
186
|
0
|
0
|
|
|
|
0
|
die "Can't readling MANIFEST: $!" unless defined $where; |
187
|
0
|
0
|
|
|
|
0
|
die "Confusing symlink target for MANIFEST, '$where'" |
188
|
|
|
|
|
|
|
unless $where =~ s!/MANIFEST\z!!; |
189
|
0
|
0
|
|
|
|
0
|
if (-d "$where/.git") { |
190
|
|
|
|
|
|
|
# Looks like we are in a symlink tree |
191
|
0
|
0
|
|
|
|
0
|
if (exists $ENV{GIT_DIR}) { |
192
|
0
|
|
|
|
|
0
|
diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); |
193
|
|
|
|
|
|
|
} else { |
194
|
0
|
|
|
|
|
0
|
note("Found source tree at $where, setting \$ENV{GIT_DIR}"); |
195
|
0
|
|
|
|
|
0
|
$ENV{GIT_DIR} = "$where/.git"; |
196
|
|
|
|
|
|
|
} |
197
|
0
|
|
|
|
|
0
|
$source_dir = $where; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
} elsif (exists $ENV{GIT_DIR}) { |
200
|
0
|
|
|
|
|
0
|
my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; |
201
|
0
|
|
|
|
|
0
|
my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; |
202
|
0
|
|
|
|
|
0
|
chomp $out; |
203
|
0
|
0
|
|
|
|
0
|
if($out eq $commit) { |
204
|
0
|
|
|
|
|
0
|
$source_dir = '.' |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
} |
207
|
0
|
0
|
|
|
|
0
|
if ($source_dir) { |
208
|
0
|
|
|
|
|
0
|
my $version_string = `git --version`; |
209
|
0
|
0
|
0
|
|
|
0
|
if (defined $version_string |
210
|
|
|
|
|
|
|
&& $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { |
211
|
0
|
0
|
|
|
|
0
|
return $source_dir if eval "v$1 ge v1.5.0"; |
212
|
|
|
|
|
|
|
# If you have earlier than 1.5.0 and it works, change this test |
213
|
0
|
|
|
|
|
0
|
$reason = "in git checkout, but git version '$1$2' too old"; |
214
|
|
|
|
|
|
|
} else { |
215
|
0
|
|
|
|
|
0
|
$reason = "in git checkout, but cannot run git"; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} else { |
218
|
0
|
|
|
|
|
0
|
$reason = 'not being run from a git checkout'; |
219
|
|
|
|
|
|
|
} |
220
|
0
|
0
|
0
|
|
|
0
|
skip_all($reason) if $_[0] && $_[0] eq 'all'; |
221
|
0
|
|
|
|
|
0
|
skip($reason, @_); |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub BAIL_OUT { |
225
|
0
|
|
|
0
|
|
0
|
my ($reason) = @_; |
226
|
0
|
|
|
|
|
0
|
_print("Bail out! $reason\n"); |
227
|
0
|
|
|
|
|
0
|
exit 255; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub _ok { |
231
|
167
|
|
|
167
|
|
412
|
my ($pass, $where, $name, @mess) = @_; |
232
|
|
|
|
|
|
|
# Do not try to microoptimize by factoring out the "not ". |
233
|
|
|
|
|
|
|
# VMS will avenge. |
234
|
167
|
|
|
|
|
204
|
my $out; |
235
|
167
|
50
|
|
|
|
288
|
if ($name) { |
236
|
|
|
|
|
|
|
# escape out '#' or it will interfere with '# skip' and such |
237
|
167
|
|
|
|
|
326
|
$name =~ s/#/\\#/g; |
238
|
167
|
50
|
|
|
|
449
|
$out = $pass ? "ok $test - $name" : "not ok $test - $name"; |
239
|
|
|
|
|
|
|
} else { |
240
|
0
|
0
|
|
|
|
0
|
$out = $pass ? "ok $test" : "not ok $test"; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
167
|
50
|
|
|
|
277
|
if ($TODO) { |
244
|
0
|
|
|
|
|
0
|
$out = $out . " # TODO $TODO"; |
245
|
|
|
|
|
|
|
} else { |
246
|
167
|
50
|
|
|
|
332
|
$Tests_Are_Passing = 0 unless $pass; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
167
|
|
|
|
|
456
|
_print "$out\n"; |
250
|
|
|
|
|
|
|
|
251
|
167
|
50
|
|
|
|
340
|
if ($pass) { |
252
|
167
|
|
|
|
|
326
|
note @mess; # Ensure that the message is properly escaped. |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
else { |
255
|
0
|
|
|
|
|
0
|
my $msg = "# Failed test $test - "; |
256
|
0
|
0
|
|
|
|
0
|
$msg.= "$name " if $name; |
257
|
0
|
|
|
|
|
0
|
$msg .= "$where\n"; |
258
|
0
|
|
|
|
|
0
|
_diag $msg; |
259
|
0
|
|
|
|
|
0
|
_diag @mess; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
167
|
|
|
|
|
248
|
$test = $test + 1; # don't use ++ |
263
|
|
|
|
|
|
|
|
264
|
167
|
|
|
|
|
582
|
return $pass; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
sub _where { |
268
|
168
|
|
|
168
|
|
1093
|
my @caller = caller($Level); |
269
|
168
|
|
|
|
|
746
|
return "at $caller[1] line $caller[2]"; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# DON'T use this for matches. Use like() instead. |
273
|
|
|
|
|
|
|
sub ok ($@) { |
274
|
53
|
|
|
53
|
|
9080
|
my ($pass, $name, @mess) = @_; |
275
|
53
|
|
|
|
|
104
|
_ok($pass, _where(), $name, @mess); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
sub _q { |
279
|
0
|
|
|
0
|
|
0
|
my $x = shift; |
280
|
0
|
0
|
|
|
|
0
|
return 'undef' unless defined $x; |
281
|
0
|
|
|
|
|
0
|
my $q = $x; |
282
|
0
|
|
|
|
|
0
|
$q =~ s/\\/\\\\/g; |
283
|
0
|
|
|
|
|
0
|
$q =~ s/'/\\'/g; |
284
|
0
|
|
|
|
|
0
|
return "'$q'"; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub _qq { |
288
|
0
|
|
|
0
|
|
0
|
my $x = shift; |
289
|
0
|
0
|
|
|
|
0
|
return defined $x ? '"' . display ($x) . '"' : 'undef'; |
290
|
|
|
|
|
|
|
}; |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
# keys are the codes \n etc map to, values are 2 char strings such as \n |
293
|
|
|
|
|
|
|
my %backslash_escape; |
294
|
|
|
|
|
|
|
foreach my $x (split //, 'nrtfa\\\'"') { |
295
|
|
|
|
|
|
|
$backslash_escape{ord eval "\"\\$x\""} = "\\$x"; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
# A way to display scalars containing control characters and Unicode. |
298
|
|
|
|
|
|
|
# Trying to avoid setting $_, or relying on local $_ to work. |
299
|
|
|
|
|
|
|
sub display { |
300
|
0
|
|
|
0
|
|
0
|
my @result; |
301
|
0
|
|
|
|
|
0
|
foreach my $x (@_) { |
302
|
0
|
0
|
0
|
|
|
0
|
if (defined $x and not ref $x) { |
303
|
0
|
|
|
|
|
0
|
my $y = ''; |
304
|
0
|
|
|
|
|
0
|
foreach my $c (unpack((OPV ge '5.009002' ? "W*" : "U*"), $x)) { |
305
|
0
|
0
|
|
|
|
0
|
if ($c > 255) { |
|
|
0
|
|
|
|
|
|
306
|
0
|
|
|
|
|
0
|
$y = $y . sprintf "\\x{%x}", $c; |
307
|
|
|
|
|
|
|
} elsif ($backslash_escape{$c}) { |
308
|
0
|
|
|
|
|
0
|
$y = $y . $backslash_escape{$c}; |
309
|
|
|
|
|
|
|
} else { |
310
|
0
|
|
|
|
|
0
|
my $z = chr $c; # Maybe we can get away with a literal... |
311
|
|
|
|
|
|
|
|
312
|
0
|
0
|
|
|
|
0
|
if ($z !~ /[^[:^print:][:^ascii:]]/) { |
313
|
|
|
|
|
|
|
# The pattern above is equivalent (by de Morgan's |
314
|
|
|
|
|
|
|
# laws) to: |
315
|
|
|
|
|
|
|
# $z !~ /(?[ [:print:] & [:ascii:] ])/ |
316
|
|
|
|
|
|
|
# or, $z is not an ascii printable character |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# Use octal for characters with small ordinals that |
319
|
|
|
|
|
|
|
# are traditionally expressed as octal: the controls |
320
|
|
|
|
|
|
|
# below space, which on EBCDIC are almost all the |
321
|
|
|
|
|
|
|
# controls, but on ASCII don't include DEL nor the C1 |
322
|
|
|
|
|
|
|
# controls. |
323
|
0
|
0
|
|
|
|
0
|
if ($c < ord " ") { |
324
|
0
|
|
|
|
|
0
|
$z = sprintf "\\%03o", $c; |
325
|
|
|
|
|
|
|
} else { |
326
|
0
|
|
|
|
|
0
|
$z = sprintf "\\x{%x}", $c; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
0
|
|
|
|
|
0
|
$y = $y . $z; |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
} |
332
|
0
|
|
|
|
|
0
|
$x = $y; |
333
|
|
|
|
|
|
|
} |
334
|
0
|
0
|
|
|
|
0
|
return $x unless wantarray; |
335
|
0
|
|
|
|
|
0
|
push @result, $x; |
336
|
|
|
|
|
|
|
} |
337
|
0
|
|
|
|
|
0
|
return @result; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
sub is ($$@) { |
341
|
46
|
|
|
46
|
|
1516
|
my ($got, $expected, $name, @mess) = @_; |
342
|
|
|
|
|
|
|
|
343
|
46
|
|
|
|
|
75
|
my $pass; |
344
|
46
|
50
|
33
|
|
|
190
|
if( !defined $got || !defined $expected ) { |
345
|
|
|
|
|
|
|
# undef only matches undef |
346
|
0
|
|
0
|
|
|
0
|
$pass = !defined $got && !defined $expected; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
else { |
349
|
46
|
|
|
|
|
139
|
$pass = $got eq $expected; |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
46
|
50
|
|
|
|
108
|
unless ($pass) { |
353
|
0
|
|
|
|
|
0
|
unshift(@mess, "# got "._qq($got)."\n", |
354
|
|
|
|
|
|
|
"# expected "._qq($expected)."\n"); |
355
|
|
|
|
|
|
|
} |
356
|
46
|
|
|
|
|
104
|
_ok($pass, _where(), $name, @mess); |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub isnt ($$@) { |
360
|
3
|
|
|
3
|
|
36
|
my ($got, $isnt, $name, @mess) = @_; |
361
|
|
|
|
|
|
|
|
362
|
3
|
|
|
|
|
6
|
my $pass; |
363
|
3
|
50
|
33
|
|
|
17
|
if( !defined $got || !defined $isnt ) { |
364
|
|
|
|
|
|
|
# undef only matches undef |
365
|
3
|
|
33
|
|
|
8
|
$pass = defined $got || defined $isnt; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
else { |
368
|
0
|
|
|
|
|
0
|
$pass = $got ne $isnt; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
3
|
50
|
|
|
|
8
|
unless( $pass ) { |
372
|
0
|
|
|
|
|
0
|
unshift(@mess, "# it should not be "._qq($got)."\n", |
373
|
|
|
|
|
|
|
"# but it is.\n"); |
374
|
|
|
|
|
|
|
} |
375
|
3
|
|
|
|
|
8
|
_ok($pass, _where(), $name, @mess); |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
sub cmp_ok ($$$@) { |
379
|
0
|
|
|
0
|
|
0
|
my($got, $type, $expected, $name, @mess) = @_; |
380
|
|
|
|
|
|
|
|
381
|
0
|
|
|
|
|
0
|
my $pass; |
382
|
|
|
|
|
|
|
{ |
383
|
0
|
|
|
|
|
0
|
local $^W = 0; |
|
0
|
|
|
|
|
0
|
|
384
|
0
|
|
|
|
|
0
|
local($@,$!); # don't interfere with $@ |
385
|
|
|
|
|
|
|
# eval() sometimes resets $! |
386
|
0
|
|
|
|
|
0
|
$pass = eval "\$got $type \$expected"; |
387
|
|
|
|
|
|
|
} |
388
|
0
|
0
|
|
|
|
0
|
unless ($pass) { |
389
|
|
|
|
|
|
|
# It seems Irix long doubles can have 2147483648 and 2147483648 |
390
|
|
|
|
|
|
|
# that stringify to the same thing but are actually numerically |
391
|
|
|
|
|
|
|
# different. Display the numbers if $type isn't a string operator, |
392
|
|
|
|
|
|
|
# and the numbers are stringwise the same. |
393
|
|
|
|
|
|
|
# (all string operators have alphabetic names, so tr/a-z// is true) |
394
|
|
|
|
|
|
|
# This will also show numbers for some unneeded cases, but will |
395
|
|
|
|
|
|
|
# definitely be helpful for things such as == and <= that fail |
396
|
0
|
0
|
0
|
|
|
0
|
if ($got eq $expected and $type !~ tr/a-z//) { |
397
|
0
|
|
|
|
|
0
|
unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; |
398
|
|
|
|
|
|
|
} |
399
|
0
|
|
|
|
|
0
|
unshift(@mess, "# got "._qq($got)."\n", |
400
|
|
|
|
|
|
|
"# expected $type "._qq($expected)."\n"); |
401
|
|
|
|
|
|
|
} |
402
|
0
|
|
|
|
|
0
|
_ok($pass, _where(), $name, @mess); |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
# Check that $got is within $range of $expected |
406
|
|
|
|
|
|
|
# if $range is 0, then check it's exact |
407
|
|
|
|
|
|
|
# else if $expected is 0, then $range is an absolute value |
408
|
|
|
|
|
|
|
# otherwise $range is a fractional error. |
409
|
|
|
|
|
|
|
# Here $range must be numeric, >= 0 |
410
|
|
|
|
|
|
|
# Non numeric ranges might be a useful future extension. (eg %) |
411
|
|
|
|
|
|
|
sub within ($$$@) { |
412
|
0
|
|
|
0
|
|
0
|
my ($got, $expected, $range, $name, @mess) = @_; |
413
|
0
|
|
|
|
|
0
|
my $pass; |
414
|
0
|
0
|
0
|
|
|
0
|
if (!defined $got or !defined $expected or !defined $range) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# This is a fail, but doesn't need extra diagnostics |
416
|
|
|
|
|
|
|
} elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { |
417
|
|
|
|
|
|
|
# This is a fail |
418
|
0
|
|
|
|
|
0
|
unshift @mess, "# got, expected and range must be numeric\n"; |
419
|
|
|
|
|
|
|
} elsif ($range < 0) { |
420
|
|
|
|
|
|
|
# This is also a fail |
421
|
0
|
|
|
|
|
0
|
unshift @mess, "# range must not be negative\n"; |
422
|
|
|
|
|
|
|
} elsif ($range == 0) { |
423
|
|
|
|
|
|
|
# Within 0 is == |
424
|
0
|
|
|
|
|
0
|
$pass = $got == $expected; |
425
|
|
|
|
|
|
|
} elsif ($expected == 0) { |
426
|
|
|
|
|
|
|
# If expected is 0, treat range as absolute |
427
|
0
|
|
0
|
|
|
0
|
$pass = ($got <= $range) && ($got >= - $range); |
428
|
|
|
|
|
|
|
} else { |
429
|
0
|
|
|
|
|
0
|
my $diff = $got - $expected; |
430
|
0
|
|
|
|
|
0
|
$pass = abs ($diff / $expected) < $range; |
431
|
|
|
|
|
|
|
} |
432
|
0
|
0
|
|
|
|
0
|
unless ($pass) { |
433
|
0
|
0
|
|
|
|
0
|
if ($got eq $expected) { |
434
|
0
|
|
|
|
|
0
|
unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; |
435
|
|
|
|
|
|
|
} |
436
|
0
|
|
|
|
|
0
|
unshift@mess, "# got "._qq($got)."\n", |
437
|
|
|
|
|
|
|
"# expected "._qq($expected)." (within "._qq($range).")\n"; |
438
|
|
|
|
|
|
|
} |
439
|
0
|
|
|
|
|
0
|
_ok($pass, _where(), $name, @mess); |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# Note: this isn't quite as fancy as Test::More::like(). |
443
|
|
|
|
|
|
|
|
444
|
65
|
|
|
65
|
|
889
|
sub like ($$@) { like_yn (0,@_) }; # 0 for - |
445
|
0
|
|
|
0
|
|
0
|
sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub like_yn ($$$@) { |
448
|
65
|
|
|
65
|
|
161
|
my ($flip, undef, $expected, $name, @mess) = @_; |
449
|
65
|
|
|
|
|
83
|
my $pass; |
450
|
65
|
50
|
|
|
|
495
|
$pass = $_[1] =~ /$expected/ if !$flip; |
451
|
65
|
50
|
|
|
|
163
|
$pass = $_[1] !~ /$expected/ if $flip; |
452
|
65
|
50
|
|
|
|
122
|
unless ($pass) { |
453
|
0
|
0
|
|
|
|
0
|
unshift(@mess, "# got '$_[1]'\n", |
454
|
|
|
|
|
|
|
$flip |
455
|
|
|
|
|
|
|
? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); |
456
|
|
|
|
|
|
|
} |
457
|
65
|
|
|
|
|
110
|
local $Level = $Level + 1; |
458
|
65
|
|
|
|
|
132
|
_ok($pass, _where(), $name, @mess); |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
sub pass { |
462
|
0
|
|
|
0
|
|
0
|
_ok(1, '', @_); |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
sub fail { |
466
|
0
|
|
|
0
|
|
0
|
_ok(0, _where(), @_); |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub curr_test { |
470
|
0
|
0
|
|
0
|
|
0
|
$test = shift if @_; |
471
|
0
|
|
|
|
|
0
|
return $test; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
sub next_test { |
475
|
0
|
|
|
0
|
|
0
|
my $retval = $test; |
476
|
0
|
|
|
|
|
0
|
$test = $test + 1; # don't use ++ |
477
|
0
|
|
|
|
|
0
|
$retval; |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
# Note: can't pass multipart messages since we try to |
481
|
|
|
|
|
|
|
# be compatible with Test::More::skip(). |
482
|
|
|
|
|
|
|
sub skip { |
483
|
3
|
|
|
3
|
|
169
|
my $why = shift; |
484
|
3
|
50
|
|
|
|
15
|
my $n = @_ ? shift : 1; |
485
|
3
|
|
|
|
|
13
|
my $bad_swap; |
486
|
|
|
|
|
|
|
my $both_zero; |
487
|
|
|
|
|
|
|
{ |
488
|
3
|
|
|
|
|
6
|
local $^W = 0; |
|
3
|
|
|
|
|
23
|
|
489
|
3
|
|
33
|
|
|
24
|
$bad_swap = $why > 0 && $n == 0; |
490
|
3
|
|
33
|
|
|
39
|
$both_zero = $why == 0 && $n == 0; |
491
|
|
|
|
|
|
|
} |
492
|
3
|
50
|
33
|
|
|
57
|
if ($bad_swap || $both_zero || @_) { |
|
|
|
33
|
|
|
|
|
493
|
0
|
|
|
|
|
0
|
my $arg = "'$why', '$n'"; |
494
|
0
|
0
|
|
|
|
0
|
if (@_) { |
495
|
0
|
|
|
|
|
0
|
$arg .= join(", ", '', map { qq['$_'] } @_); |
|
0
|
|
|
|
|
0
|
|
496
|
|
|
|
|
|
|
} |
497
|
0
|
|
|
|
|
0
|
die qq[$0: expected skip(why, count), got skip($arg)\n]; |
498
|
|
|
|
|
|
|
} |
499
|
3
|
|
|
|
|
9
|
for (1..$n) { |
500
|
3
|
|
|
|
|
57
|
_print "ok $test # skip $why\n"; |
501
|
3
|
|
|
|
|
8
|
$test = $test + 1; |
502
|
|
|
|
|
|
|
} |
503
|
3
|
|
|
|
|
10
|
local $^W = 0; |
504
|
3
|
|
|
|
|
13
|
last SKIP; |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
sub skip_if_miniperl { |
508
|
0
|
0
|
|
0
|
|
0
|
skip(@_) if is_miniperl(); |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
sub skip_without_dynamic_extension { |
512
|
0
|
|
|
0
|
|
0
|
my $extension = shift; |
513
|
0
|
0
|
|
|
|
0
|
skip("no dynamic loading on miniperl, no extension $extension", @_) |
514
|
|
|
|
|
|
|
if is_miniperl(); |
515
|
0
|
0
|
|
|
|
0
|
return if &_have_dynamic_extension($extension); |
516
|
0
|
|
|
|
|
0
|
skip("extension $extension was not built", @_); |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
sub todo_skip { |
520
|
0
|
|
|
0
|
|
0
|
my $why = shift; |
521
|
0
|
0
|
|
|
|
0
|
my $n = @_ ? shift : 1; |
522
|
|
|
|
|
|
|
|
523
|
0
|
|
|
|
|
0
|
for (1..$n) { |
524
|
0
|
|
|
|
|
0
|
_print "not ok $test # TODO & SKIP $why\n"; |
525
|
0
|
|
|
|
|
0
|
$test = $test + 1; |
526
|
|
|
|
|
|
|
} |
527
|
0
|
|
|
|
|
0
|
local $^W = 0; |
528
|
0
|
|
|
|
|
0
|
last TODO; |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
sub eq_array { |
532
|
0
|
|
|
0
|
|
0
|
my ($ra, $rb) = @_; |
533
|
0
|
0
|
|
|
|
0
|
return 0 unless $#$ra == $#$rb; |
534
|
0
|
|
|
|
|
0
|
for my $i (0..$#$ra) { |
535
|
0
|
0
|
0
|
|
|
0
|
next if !defined $ra->[$i] && !defined $rb->[$i]; |
536
|
0
|
0
|
|
|
|
0
|
return 0 if !defined $ra->[$i]; |
537
|
0
|
0
|
|
|
|
0
|
return 0 if !defined $rb->[$i]; |
538
|
0
|
0
|
|
|
|
0
|
return 0 unless $ra->[$i] eq $rb->[$i]; |
539
|
|
|
|
|
|
|
} |
540
|
0
|
|
|
|
|
0
|
return 1; |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub eq_hash { |
544
|
0
|
|
|
0
|
|
0
|
my ($orig, $suspect) = @_; |
545
|
0
|
|
|
|
|
0
|
my $fail; |
546
|
0
|
|
|
|
|
0
|
while (my ($key, $value) = each %$suspect) { |
547
|
|
|
|
|
|
|
# Force a hash recompute if this perl's internals can cache the hash key. |
548
|
0
|
|
|
|
|
0
|
$key = "" . $key; |
549
|
0
|
0
|
|
|
|
0
|
if (exists $orig->{$key}) { |
550
|
0
|
0
|
0
|
|
|
0
|
if ( |
|
|
|
0
|
|
|
|
|
551
|
|
|
|
|
|
|
defined $orig->{$key} != defined $value |
552
|
|
|
|
|
|
|
|| (defined $value && $orig->{$key} ne $value) |
553
|
|
|
|
|
|
|
) { |
554
|
0
|
|
|
|
|
0
|
_print "# key ", _qq($key), " was ", _qq($orig->{$key}), |
555
|
|
|
|
|
|
|
" now ", _qq($value), "\n"; |
556
|
0
|
|
|
|
|
0
|
$fail = 1; |
557
|
|
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
} else { |
559
|
0
|
|
|
|
|
0
|
_print "# key ", _qq($key), " is ", _qq($value), |
560
|
|
|
|
|
|
|
", not in original.\n"; |
561
|
0
|
|
|
|
|
0
|
$fail = 1; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
} |
564
|
0
|
|
|
|
|
0
|
foreach (keys %$orig) { |
565
|
|
|
|
|
|
|
# Force a hash recompute if this perl's internals can cache the hash key. |
566
|
0
|
|
|
|
|
0
|
$_ = "" . $_; |
567
|
0
|
0
|
|
|
|
0
|
next if (exists $suspect->{$_}); |
568
|
0
|
|
|
|
|
0
|
_print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; |
569
|
0
|
|
|
|
|
0
|
$fail = 1; |
570
|
|
|
|
|
|
|
} |
571
|
0
|
|
|
|
|
0
|
!$fail; |
572
|
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# We only provide a subset of the Test::More functionality. |
575
|
|
|
|
|
|
|
sub require_ok ($) { |
576
|
0
|
|
|
0
|
|
0
|
my ($require) = @_; |
577
|
0
|
0
|
|
|
|
0
|
if ($require =~ tr/[A-Za-z0-9:.]//c) { |
578
|
0
|
|
|
|
|
0
|
fail("Invalid character in \"$require\", passed to require_ok"); |
579
|
|
|
|
|
|
|
} else { |
580
|
0
|
|
|
|
|
0
|
eval <
|
581
|
|
|
|
|
|
|
require $require; |
582
|
|
|
|
|
|
|
REQUIRE_OK |
583
|
0
|
|
|
|
|
0
|
is($@, '', _where(), "require $require"); |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
sub use_ok ($) { |
588
|
1
|
|
|
1
|
|
6
|
my ($use) = @_; |
589
|
1
|
50
|
|
|
|
4
|
if ($use =~ tr/[A-Za-z0-9:.]//c) { |
590
|
0
|
|
|
|
|
0
|
fail("Invalid character in \"$use\", passed to use"); |
591
|
|
|
|
|
|
|
} else { |
592
|
1
|
|
|
1
|
|
10
|
eval <
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
41
|
|
|
1
|
|
|
|
|
55
|
|
593
|
|
|
|
|
|
|
use $use; |
594
|
|
|
|
|
|
|
USE_OK |
595
|
1
|
|
|
|
|
6
|
is($@, '', _where(), "use $use"); |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# runperl - Runs a separate perl interpreter and returns its output. |
600
|
|
|
|
|
|
|
# Arguments : |
601
|
|
|
|
|
|
|
# switches => [ command-line switches ] |
602
|
|
|
|
|
|
|
# nolib => 1 # don't use -I../lib (included by default) |
603
|
|
|
|
|
|
|
# non_portable => Don't warn if a one liner contains quotes |
604
|
|
|
|
|
|
|
# prog => one-liner (avoid quotes) |
605
|
|
|
|
|
|
|
# progs => [ multi-liner (avoid quotes) ] |
606
|
|
|
|
|
|
|
# progfile => perl script |
607
|
|
|
|
|
|
|
# stdin => string to feed the stdin (or undef to redirect from /dev/null) |
608
|
|
|
|
|
|
|
# stderr => If 'devnull' suppresses stderr, if other TRUE value redirect |
609
|
|
|
|
|
|
|
# stderr to stdout |
610
|
|
|
|
|
|
|
# args => [ command-line arguments to the perl program ] |
611
|
|
|
|
|
|
|
# verbose => print the command line |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
my $is_mswin = $^O eq 'MSWin32'; |
614
|
|
|
|
|
|
|
my $is_netware = $^O eq 'NetWare'; |
615
|
|
|
|
|
|
|
my $is_vms = $^O eq 'VMS'; |
616
|
|
|
|
|
|
|
my $is_cygwin = $^O eq 'cygwin'; |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
sub _quote_args { |
619
|
0
|
|
|
0
|
|
0
|
my ($runperl, $args) = @_; |
620
|
|
|
|
|
|
|
|
621
|
0
|
|
|
|
|
0
|
foreach (@$args) { |
622
|
|
|
|
|
|
|
# In VMS protect with doublequotes because otherwise |
623
|
|
|
|
|
|
|
# DCL will lowercase -- unless already doublequoted. |
624
|
0
|
0
|
0
|
|
|
0
|
$_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; |
|
|
|
0
|
|
|
|
|
625
|
0
|
|
|
|
|
0
|
$runperl = $runperl . ' ' . $_; |
626
|
|
|
|
|
|
|
} |
627
|
0
|
|
|
|
|
0
|
return $runperl; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
sub _create_runperl { # Create the string to qx in runperl(). |
631
|
1
|
|
|
1
|
|
6
|
my %args = @_; |
632
|
1
|
|
|
|
|
6
|
my $runperl = which_perl(); |
633
|
1
|
50
|
|
|
|
6
|
if ($runperl =~ m/\s/) { |
634
|
0
|
|
|
|
|
0
|
$runperl = qq{"$runperl"}; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
#- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind |
637
|
1
|
50
|
|
|
|
5
|
if ($ENV{PERL_RUNPERL_DEBUG}) { |
638
|
0
|
|
|
|
|
0
|
$runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; |
639
|
|
|
|
|
|
|
} |
640
|
1
|
50
|
|
|
|
4
|
unless ($args{nolib}) { |
641
|
0
|
|
|
|
|
0
|
$runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS |
642
|
|
|
|
|
|
|
} |
643
|
1
|
50
|
|
|
|
4
|
if ($args{switches}) { |
644
|
0
|
|
|
|
|
0
|
local $Level = 2; |
645
|
|
|
|
|
|
|
die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() |
646
|
0
|
0
|
|
|
|
0
|
unless ref $args{switches} eq "ARRAY"; |
647
|
0
|
|
|
|
|
0
|
$runperl = _quote_args($runperl, $args{switches}); |
648
|
|
|
|
|
|
|
} |
649
|
1
|
50
|
|
|
|
3
|
if (defined $args{prog}) { |
650
|
|
|
|
|
|
|
die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() |
651
|
1
|
50
|
|
|
|
4
|
if defined $args{progs}; |
652
|
1
|
|
|
|
|
7
|
$args{progs} = [split /\n/, $args{prog}, -1] |
653
|
|
|
|
|
|
|
} |
654
|
1
|
50
|
|
|
|
5
|
if (defined $args{progs}) { |
|
|
0
|
|
|
|
|
|
655
|
|
|
|
|
|
|
die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() |
656
|
1
|
50
|
|
|
|
5
|
unless ref $args{progs} eq "ARRAY"; |
657
|
1
|
|
|
|
|
2
|
foreach my $prog (@{$args{progs}}) { |
|
1
|
|
|
|
|
4
|
|
658
|
1
|
50
|
|
|
|
4
|
if (!$args{non_portable}) { |
659
|
1
|
50
|
|
|
|
5
|
if ($prog =~ tr/'"//) { |
660
|
0
|
|
|
|
|
0
|
warn "quotes in prog >>$prog<< are not portable"; |
661
|
|
|
|
|
|
|
} |
662
|
1
|
50
|
|
|
|
6
|
if ($prog =~ /^([<>|]|2>)/) { |
663
|
0
|
|
|
|
|
0
|
warn "Initial $1 in prog >>$prog<< is not portable"; |
664
|
|
|
|
|
|
|
} |
665
|
1
|
50
|
|
|
|
5
|
if ($prog =~ /&\z/) { |
666
|
0
|
|
|
|
|
0
|
warn "Trailing & in prog >>$prog<< is not portable"; |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
} |
669
|
1
|
50
|
33
|
|
|
10
|
if ($is_mswin || $is_netware || $is_vms) { |
|
|
|
33
|
|
|
|
|
670
|
0
|
|
|
|
|
0
|
$runperl = $runperl . qq ( -e "$prog" ); |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
else { |
673
|
1
|
|
|
|
|
6
|
$runperl = $runperl . qq ( -e '$prog' ); |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
} elsif (defined $args{progfile}) { |
677
|
0
|
|
|
|
|
0
|
$runperl = $runperl . qq( "$args{progfile}"); |
678
|
|
|
|
|
|
|
} else { |
679
|
|
|
|
|
|
|
# You probably didn't want to be sucking in from the upstream stdin |
680
|
|
|
|
|
|
|
die "test.pl:runperl(): none of prog, progs, progfile, args, " |
681
|
|
|
|
|
|
|
. " switches or stdin specified" |
682
|
|
|
|
|
|
|
unless defined $args{args} or defined $args{switches} |
683
|
0
|
0
|
0
|
|
|
0
|
or defined $args{stdin}; |
|
|
|
0
|
|
|
|
|
684
|
|
|
|
|
|
|
} |
685
|
1
|
50
|
|
|
|
6
|
if (defined $args{stdin}) { |
|
|
50
|
|
|
|
|
|
686
|
|
|
|
|
|
|
# so we don't try to put literal newlines and crs onto the |
687
|
|
|
|
|
|
|
# command line. |
688
|
0
|
|
|
|
|
0
|
$args{stdin} =~ s/\n/\\n/g; |
689
|
0
|
|
|
|
|
0
|
$args{stdin} =~ s/\r/\\r/g; |
690
|
|
|
|
|
|
|
|
691
|
0
|
0
|
0
|
|
|
0
|
if ($is_mswin || $is_netware || $is_vms) { |
|
|
|
0
|
|
|
|
|
692
|
|
|
|
|
|
|
$runperl = qq{$Perl -e "print qq(} . |
693
|
0
|
|
|
|
|
0
|
$args{stdin} . q{)" | } . $runperl; |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
else { |
696
|
|
|
|
|
|
|
$runperl = qq{$Perl -e 'print qq(} . |
697
|
0
|
|
|
|
|
0
|
$args{stdin} . q{)' | } . $runperl; |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
} elsif (exists $args{stdin}) { |
700
|
|
|
|
|
|
|
# Using the pipe construction above can cause fun on systems which use |
701
|
|
|
|
|
|
|
# ksh as /bin/sh, as ksh does pipes differently (with one less process) |
702
|
|
|
|
|
|
|
# With sh, for the command line 'perl -e 'print qq()' | perl -e ...' |
703
|
|
|
|
|
|
|
# the sh process forks two children, which use exec to start the two |
704
|
|
|
|
|
|
|
# perl processes. The parent shell process persists for the duration of |
705
|
|
|
|
|
|
|
# the pipeline, and the second perl process starts with no children. |
706
|
|
|
|
|
|
|
# With ksh (and zsh), the shell saves a process by forking a child for |
707
|
|
|
|
|
|
|
# just the first perl process, and execing itself to start the second. |
708
|
|
|
|
|
|
|
# This means that the second perl process starts with one child which |
709
|
|
|
|
|
|
|
# it didn't create. This causes "fun" when if the tests assume that |
710
|
|
|
|
|
|
|
# wait (or waitpid) will only return information about processes |
711
|
|
|
|
|
|
|
# started within the test. |
712
|
|
|
|
|
|
|
# They also cause fun on VMS, where the pipe implementation returns |
713
|
|
|
|
|
|
|
# the exit code of the process at the front of the pipeline, not the |
714
|
|
|
|
|
|
|
# end. This messes up any test using OPTION FATAL. |
715
|
|
|
|
|
|
|
# Hence it's useful to have a way to make STDIN be at eof without |
716
|
|
|
|
|
|
|
# needing a pipeline, so that the fork tests have a sane environment |
717
|
|
|
|
|
|
|
# without these surprises. |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
# /dev/null appears to be surprisingly portable. |
720
|
0
|
0
|
|
|
|
0
|
$runperl = $runperl . ($is_mswin ? '
|
721
|
|
|
|
|
|
|
} |
722
|
1
|
50
|
|
|
|
4
|
if (defined $args{args}) { |
723
|
0
|
|
|
|
|
0
|
$runperl = _quote_args($runperl, $args{args}); |
724
|
|
|
|
|
|
|
} |
725
|
1
|
50
|
33
|
|
|
7
|
if (exists $args{stderr} && $args{stderr} eq 'devnull') { |
|
|
50
|
|
|
|
|
|
726
|
0
|
0
|
|
|
|
0
|
$runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null'); |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
elsif ($args{stderr}) { |
729
|
0
|
|
|
|
|
0
|
$runperl = $runperl . ' 2>&1'; |
730
|
|
|
|
|
|
|
} |
731
|
1
|
50
|
|
|
|
3
|
if ($args{verbose}) { |
732
|
0
|
|
|
|
|
0
|
my $runperldisplay = $runperl; |
733
|
0
|
|
|
|
|
0
|
$runperldisplay =~ s/\n/\n\#/g; |
734
|
0
|
|
|
|
|
0
|
_print_stderr "# $runperldisplay\n"; |
735
|
|
|
|
|
|
|
} |
736
|
1
|
|
|
|
|
5
|
return $runperl; |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
# sub run_perl {} is alias to below |
740
|
|
|
|
|
|
|
sub runperl { |
741
|
1
|
50
|
33
|
1
|
|
17
|
die "test.pl:runperl() does not take a hashref" |
742
|
|
|
|
|
|
|
if ref $_[0] and ref $_[0] eq 'HASH'; |
743
|
1
|
|
|
|
|
5
|
my $runperl = &_create_runperl; |
744
|
1
|
|
|
|
|
2
|
my $result; |
745
|
|
|
|
|
|
|
|
746
|
1
|
|
|
|
|
14
|
my $tainted = ${^TAINT}; |
747
|
1
|
|
|
|
|
6
|
my %args = @_; |
748
|
1
|
50
|
33
|
|
|
7
|
exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; |
|
0
|
|
|
|
|
0
|
|
749
|
|
|
|
|
|
|
|
750
|
1
|
50
|
|
|
|
4
|
if ($tainted) { |
751
|
|
|
|
|
|
|
# We will assume that if you're running under -T, you really mean to |
752
|
|
|
|
|
|
|
# run a fresh perl, so we'll brute force launder everything for you |
753
|
0
|
|
|
|
|
0
|
my $sep; |
754
|
|
|
|
|
|
|
|
755
|
0
|
0
|
|
|
|
0
|
if (! eval {require Config; 1}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
756
|
0
|
|
|
|
|
0
|
warn "test.pl had problems loading Config: $@"; |
757
|
0
|
|
|
|
|
0
|
$sep = ':'; |
758
|
|
|
|
|
|
|
} else { |
759
|
0
|
|
|
|
|
0
|
$sep = $Config::Config{path_sep}; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
0
|
|
|
|
|
0
|
my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); |
|
0
|
|
|
|
|
0
|
|
763
|
0
|
|
|
|
|
0
|
local @ENV{@keys} = (); |
764
|
|
|
|
|
|
|
# Untaint, plus take out . and empty string: |
765
|
0
|
0
|
0
|
|
|
0
|
local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); |
|
|
|
0
|
|
|
|
|
766
|
0
|
|
|
|
|
0
|
$ENV{PATH} =~ /(.*)/s; |
767
|
|
|
|
|
|
|
local $ENV{PATH} = |
768
|
0
|
0
|
0
|
|
|
0
|
join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and |
|
0
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
769
|
|
|
|
|
|
|
($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } |
770
|
|
|
|
|
|
|
split quotemeta ($sep), $1; |
771
|
0
|
0
|
|
|
|
0
|
if ($is_cygwin) { # Must have /bin under Cygwin |
772
|
0
|
0
|
|
|
|
0
|
if (length $ENV{PATH}) { |
773
|
0
|
|
|
|
|
0
|
$ENV{PATH} = $ENV{PATH} . $sep; |
774
|
|
|
|
|
|
|
} |
775
|
0
|
|
|
|
|
0
|
$ENV{PATH} = $ENV{PATH} . '/bin'; |
776
|
|
|
|
|
|
|
} |
777
|
0
|
|
|
|
|
0
|
$runperl =~ /(.*)/s; |
778
|
0
|
|
|
|
|
0
|
$runperl = $1; |
779
|
|
|
|
|
|
|
|
780
|
0
|
|
|
|
|
0
|
$result = `$runperl`; |
781
|
|
|
|
|
|
|
} else { |
782
|
1
|
|
|
|
|
5979
|
$result = `$runperl`; |
783
|
|
|
|
|
|
|
} |
784
|
1
|
50
|
|
|
|
40
|
$result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these |
785
|
1
|
|
|
|
|
66
|
return $result; |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
# Nice alias |
789
|
|
|
|
|
|
|
*run_perl = *run_perl = \&runperl; # shut up "used only once" warning |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
sub DIE { |
792
|
0
|
|
|
0
|
|
0
|
_print_stderr "# @_\n"; |
793
|
0
|
|
|
|
|
0
|
exit 1; |
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# A somewhat safer version of the sometimes wrong $^X. |
797
|
|
|
|
|
|
|
sub which_perl { |
798
|
1
|
50
|
|
1
|
|
5
|
unless (defined $Perl) { |
799
|
1
|
|
|
|
|
2
|
$Perl = $^X; |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
# VMS should have 'perl' aliased properly |
802
|
1
|
50
|
|
|
|
5
|
return $Perl if $is_vms; |
803
|
|
|
|
|
|
|
|
804
|
1
|
|
|
|
|
2
|
my $exe; |
805
|
1
|
50
|
|
|
|
3
|
if (! eval {require Config; 1}) { |
|
1
|
|
|
|
|
10
|
|
|
1
|
|
|
|
|
29
|
|
806
|
0
|
|
|
|
|
0
|
warn "test.pl had problems loading Config: $@"; |
807
|
0
|
|
|
|
|
0
|
$exe = ''; |
808
|
|
|
|
|
|
|
} else { |
809
|
1
|
|
|
|
|
18
|
$exe = $Config::Config{_exe}; |
810
|
|
|
|
|
|
|
} |
811
|
1
|
50
|
|
|
|
5
|
$exe = '' unless defined $exe; |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
# This doesn't absolutize the path: beware of future chdirs(). |
814
|
|
|
|
|
|
|
# We could do File::Spec->abs2rel() but that does getcwd()s, |
815
|
|
|
|
|
|
|
# which is a bit heavyweight to do here. |
816
|
|
|
|
|
|
|
|
817
|
1
|
50
|
|
|
|
16
|
if ($Perl =~ /^perl\Q$exe\E$/i) { |
818
|
0
|
|
|
|
|
0
|
my $perl = "perl$exe"; |
819
|
0
|
0
|
|
|
|
0
|
if (! eval {require File::Spec; 1}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
820
|
0
|
|
|
|
|
0
|
warn "test.pl had problems loading File::Spec: $@"; |
821
|
0
|
|
|
|
|
0
|
$Perl = "./$perl"; |
822
|
|
|
|
|
|
|
} else { |
823
|
0
|
|
|
|
|
0
|
$Perl = File::Spec->catfile(File::Spec->curdir(), $perl); |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
# Build up the name of the executable file from the name of |
828
|
|
|
|
|
|
|
# the command. |
829
|
|
|
|
|
|
|
|
830
|
1
|
50
|
|
|
|
10
|
if ($Perl !~ /\Q$exe\E$/i) { |
831
|
0
|
|
|
|
|
0
|
$Perl = $Perl . $exe; |
832
|
|
|
|
|
|
|
} |
833
|
|
|
|
|
|
|
|
834
|
1
|
50
|
|
|
|
50
|
warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
# For subcommands to use. |
837
|
1
|
|
|
|
|
14
|
$ENV{PERLEXE} = $Perl; |
838
|
|
|
|
|
|
|
} |
839
|
1
|
|
|
|
|
4
|
return $Perl; |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
sub unlink_all { |
843
|
1
|
|
|
1
|
|
5
|
my $count = 0; |
844
|
1
|
|
|
|
|
8
|
foreach my $file (@_) { |
845
|
1
|
|
|
|
|
22
|
1 while unlink $file; |
846
|
1
|
50
|
|
|
|
21
|
if( -f $file ){ |
847
|
0
|
|
|
|
|
0
|
_print_stderr "# Couldn't unlink '$file': $!\n"; |
848
|
|
|
|
|
|
|
}else{ |
849
|
1
|
|
|
|
|
3
|
++$count; |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
} |
852
|
1
|
|
|
|
|
6
|
$count; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# _num_to_alpha - Returns a string of letters representing a positive integer. |
856
|
|
|
|
|
|
|
# Arguments : |
857
|
|
|
|
|
|
|
# number to convert |
858
|
|
|
|
|
|
|
# maximum number of letters |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# returns undef if the number is negative |
861
|
|
|
|
|
|
|
# returns undef if the number of letters is greater than the maximum wanted |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# _num_to_alpha( 0) eq 'A'; |
864
|
|
|
|
|
|
|
# _num_to_alpha( 1) eq 'B'; |
865
|
|
|
|
|
|
|
# _num_to_alpha(25) eq 'Z'; |
866
|
|
|
|
|
|
|
# _num_to_alpha(26) eq 'AA'; |
867
|
|
|
|
|
|
|
# _num_to_alpha(27) eq 'AB'; |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
# Avoid ++ -- ranges split negative numbers |
872
|
|
|
|
|
|
|
sub _num_to_alpha{ |
873
|
1
|
|
|
1
|
|
4
|
my($num,$max_char) = @_; |
874
|
1
|
50
|
|
|
|
5
|
return unless $num >= 0; |
875
|
1
|
|
|
|
|
2
|
my $alpha = ''; |
876
|
1
|
|
|
|
|
2
|
my $char_count = 0; |
877
|
1
|
50
|
|
|
|
4
|
$max_char = 0 if $max_char < 0; |
878
|
|
|
|
|
|
|
|
879
|
1
|
|
|
|
|
3
|
while( 1 ){ |
880
|
1
|
|
|
|
|
3
|
$alpha = $letters[ $num % 26 ] . $alpha; |
881
|
1
|
|
|
|
|
5
|
$num = int( $num / 26 ); |
882
|
1
|
50
|
|
|
|
5
|
last if $num == 0; |
883
|
0
|
|
|
|
|
0
|
$num = $num - 1; |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
# char limit |
886
|
0
|
0
|
|
|
|
0
|
next unless $max_char; |
887
|
0
|
|
|
|
|
0
|
$char_count = $char_count + 1; |
888
|
0
|
0
|
|
|
|
0
|
return if $char_count == $max_char; |
889
|
|
|
|
|
|
|
} |
890
|
1
|
|
|
|
|
3
|
return $alpha; |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
my %tmpfiles; |
894
|
1
|
|
|
1
|
|
1236
|
END { unlink_all keys %tmpfiles } |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
# A regexp that matches the tempfile names |
897
|
|
|
|
|
|
|
$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
# Avoid ++, avoid ranges, avoid split // |
900
|
|
|
|
|
|
|
my $tempfile_count = 0; |
901
|
|
|
|
|
|
|
sub tempfile { |
902
|
1
|
|
|
1
|
|
2
|
while(1){ |
903
|
1
|
|
|
|
|
14
|
my $try = "tmp$$"; |
904
|
1
|
|
|
|
|
5
|
my $alpha = _num_to_alpha($tempfile_count,2); |
905
|
1
|
50
|
|
|
|
4
|
last unless defined $alpha; |
906
|
1
|
|
|
|
|
2
|
$try = $try . $alpha; |
907
|
1
|
|
|
|
|
2
|
$tempfile_count = $tempfile_count + 1; |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
# Need to note all the file names we allocated, as a second request may |
910
|
|
|
|
|
|
|
# come before the first is created. |
911
|
1
|
50
|
33
|
|
|
68
|
if (!$tmpfiles{$try} && !-e $try) { |
912
|
|
|
|
|
|
|
# We have a winner |
913
|
1
|
|
|
|
|
6
|
$tmpfiles{$try} = 1; |
914
|
1
|
|
|
|
|
3
|
return $try; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
} |
917
|
0
|
|
|
|
|
|
die "Can't find temporary file name starting \"tmp$$\""; |
918
|
|
|
|
|
|
|
} |
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
# register_tempfile - Adds a list of files to be removed at the end of the current test file |
921
|
|
|
|
|
|
|
# Arguments : |
922
|
|
|
|
|
|
|
# a list of files to be removed later |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
# returns a count of how many file names were actually added |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
# Reuses %tmpfiles so that tempfile() will also skip any files added here |
927
|
|
|
|
|
|
|
# even if the file doesn't exist yet. |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
sub register_tempfile { |
930
|
0
|
|
|
0
|
|
|
my $count = 0; |
931
|
0
|
|
|
|
|
|
for( @_ ){ |
932
|
0
|
0
|
|
|
|
|
if( $tmpfiles{$_} ){ |
933
|
0
|
|
|
|
|
|
_print_stderr "# Temporary file '$_' already added\n"; |
934
|
|
|
|
|
|
|
}else{ |
935
|
0
|
|
|
|
|
|
$tmpfiles{$_} = 1; |
936
|
0
|
|
|
|
|
|
$count = $count + 1; |
937
|
|
|
|
|
|
|
} |
938
|
|
|
|
|
|
|
} |
939
|
0
|
|
|
|
|
|
return $count; |
940
|
|
|
|
|
|
|
} |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
# This is the temporary file for _fresh_perl |
943
|
|
|
|
|
|
|
my $tmpfile = tempfile(); |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
sub _fresh_perl { |
946
|
0
|
|
|
0
|
|
|
my($prog, $action, $expect, $runperl_args, $name) = @_; |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
# Given the choice of the mis-parsable {} |
949
|
|
|
|
|
|
|
# (we want an anon hash, but a borked lexer might think that it's a block) |
950
|
|
|
|
|
|
|
# or relying on taking a reference to a lexical |
951
|
|
|
|
|
|
|
# (\ might be mis-parsed, and the reference counting on the pad may go |
952
|
|
|
|
|
|
|
# awry) |
953
|
|
|
|
|
|
|
# it feels like the least-worse thing is to assume that auto-vivification |
954
|
|
|
|
|
|
|
# works. At least, this is only going to be a run-time failure, so won't |
955
|
|
|
|
|
|
|
# affect tests using this file but not this function. |
956
|
0
|
|
0
|
|
|
|
$runperl_args->{progfile} ||= $tmpfile; |
957
|
0
|
0
|
|
|
|
|
$runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; |
958
|
|
|
|
|
|
|
|
959
|
0
|
0
|
|
|
|
|
open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
960
|
0
|
|
|
|
|
|
print TEST $prog; |
961
|
0
|
0
|
|
|
|
|
close TEST or die "Cannot close $tmpfile: $!"; |
962
|
|
|
|
|
|
|
|
963
|
0
|
|
|
|
|
|
my $results = runperl(%$runperl_args); |
964
|
0
|
|
|
|
|
|
my $status = $?; |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
# Clean up the results into something a bit more predictable. |
967
|
0
|
|
|
|
|
|
$results =~ s/\n+$//; |
968
|
0
|
|
|
|
|
|
$results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; |
969
|
0
|
|
|
|
|
|
$results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
# bison says 'parse error' instead of 'syntax error', |
972
|
|
|
|
|
|
|
# various yaccs may or may not capitalize 'syntax'. |
973
|
0
|
|
|
|
|
|
$results =~ s/^(syntax|parse) error/syntax error/mig; |
974
|
|
|
|
|
|
|
|
975
|
0
|
0
|
|
|
|
|
if ($is_vms) { |
976
|
|
|
|
|
|
|
# some tests will trigger VMS messages that won't be expected |
977
|
0
|
|
|
|
|
|
$results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
# pipes double these sometimes |
980
|
0
|
|
|
|
|
|
$results =~ s/\n\n/\n/g; |
981
|
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
# Use the first line of the program as a name if none was given |
984
|
0
|
0
|
|
|
|
|
unless( $name ) { |
985
|
0
|
|
|
|
|
|
($first_line, $name) = $prog =~ /^((.{1,50}).*)/; |
986
|
0
|
0
|
|
|
|
|
$name = $name . '...' if length $first_line > length $name; |
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
# Historically this was implemented using a closure, but then that means |
990
|
|
|
|
|
|
|
# that the tests for closures avoid using this code. Given that there |
991
|
|
|
|
|
|
|
# are exactly two callers, doing exactly two things, the simpler approach |
992
|
|
|
|
|
|
|
# feels like a better trade off. |
993
|
0
|
|
|
|
|
|
my $pass; |
994
|
0
|
0
|
|
|
|
|
if ($action eq 'eq') { |
|
|
0
|
|
|
|
|
|
995
|
0
|
|
|
|
|
|
$pass = is($results, $expect, $name); |
996
|
|
|
|
|
|
|
} elsif ($action eq '=~') { |
997
|
0
|
|
|
|
|
|
$pass = like($results, $expect, $name); |
998
|
|
|
|
|
|
|
} else { |
999
|
0
|
|
|
|
|
|
die "_fresh_perl can't process action '$action'"; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
|
1002
|
0
|
0
|
|
|
|
|
unless ($pass) { |
1003
|
0
|
|
|
|
|
|
_diag "# PROG: \n$prog\n"; |
1004
|
0
|
|
|
|
|
|
_diag "# STATUS: $status\n"; |
1005
|
|
|
|
|
|
|
} |
1006
|
|
|
|
|
|
|
|
1007
|
0
|
|
|
|
|
|
return $pass; |
1008
|
|
|
|
|
|
|
} |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
# |
1011
|
|
|
|
|
|
|
# fresh_perl_is |
1012
|
|
|
|
|
|
|
# |
1013
|
|
|
|
|
|
|
# Combination of run_perl() and is(). |
1014
|
|
|
|
|
|
|
# |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
sub fresh_perl_is { |
1017
|
0
|
|
|
0
|
|
|
my($prog, $expected, $runperl_args, $name) = @_; |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
# _fresh_perl() is going to clip the trailing newlines off the result. |
1020
|
|
|
|
|
|
|
# This will make it so the test author doesn't have to know that. |
1021
|
0
|
|
|
|
|
|
$expected =~ s/\n+$//; |
1022
|
|
|
|
|
|
|
|
1023
|
0
|
|
|
|
|
|
local $Level = 2; |
1024
|
0
|
|
|
|
|
|
_fresh_perl($prog, 'eq', $expected, $runperl_args, $name); |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
# |
1028
|
|
|
|
|
|
|
# fresh_perl_like |
1029
|
|
|
|
|
|
|
# |
1030
|
|
|
|
|
|
|
# Combination of run_perl() and like(). |
1031
|
|
|
|
|
|
|
# |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
sub fresh_perl_like { |
1034
|
0
|
|
|
0
|
|
|
my($prog, $expected, $runperl_args, $name) = @_; |
1035
|
0
|
|
|
|
|
|
local $Level = 2; |
1036
|
0
|
|
|
|
|
|
_fresh_perl($prog, '=~', $expected, $runperl_args, $name); |
1037
|
|
|
|
|
|
|
} |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
# Many tests use the same format in __DATA__ or external files to specify a |
1040
|
|
|
|
|
|
|
# sequence of (fresh) tests to run, extra files they may temporarily need, and |
1041
|
|
|
|
|
|
|
# what the expected output is. Putting it here allows common code to serve |
1042
|
|
|
|
|
|
|
# these multiple tests. |
1043
|
|
|
|
|
|
|
# |
1044
|
|
|
|
|
|
|
# Each program is source code to run followed by an "EXPECT" line, followed |
1045
|
|
|
|
|
|
|
# by the expected output. |
1046
|
|
|
|
|
|
|
# |
1047
|
|
|
|
|
|
|
# The code to run may begin with a command line switch such as -w or -0777 |
1048
|
|
|
|
|
|
|
# (alphanumerics only), and may contain (note the '# ' on each): |
1049
|
|
|
|
|
|
|
# # TODO reason for todo |
1050
|
|
|
|
|
|
|
# # SKIP reason for skip |
1051
|
|
|
|
|
|
|
# # SKIP ?code to test if this should be skipped |
1052
|
|
|
|
|
|
|
# # NAME name of the test (as with ok($ok, $name)) |
1053
|
|
|
|
|
|
|
# |
1054
|
|
|
|
|
|
|
# The expected output may contain: |
1055
|
|
|
|
|
|
|
# OPTION list of options |
1056
|
|
|
|
|
|
|
# OPTIONS list of options |
1057
|
|
|
|
|
|
|
# |
1058
|
|
|
|
|
|
|
# The possible options for OPTION may be: |
1059
|
|
|
|
|
|
|
# regex - the expected output is a regular expression |
1060
|
|
|
|
|
|
|
# random - all lines match but in any order |
1061
|
|
|
|
|
|
|
# fatal - the code will fail fatally (croak, die) |
1062
|
|
|
|
|
|
|
# |
1063
|
|
|
|
|
|
|
# If the actual output contains a line "SKIPPED" the test will be |
1064
|
|
|
|
|
|
|
# skipped. |
1065
|
|
|
|
|
|
|
# |
1066
|
|
|
|
|
|
|
# If the actual output contains a line "PREFIX", any output starting with that |
1067
|
|
|
|
|
|
|
# line will be ignored when comparing with the expected output |
1068
|
|
|
|
|
|
|
# |
1069
|
|
|
|
|
|
|
# If the global variable $FATAL is true then OPTION fatal is the |
1070
|
|
|
|
|
|
|
# default. |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
sub _setup_one_file { |
1073
|
0
|
|
|
0
|
|
|
my $fh = shift; |
1074
|
|
|
|
|
|
|
# Store the filename as a program that started at line 0. |
1075
|
|
|
|
|
|
|
# Real files count lines starting at line 1. |
1076
|
0
|
|
|
|
|
|
my @these = (0, shift); |
1077
|
0
|
|
|
|
|
|
my ($lineno, $current); |
1078
|
0
|
|
|
|
|
|
while (<$fh>) { |
1079
|
0
|
0
|
|
|
|
|
if ($_ eq "########\n") { |
1080
|
0
|
0
|
|
|
|
|
if (defined $current) { |
1081
|
0
|
|
|
|
|
|
push @these, $lineno, $current; |
1082
|
|
|
|
|
|
|
} |
1083
|
0
|
|
|
|
|
|
undef $current; |
1084
|
|
|
|
|
|
|
} else { |
1085
|
0
|
0
|
|
|
|
|
if (!defined $current) { |
1086
|
0
|
|
|
|
|
|
$lineno = $.; |
1087
|
|
|
|
|
|
|
} |
1088
|
0
|
|
|
|
|
|
$current .= $_; |
1089
|
|
|
|
|
|
|
} |
1090
|
|
|
|
|
|
|
} |
1091
|
0
|
0
|
|
|
|
|
if (defined $current) { |
1092
|
0
|
|
|
|
|
|
push @these, $lineno, $current; |
1093
|
|
|
|
|
|
|
} |
1094
|
0
|
|
|
|
|
|
((scalar @these) / 2 - 1, @these); |
1095
|
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
sub setup_multiple_progs { |
1098
|
0
|
|
|
0
|
|
|
my ($tests, @prgs); |
1099
|
0
|
|
|
|
|
|
foreach my $file (@_) { |
1100
|
0
|
0
|
|
|
|
|
next if $file =~ /(?:~|\.orig|,v)$/; |
1101
|
0
|
0
|
0
|
|
|
|
next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); |
1102
|
0
|
0
|
|
|
|
|
next if -d $file; |
1103
|
|
|
|
|
|
|
|
1104
|
0
|
0
|
|
|
|
|
open my $fh, '<', $file or die "Cannot open $file: $!\n" ; |
1105
|
0
|
|
|
|
|
|
my $found; |
1106
|
0
|
|
|
|
|
|
while (<$fh>) { |
1107
|
0
|
0
|
|
|
|
|
if (/^__END__/) { |
1108
|
0
|
|
|
|
|
|
++$found; |
1109
|
0
|
|
|
|
|
|
last; |
1110
|
|
|
|
|
|
|
} |
1111
|
|
|
|
|
|
|
} |
1112
|
|
|
|
|
|
|
# This is an internal error, and should never happen. All bar one of |
1113
|
|
|
|
|
|
|
# the files had an __END__ marker to signal the end of their preamble, |
1114
|
|
|
|
|
|
|
# although for some it wasn't technically necessary as they have no |
1115
|
|
|
|
|
|
|
# tests. It might be possible to process files without an __END__ by |
1116
|
|
|
|
|
|
|
# seeking back to the start and treating the whole file as tests, but |
1117
|
|
|
|
|
|
|
# it's simpler and more reliable just to make the rule that all files |
1118
|
|
|
|
|
|
|
# must have __END__ in. This should never fail - a file without an |
1119
|
|
|
|
|
|
|
# __END__ should not have been checked in, because the regression tests |
1120
|
|
|
|
|
|
|
# would not have passed. |
1121
|
0
|
0
|
|
|
|
|
die "Could not find '__END__' in $file" |
1122
|
|
|
|
|
|
|
unless $found; |
1123
|
|
|
|
|
|
|
|
1124
|
0
|
|
|
|
|
|
my ($t, @p) = _setup_one_file($fh, $file); |
1125
|
0
|
|
|
|
|
|
$tests += $t; |
1126
|
0
|
|
|
|
|
|
push @prgs, @p; |
1127
|
|
|
|
|
|
|
|
1128
|
0
|
0
|
|
|
|
|
close $fh |
1129
|
|
|
|
|
|
|
or die "Cannot close $file: $!\n"; |
1130
|
|
|
|
|
|
|
} |
1131
|
0
|
|
|
|
|
|
return ($tests, @prgs); |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
|
1134
|
|
|
|
|
|
|
sub run_multiple_progs { |
1135
|
0
|
|
|
0
|
|
|
my $up = shift; |
1136
|
0
|
|
|
|
|
|
my @prgs; |
1137
|
0
|
0
|
|
|
|
|
if ($up) { |
1138
|
|
|
|
|
|
|
# The tests in lib run in a temporary subdirectory of t, and always |
1139
|
|
|
|
|
|
|
# pass in a list of "programs" to run |
1140
|
0
|
|
|
|
|
|
@prgs = @_; |
1141
|
|
|
|
|
|
|
} else { |
1142
|
|
|
|
|
|
|
# The tests below t run in t and pass in a file handle. In theory we |
1143
|
|
|
|
|
|
|
# can pass (caller)[1] as the second argument to report errors with |
1144
|
|
|
|
|
|
|
# the filename of our caller, as the handle is always DATA. However, |
1145
|
|
|
|
|
|
|
# line numbers in DATA count from the __END__ token, so will be wrong. |
1146
|
|
|
|
|
|
|
# Which is more confusing than not providing line numbers. So, for now, |
1147
|
|
|
|
|
|
|
# don't provide line numbers. No obvious clean solution - one hack |
1148
|
|
|
|
|
|
|
# would be to seek DATA back to the start and read to the __END__ token, |
1149
|
|
|
|
|
|
|
# but that feels almost like we should just open $0 instead. |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
# Not going to rely on undef in list assignment. |
1152
|
0
|
|
|
|
|
|
my $dummy; |
1153
|
0
|
|
|
|
|
|
($dummy, @prgs) = _setup_one_file(shift); |
1154
|
|
|
|
|
|
|
} |
1155
|
|
|
|
|
|
|
|
1156
|
0
|
|
|
|
|
|
my $tmpfile = tempfile(); |
1157
|
|
|
|
|
|
|
|
1158
|
0
|
|
|
|
|
|
my ($file, $line); |
1159
|
|
|
|
|
|
|
PROGRAM: |
1160
|
0
|
|
|
|
|
|
while (defined ($line = shift @prgs)) { |
1161
|
0
|
|
|
|
|
|
$_ = shift @prgs; |
1162
|
0
|
0
|
|
|
|
|
unless ($line) { |
1163
|
0
|
|
|
|
|
|
$file = $_; |
1164
|
0
|
0
|
|
|
|
|
if (defined $file) { |
1165
|
0
|
|
|
|
|
|
print "# From $file\n"; |
1166
|
|
|
|
|
|
|
} |
1167
|
0
|
|
|
|
|
|
next; |
1168
|
|
|
|
|
|
|
} |
1169
|
0
|
|
|
|
|
|
my $switch = ""; |
1170
|
0
|
|
|
|
|
|
my @temps ; |
1171
|
|
|
|
|
|
|
my @temp_path; |
1172
|
0
|
0
|
|
|
|
|
if (s/^(\s*-\w+)//) { |
1173
|
0
|
|
|
|
|
|
$switch = $1; |
1174
|
|
|
|
|
|
|
} |
1175
|
0
|
|
|
|
|
|
my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); |
1176
|
|
|
|
|
|
|
|
1177
|
0
|
|
|
|
|
|
my %reason; |
1178
|
0
|
|
|
|
|
|
foreach my $what (qw(skip todo)) { |
1179
|
0
|
0
|
|
|
|
|
$prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; |
1180
|
|
|
|
|
|
|
# If the SKIP reason starts ? then it's taken as a code snippet to |
1181
|
|
|
|
|
|
|
# evaluate. This provides the flexibility to have conditional SKIPs |
1182
|
0
|
0
|
0
|
|
|
|
if ($reason{$what} && $reason{$what} =~ s/^\?//) { |
1183
|
0
|
|
|
|
|
|
my $temp = eval $reason{$what}; |
1184
|
0
|
0
|
|
|
|
|
if ($@) { |
1185
|
0
|
|
|
|
|
|
die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; |
1186
|
|
|
|
|
|
|
} |
1187
|
0
|
|
|
|
|
|
$reason{$what} = $temp; |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
} |
1190
|
|
|
|
|
|
|
|
1191
|
0
|
|
|
|
|
|
my $name = ''; |
1192
|
0
|
0
|
|
|
|
|
if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { |
1193
|
0
|
|
|
|
|
|
$name = $1; |
1194
|
|
|
|
|
|
|
} |
1195
|
|
|
|
|
|
|
|
1196
|
0
|
0
|
|
|
|
|
if ($reason{skip}) { |
1197
|
|
|
|
|
|
|
SKIP: |
1198
|
|
|
|
|
|
|
{ |
1199
|
0
|
0
|
|
|
|
|
skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); |
|
0
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
} |
1201
|
0
|
|
|
|
|
|
next PROGRAM; |
1202
|
|
|
|
|
|
|
} |
1203
|
|
|
|
|
|
|
|
1204
|
0
|
0
|
|
|
|
|
if ($prog =~ /--FILE--/) { |
1205
|
0
|
|
|
|
|
|
my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; |
1206
|
0
|
|
|
|
|
|
shift @files ; |
1207
|
0
|
0
|
|
|
|
|
die "Internal error: test $_ didn't split into pairs, got " . |
1208
|
|
|
|
|
|
|
scalar(@files) . "[" . join("%%%%", @files) ."]\n" |
1209
|
|
|
|
|
|
|
if @files % 2; |
1210
|
0
|
|
|
|
|
|
while (@files > 2) { |
1211
|
0
|
|
|
|
|
|
my $filename = shift @files; |
1212
|
0
|
|
|
|
|
|
my $code = shift @files; |
1213
|
0
|
|
|
|
|
|
push @temps, $filename; |
1214
|
0
|
0
|
0
|
|
|
|
if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { |
1215
|
0
|
|
|
|
|
|
require File::Path; |
1216
|
0
|
|
|
|
|
|
File::Path::mkpath($1); |
1217
|
0
|
|
|
|
|
|
push(@temp_path, $1); |
1218
|
|
|
|
|
|
|
} |
1219
|
0
|
0
|
|
|
|
|
open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; |
1220
|
0
|
|
|
|
|
|
print $fh $code; |
1221
|
0
|
0
|
|
|
|
|
close $fh or die "Cannot close $filename: $!\n"; |
1222
|
|
|
|
|
|
|
} |
1223
|
0
|
|
|
|
|
|
shift @files; |
1224
|
0
|
|
|
|
|
|
$prog = shift @files; |
1225
|
|
|
|
|
|
|
} |
1226
|
|
|
|
|
|
|
|
1227
|
0
|
0
|
|
|
|
|
open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; |
1228
|
0
|
|
|
|
|
|
print $fh q{ |
1229
|
|
|
|
|
|
|
BEGIN { |
1230
|
|
|
|
|
|
|
open STDERR, '>&', STDOUT |
1231
|
|
|
|
|
|
|
or die "Can't dup STDOUT->STDERR: $!;"; |
1232
|
|
|
|
|
|
|
} |
1233
|
|
|
|
|
|
|
}; |
1234
|
0
|
|
|
|
|
|
print $fh "\n#line 1\n"; # So the line numbers don't get messed up. |
1235
|
0
|
|
|
|
|
|
print $fh $prog,"\n"; |
1236
|
0
|
0
|
|
|
|
|
close $fh or die "Cannot close $tmpfile: $!"; |
1237
|
0
|
0
|
|
|
|
|
my $results = runperl( stderr => 1, progfile => $tmpfile, |
1238
|
|
|
|
|
|
|
stdin => undef, $up |
1239
|
|
|
|
|
|
|
? (switches => ["-I$up/lib", $switch], nolib => 1) |
1240
|
|
|
|
|
|
|
: (switches => [$switch]) |
1241
|
|
|
|
|
|
|
); |
1242
|
0
|
|
|
|
|
|
my $status = $?; |
1243
|
0
|
|
|
|
|
|
$results =~ s/\n+$//; |
1244
|
|
|
|
|
|
|
# allow expected output to be written as if $prog is on STDIN |
1245
|
0
|
|
|
|
|
|
$results =~ s/$::tempfile_regexp/-/g; |
1246
|
0
|
0
|
|
|
|
|
if ($^O eq 'VMS') { |
1247
|
|
|
|
|
|
|
# some tests will trigger VMS messages that won't be expected |
1248
|
0
|
|
|
|
|
|
$results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; |
1249
|
|
|
|
|
|
|
|
1250
|
|
|
|
|
|
|
# pipes double these sometimes |
1251
|
0
|
|
|
|
|
|
$results =~ s/\n\n/\n/g; |
1252
|
|
|
|
|
|
|
} |
1253
|
|
|
|
|
|
|
# bison says 'parse error' instead of 'syntax error', |
1254
|
|
|
|
|
|
|
# various yaccs may or may not capitalize 'syntax'. |
1255
|
0
|
|
|
|
|
|
$results =~ s/^(syntax|parse) error/syntax error/mig; |
1256
|
|
|
|
|
|
|
# allow all tests to run when there are leaks |
1257
|
0
|
|
|
|
|
|
$results =~ s/Scalars leaked: \d+\n//g; |
1258
|
|
|
|
|
|
|
|
1259
|
0
|
|
|
|
|
|
$expected =~ s/\n+$//; |
1260
|
0
|
|
|
|
|
|
my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; |
1261
|
|
|
|
|
|
|
# any special options? (OPTIONS foo bar zap) |
1262
|
0
|
|
|
|
|
|
my $option_regex = 0; |
1263
|
0
|
|
|
|
|
|
my $option_random = 0; |
1264
|
0
|
|
|
|
|
|
my $fatal = $FATAL; |
1265
|
0
|
0
|
|
|
|
|
if ($expected =~ s/^OPTIONS? (.+)\n//) { |
1266
|
0
|
|
|
|
|
|
foreach my $option (split(' ', $1)) { |
1267
|
0
|
0
|
|
|
|
|
if ($option eq 'regex') { # allow regular expressions |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1268
|
0
|
|
|
|
|
|
$option_regex = 1; |
1269
|
|
|
|
|
|
|
} |
1270
|
|
|
|
|
|
|
elsif ($option eq 'random') { # all lines match, but in any order |
1271
|
0
|
|
|
|
|
|
$option_random = 1; |
1272
|
|
|
|
|
|
|
} |
1273
|
|
|
|
|
|
|
elsif ($option eq 'fatal') { # perl should fail |
1274
|
0
|
|
|
|
|
|
$fatal = 1; |
1275
|
|
|
|
|
|
|
} |
1276
|
|
|
|
|
|
|
else { |
1277
|
0
|
|
|
|
|
|
die "$0: Unknown OPTION '$option'\n"; |
1278
|
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
} |
1280
|
|
|
|
|
|
|
} |
1281
|
0
|
0
|
|
|
|
|
die "$0: can't have OPTION regex and random\n" |
1282
|
|
|
|
|
|
|
if $option_regex + $option_random > 1; |
1283
|
0
|
|
|
|
|
|
my $ok = 0; |
1284
|
0
|
0
|
|
|
|
|
if ($results =~ s/^SKIPPED\n//) { |
1285
|
0
|
|
|
|
|
|
print "$results\n" ; |
1286
|
0
|
|
|
|
|
|
$ok = 1; |
1287
|
|
|
|
|
|
|
} |
1288
|
|
|
|
|
|
|
else { |
1289
|
0
|
0
|
|
|
|
|
if ($option_random) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1290
|
0
|
|
|
|
|
|
my @got = sort split "\n", $results; |
1291
|
0
|
|
|
|
|
|
my @expected = sort split "\n", $expected; |
1292
|
|
|
|
|
|
|
|
1293
|
0
|
|
|
|
|
|
$ok = "@got" eq "@expected"; |
1294
|
|
|
|
|
|
|
} |
1295
|
|
|
|
|
|
|
elsif ($option_regex) { |
1296
|
0
|
|
|
|
|
|
$ok = $results =~ /^$expected/; |
1297
|
|
|
|
|
|
|
} |
1298
|
|
|
|
|
|
|
elsif ($prefix) { |
1299
|
0
|
|
|
|
|
|
$ok = $results =~ /^\Q$expected/; |
1300
|
|
|
|
|
|
|
} |
1301
|
|
|
|
|
|
|
else { |
1302
|
0
|
|
|
|
|
|
$ok = $results eq $expected; |
1303
|
|
|
|
|
|
|
} |
1304
|
|
|
|
|
|
|
|
1305
|
0
|
0
|
0
|
|
|
|
if ($ok && $fatal && !($status >> 8)) { |
|
|
|
0
|
|
|
|
|
1306
|
0
|
|
|
|
|
|
$ok = 0; |
1307
|
|
|
|
|
|
|
} |
1308
|
|
|
|
|
|
|
} |
1309
|
|
|
|
|
|
|
|
1310
|
0
|
|
|
|
|
|
local $::TODO = $reason{todo}; |
1311
|
|
|
|
|
|
|
|
1312
|
0
|
0
|
|
|
|
|
unless ($ok) { |
1313
|
0
|
|
|
|
|
|
my $err_line = "PROG: $switch\n$prog\n" . |
1314
|
|
|
|
|
|
|
"EXPECTED:\n$expected\n"; |
1315
|
0
|
0
|
|
|
|
|
$err_line .= "EXIT STATUS: != 0\n" if $fatal; |
1316
|
0
|
|
|
|
|
|
$err_line .= "GOT:\n$results\n"; |
1317
|
0
|
0
|
|
|
|
|
$err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; |
1318
|
0
|
0
|
|
|
|
|
if ($::TODO) { |
1319
|
0
|
|
|
|
|
|
$err_line =~ s/^/# /mg; |
1320
|
0
|
|
|
|
|
|
print $err_line; # Harness can't filter it out from STDERR. |
1321
|
|
|
|
|
|
|
} |
1322
|
|
|
|
|
|
|
else { |
1323
|
0
|
|
|
|
|
|
print STDERR $err_line; |
1324
|
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
|
} |
1326
|
|
|
|
|
|
|
|
1327
|
0
|
0
|
|
|
|
|
if (defined $file) { |
1328
|
0
|
|
|
|
|
|
_ok($ok, "at $file line $line", $name); |
1329
|
|
|
|
|
|
|
} else { |
1330
|
|
|
|
|
|
|
# We don't have file and line number data for the test, so report |
1331
|
|
|
|
|
|
|
# errors as coming from our caller. |
1332
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1333
|
0
|
|
|
|
|
|
ok($ok, $name); |
1334
|
|
|
|
|
|
|
} |
1335
|
|
|
|
|
|
|
|
1336
|
0
|
|
|
|
|
|
foreach (@temps) { |
1337
|
0
|
0
|
|
|
|
|
unlink $_ if $_; |
1338
|
|
|
|
|
|
|
} |
1339
|
0
|
|
|
|
|
|
foreach (@temp_path) { |
1340
|
0
|
0
|
|
|
|
|
File::Path::rmtree $_ if -d $_; |
1341
|
|
|
|
|
|
|
} |
1342
|
|
|
|
|
|
|
} |
1343
|
|
|
|
|
|
|
} |
1344
|
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
|
sub can_ok ($@) { |
1346
|
0
|
|
|
0
|
|
|
my($proto, @methods) = @_; |
1347
|
0
|
|
0
|
|
|
|
my $class = ref $proto || $proto; |
1348
|
|
|
|
|
|
|
|
1349
|
0
|
0
|
|
|
|
|
unless( @methods ) { |
1350
|
0
|
|
|
|
|
|
return _ok( 0, _where(), "$class->can(...)" ); |
1351
|
|
|
|
|
|
|
} |
1352
|
|
|
|
|
|
|
|
1353
|
0
|
|
|
|
|
|
my @nok = (); |
1354
|
0
|
|
|
|
|
|
foreach my $method (@methods) { |
1355
|
0
|
|
|
|
|
|
local($!, $@); # don't interfere with caller's $@ |
1356
|
|
|
|
|
|
|
# eval sometimes resets $! |
1357
|
0
|
0
|
|
|
|
|
eval { $proto->can($method) } || push @nok, $method; |
|
0
|
|
|
|
|
|
|
1358
|
|
|
|
|
|
|
} |
1359
|
|
|
|
|
|
|
|
1360
|
0
|
|
|
|
|
|
my $name; |
1361
|
0
|
0
|
|
|
|
|
$name = @methods == 1 ? "$class->can('$methods[0]')" |
1362
|
|
|
|
|
|
|
: "$class->can(...)"; |
1363
|
|
|
|
|
|
|
|
1364
|
0
|
|
|
|
|
|
_ok( !@nok, _where(), $name ); |
1365
|
|
|
|
|
|
|
} |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
|
1368
|
|
|
|
|
|
|
# Call $class->new( @$args ); and run the result through object_ok. |
1369
|
|
|
|
|
|
|
# See Test::More::new_ok |
1370
|
|
|
|
|
|
|
sub new_ok { |
1371
|
0
|
|
|
0
|
|
|
my($class, $args, $obj_name) = @_; |
1372
|
0
|
|
0
|
|
|
|
$args ||= []; |
1373
|
0
|
0
|
|
|
|
|
$object_name = "The object" unless defined $obj_name; |
1374
|
|
|
|
|
|
|
|
1375
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1376
|
|
|
|
|
|
|
|
1377
|
0
|
|
|
|
|
|
my $obj; |
1378
|
0
|
|
|
|
|
|
my $ok = eval { $obj = $class->new(@$args); 1 }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1379
|
0
|
|
|
|
|
|
my $error = $@; |
1380
|
|
|
|
|
|
|
|
1381
|
0
|
0
|
|
|
|
|
if($ok) { |
1382
|
0
|
|
|
|
|
|
object_ok($obj, $class, $object_name); |
1383
|
|
|
|
|
|
|
} |
1384
|
|
|
|
|
|
|
else { |
1385
|
0
|
|
|
|
|
|
ok( 0, "new() died" ); |
1386
|
0
|
|
|
|
|
|
diag("Error was: $@"); |
1387
|
|
|
|
|
|
|
} |
1388
|
|
|
|
|
|
|
|
1389
|
0
|
|
|
|
|
|
return $obj; |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
} |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
|
sub isa_ok ($$;$) { |
1395
|
0
|
|
|
0
|
|
|
my($object, $class, $obj_name) = @_; |
1396
|
|
|
|
|
|
|
|
1397
|
0
|
|
|
|
|
|
my $diag; |
1398
|
0
|
0
|
|
|
|
|
$obj_name = 'The object' unless defined $obj_name; |
1399
|
0
|
|
|
|
|
|
my $name = "$obj_name isa $class"; |
1400
|
0
|
0
|
|
|
|
|
if( !defined $object ) { |
1401
|
0
|
|
|
|
|
|
$diag = "$obj_name isn't defined"; |
1402
|
|
|
|
|
|
|
} |
1403
|
|
|
|
|
|
|
else { |
1404
|
0
|
0
|
|
|
|
|
my $whatami = ref $object ? 'object' : 'class'; |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
# We can't use UNIVERSAL::isa because we want to honor isa() overrides |
1407
|
0
|
|
|
|
|
|
local($@, $!); # eval sometimes resets $! |
1408
|
0
|
|
|
|
|
|
my $rslt = eval { $object->isa($class) }; |
|
0
|
|
|
|
|
|
|
1409
|
0
|
|
|
|
|
|
my $error = $@; # in case something else blows away $@ |
1410
|
|
|
|
|
|
|
|
1411
|
0
|
0
|
|
|
|
|
if( $error ) { |
|
|
0
|
|
|
|
|
|
1412
|
0
|
0
|
|
|
|
|
if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { |
|
|
0
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
# It's an unblessed reference |
1414
|
0
|
0
|
|
|
|
|
$obj_name = 'The reference' unless defined $obj_name; |
1415
|
0
|
0
|
|
|
|
|
if( !UNIVERSAL::isa($object, $class) ) { |
1416
|
0
|
|
|
|
|
|
my $ref = ref $object; |
1417
|
0
|
|
|
|
|
|
$diag = "$obj_name isn't a '$class' it's a '$ref'"; |
1418
|
|
|
|
|
|
|
} |
1419
|
|
|
|
|
|
|
} |
1420
|
|
|
|
|
|
|
elsif( $error =~ /Can't call method "isa" without a package/ ) { |
1421
|
|
|
|
|
|
|
# It's something that can't even be a class |
1422
|
0
|
0
|
|
|
|
|
$obj_name = 'The thing' unless defined $obj_name; |
1423
|
0
|
|
|
|
|
|
$diag = "$obj_name isn't a class or reference"; |
1424
|
|
|
|
|
|
|
} |
1425
|
|
|
|
|
|
|
else { |
1426
|
0
|
|
|
|
|
|
die <
|
1427
|
|
|
|
|
|
|
WHOA! I tried to call ->isa on your object and got some weird error. |
1428
|
|
|
|
|
|
|
This should never happen. Please contact the author immediately. |
1429
|
|
|
|
|
|
|
Here's the error. |
1430
|
|
|
|
|
|
|
$@ |
1431
|
|
|
|
|
|
|
WHOA |
1432
|
|
|
|
|
|
|
} |
1433
|
|
|
|
|
|
|
} |
1434
|
|
|
|
|
|
|
elsif( !$rslt ) { |
1435
|
0
|
0
|
|
|
|
|
$obj_name = "The $whatami" unless defined $obj_name; |
1436
|
0
|
|
|
|
|
|
my $ref = ref $object; |
1437
|
0
|
|
|
|
|
|
$diag = "$obj_name isn't a '$class' it's a '$ref'"; |
1438
|
|
|
|
|
|
|
} |
1439
|
|
|
|
|
|
|
} |
1440
|
|
|
|
|
|
|
|
1441
|
0
|
|
|
|
|
|
_ok( !$diag, _where(), $name ); |
1442
|
|
|
|
|
|
|
} |
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
|
1445
|
|
|
|
|
|
|
sub class_ok { |
1446
|
0
|
|
|
0
|
|
|
my($class, $isa, $class_name) = @_; |
1447
|
|
|
|
|
|
|
|
1448
|
|
|
|
|
|
|
# Written so as to count as one test |
1449
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1450
|
0
|
0
|
|
|
|
|
if( ref $class ) { |
1451
|
0
|
|
|
|
|
|
ok( 0, "$class is a reference, not a class name" ); |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
else { |
1454
|
0
|
|
|
|
|
|
isa_ok($class, $isa, $class_name); |
1455
|
|
|
|
|
|
|
} |
1456
|
|
|
|
|
|
|
} |
1457
|
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
sub object_ok { |
1460
|
0
|
|
|
0
|
|
|
my($obj, $isa, $obj_name) = @_; |
1461
|
|
|
|
|
|
|
|
1462
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1463
|
0
|
0
|
|
|
|
|
if( !ref $obj ) { |
1464
|
0
|
|
|
|
|
|
ok( 0, "$obj is not a reference" ); |
1465
|
|
|
|
|
|
|
} |
1466
|
|
|
|
|
|
|
else { |
1467
|
0
|
|
|
|
|
|
isa_ok($obj, $isa, $obj_name); |
1468
|
|
|
|
|
|
|
} |
1469
|
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
|
1472
|
|
|
|
|
|
|
# Purposefully avoiding a closure. |
1473
|
|
|
|
|
|
|
sub __capture { |
1474
|
0
|
|
|
0
|
|
|
push @::__capture, join "", @_; |
1475
|
|
|
|
|
|
|
} |
1476
|
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
|
sub capture_warnings { |
1478
|
0
|
|
|
0
|
|
|
my $code = shift; |
1479
|
|
|
|
|
|
|
|
1480
|
0
|
|
|
|
|
|
local @::__capture; |
1481
|
0
|
|
|
|
|
|
local $SIG {__WARN__} = \&__capture; |
1482
|
0
|
|
|
|
|
|
&$code; |
1483
|
0
|
|
|
|
|
|
return @::__capture; |
1484
|
|
|
|
|
|
|
} |
1485
|
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
|
# This will generate a variable number of tests. |
1487
|
|
|
|
|
|
|
# Use done_testing() instead of a fixed plan. |
1488
|
|
|
|
|
|
|
sub warnings_like { |
1489
|
0
|
|
|
0
|
|
|
my ($code, $expect, $name) = @_; |
1490
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1491
|
|
|
|
|
|
|
|
1492
|
0
|
|
|
|
|
|
my @w = capture_warnings($code); |
1493
|
|
|
|
|
|
|
|
1494
|
0
|
|
|
|
|
|
cmp_ok(scalar @w, '==', scalar @$expect, $name); |
1495
|
0
|
|
|
|
|
|
foreach my $e (@$expect) { |
1496
|
0
|
0
|
|
|
|
|
if (ref $e) { |
1497
|
0
|
|
|
|
|
|
like(shift @w, $e, $name); |
1498
|
|
|
|
|
|
|
} else { |
1499
|
0
|
|
|
|
|
|
is(shift @w, $e, $name); |
1500
|
|
|
|
|
|
|
} |
1501
|
|
|
|
|
|
|
} |
1502
|
0
|
0
|
|
|
|
|
if (@w) { |
1503
|
0
|
|
|
|
|
|
diag("Saw these additional warnings:"); |
1504
|
0
|
|
|
|
|
|
diag($_) foreach @w; |
1505
|
|
|
|
|
|
|
} |
1506
|
|
|
|
|
|
|
} |
1507
|
|
|
|
|
|
|
|
1508
|
|
|
|
|
|
|
sub _fail_excess_warnings { |
1509
|
0
|
|
|
0
|
|
|
my($expect, $got, $name) = @_; |
1510
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1511
|
|
|
|
|
|
|
# This will fail, and produce diagnostics |
1512
|
0
|
|
|
|
|
|
is($expect, scalar @$got, $name); |
1513
|
0
|
|
|
|
|
|
diag("Saw these warnings:"); |
1514
|
0
|
|
|
|
|
|
diag($_) foreach @$got; |
1515
|
|
|
|
|
|
|
} |
1516
|
|
|
|
|
|
|
|
1517
|
|
|
|
|
|
|
sub warning_is { |
1518
|
0
|
|
|
0
|
|
|
my ($code, $expect, $name) = @_; |
1519
|
0
|
0
|
|
|
|
|
die sprintf "Expect must be a string or undef, not a %s reference", ref $expect |
1520
|
|
|
|
|
|
|
if ref $expect; |
1521
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1522
|
0
|
|
|
|
|
|
my @w = capture_warnings($code); |
1523
|
0
|
0
|
|
|
|
|
if (@w > 1) { |
1524
|
0
|
|
|
|
|
|
_fail_excess_warnings(0 + defined $expect, \@w, $name); |
1525
|
|
|
|
|
|
|
} else { |
1526
|
0
|
|
|
|
|
|
is($w[0], $expect, $name); |
1527
|
|
|
|
|
|
|
} |
1528
|
|
|
|
|
|
|
} |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
sub warning_like { |
1531
|
0
|
|
|
0
|
|
|
my ($code, $expect, $name) = @_; |
1532
|
0
|
0
|
|
|
|
|
die sprintf "Expect must be a regexp object" |
1533
|
|
|
|
|
|
|
unless ref $expect eq 'Regexp'; |
1534
|
0
|
|
|
|
|
|
local $Level = $Level + 1; |
1535
|
0
|
|
|
|
|
|
my @w = capture_warnings($code); |
1536
|
0
|
0
|
|
|
|
|
if (@w > 1) { |
1537
|
0
|
|
|
|
|
|
_fail_excess_warnings(0 + defined $expect, \@w, $name); |
1538
|
|
|
|
|
|
|
} else { |
1539
|
0
|
|
|
|
|
|
like($w[0], $expect, $name); |
1540
|
|
|
|
|
|
|
} |
1541
|
|
|
|
|
|
|
} |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
# Set a watchdog to timeout the entire test file |
1544
|
|
|
|
|
|
|
# NOTE: If the test file uses 'threads', then call the watchdog() function |
1545
|
|
|
|
|
|
|
# _AFTER_ the 'threads' module is loaded. |
1546
|
|
|
|
|
|
|
sub watchdog ($;$) |
1547
|
|
|
|
|
|
|
{ |
1548
|
0
|
|
|
0
|
|
|
my $timeout = shift; |
1549
|
0
|
|
0
|
|
|
|
my $method = shift || ""; |
1550
|
0
|
|
|
|
|
|
my $timeout_msg = 'Test process timed out - terminating'; |
1551
|
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
|
# Valgrind slows perl way down so give it more time before dying. |
1553
|
0
|
0
|
|
|
|
|
$timeout *= 10 if $ENV{PERL_VALGRIND}; |
1554
|
|
|
|
|
|
|
|
1555
|
0
|
|
|
|
|
|
my $pid_to_kill = $$; # PID for this process |
1556
|
|
|
|
|
|
|
|
1557
|
0
|
0
|
|
|
|
|
if ($method eq "alarm") { |
1558
|
0
|
|
|
|
|
|
goto WATCHDOG_VIA_ALARM; |
1559
|
|
|
|
|
|
|
} |
1560
|
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
|
# shut up use only once warning |
1562
|
0
|
|
0
|
|
|
|
my $threads_on = $threads::threads && $threads::threads; |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
# Don't use a watchdog process if 'threads' is loaded - |
1565
|
|
|
|
|
|
|
# use a watchdog thread instead |
1566
|
0
|
0
|
0
|
|
|
|
if (!$threads_on || $method eq "process") { |
1567
|
|
|
|
|
|
|
|
1568
|
|
|
|
|
|
|
# On Windows and VMS, try launching a watchdog process |
1569
|
|
|
|
|
|
|
# using system(1, ...) (see perlport.pod) |
1570
|
0
|
0
|
0
|
|
|
|
if ($is_mswin || $is_vms) { |
1571
|
|
|
|
|
|
|
# On Windows, try to get the 'real' PID |
1572
|
0
|
0
|
|
|
|
|
if ($is_mswin) { |
1573
|
0
|
|
|
|
|
|
eval { require Win32; }; |
|
0
|
|
|
|
|
|
|
1574
|
0
|
0
|
|
|
|
|
if (defined(&Win32::GetCurrentProcessId)) { |
1575
|
0
|
|
|
|
|
|
$pid_to_kill = Win32::GetCurrentProcessId(); |
1576
|
|
|
|
|
|
|
} |
1577
|
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
# If we still have a fake PID, we can't use this method at all |
1580
|
0
|
0
|
|
|
|
|
return if ($pid_to_kill <= 0); |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
# Launch watchdog process |
1583
|
0
|
|
|
|
|
|
my $watchdog; |
1584
|
0
|
|
|
|
|
|
eval { |
1585
|
|
|
|
|
|
|
local $SIG{'__WARN__'} = sub { |
1586
|
0
|
|
|
0
|
|
|
_diag("Watchdog warning: $_[0]"); |
1587
|
0
|
|
|
|
|
|
}; |
1588
|
0
|
0
|
|
|
|
|
my $sig = $is_vms ? 'TERM' : 'KILL'; |
1589
|
0
|
|
|
|
|
|
my $prog = "sleep($timeout);" . |
1590
|
|
|
|
|
|
|
"warn qq/# $timeout_msg" . '\n/;' . |
1591
|
|
|
|
|
|
|
"kill(q/$sig/, $pid_to_kill);"; |
1592
|
|
|
|
|
|
|
|
1593
|
|
|
|
|
|
|
# On Windows use the indirect object plus LIST form to guarantee |
1594
|
|
|
|
|
|
|
# that perl is launched directly rather than via the shell (see |
1595
|
|
|
|
|
|
|
# perlfunc.pod), and ensure that the LIST has multiple elements |
1596
|
|
|
|
|
|
|
# since the indirect object plus COMMANDSTRING form seems to |
1597
|
|
|
|
|
|
|
# hang (see perl #121283). Don't do this on VMS, which doesn't |
1598
|
|
|
|
|
|
|
# support the LIST form at all. |
1599
|
0
|
0
|
|
|
|
|
if ($is_mswin) { |
1600
|
0
|
|
|
|
|
|
my $runperl = which_perl(); |
1601
|
0
|
0
|
|
|
|
|
if ($runperl =~ m/\s/) { |
1602
|
0
|
|
|
|
|
|
$runperl = qq{"$runperl"}; |
1603
|
|
|
|
|
|
|
} |
1604
|
0
|
|
|
|
|
|
$watchdog = system({ $runperl } 1, $runperl, '-e', $prog); |
|
0
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
|
} |
1606
|
|
|
|
|
|
|
else { |
1607
|
0
|
|
|
|
|
|
my $cmd = _create_runperl(prog => $prog); |
1608
|
0
|
|
|
|
|
|
$watchdog = system(1, $cmd); |
1609
|
|
|
|
|
|
|
} |
1610
|
|
|
|
|
|
|
}; |
1611
|
0
|
0
|
0
|
|
|
|
if ($@ || ($watchdog <= 0)) { |
1612
|
0
|
|
|
|
|
|
_diag('Failed to start watchdog'); |
1613
|
0
|
0
|
|
|
|
|
_diag($@) if $@; |
1614
|
0
|
|
|
|
|
|
undef($watchdog); |
1615
|
0
|
|
|
|
|
|
return; |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
|
1618
|
|
|
|
|
|
|
# Add END block to parent to terminate and |
1619
|
|
|
|
|
|
|
# clean up watchdog process |
1620
|
0
|
|
|
|
|
|
eval("END { local \$! = 0; local \$? = 0; |
1621
|
|
|
|
|
|
|
wait() if kill('KILL', $watchdog); };"); |
1622
|
0
|
|
|
|
|
|
return; |
1623
|
|
|
|
|
|
|
} |
1624
|
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
|
# Try using fork() to generate a watchdog process |
1626
|
0
|
|
|
|
|
|
my $watchdog; |
1627
|
0
|
|
|
|
|
|
eval { $watchdog = fork() }; |
|
0
|
|
|
|
|
|
|
1628
|
0
|
0
|
|
|
|
|
if (defined($watchdog)) { |
1629
|
0
|
0
|
|
|
|
|
if ($watchdog) { # Parent process |
1630
|
|
|
|
|
|
|
# Add END block to parent to terminate and |
1631
|
|
|
|
|
|
|
# clean up watchdog process |
1632
|
0
|
|
|
|
|
|
eval "END { local \$! = 0; local \$? = 0; |
1633
|
|
|
|
|
|
|
wait() if kill('KILL', $watchdog); };"; |
1634
|
0
|
|
|
|
|
|
return; |
1635
|
|
|
|
|
|
|
} |
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
### Watchdog process code |
1638
|
|
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
# Load POSIX if available |
1640
|
0
|
|
|
|
|
|
eval { require POSIX; }; |
|
0
|
|
|
|
|
|
|
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
# Execute the timeout |
1643
|
0
|
0
|
|
|
|
|
sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 |
1644
|
0
|
|
|
|
|
|
sleep(2); |
1645
|
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
|
# Kill test process if still running |
1647
|
0
|
0
|
|
|
|
|
if (kill(0, $pid_to_kill)) { |
1648
|
0
|
|
|
|
|
|
_diag($timeout_msg); |
1649
|
0
|
|
|
|
|
|
kill('KILL', $pid_to_kill); |
1650
|
0
|
0
|
|
|
|
|
if ($is_cygwin) { |
1651
|
|
|
|
|
|
|
# sometimes the above isn't enough on cygwin |
1652
|
0
|
|
|
|
|
|
sleep 1; # wait a little, it might have worked after all |
1653
|
0
|
|
|
|
|
|
system("/bin/kill -f $pid_to_kill"); |
1654
|
|
|
|
|
|
|
} |
1655
|
|
|
|
|
|
|
} |
1656
|
|
|
|
|
|
|
|
1657
|
|
|
|
|
|
|
# Don't execute END block (added at beginning of this file) |
1658
|
0
|
|
|
|
|
|
$NO_ENDING = 1; |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
# Terminate ourself (i.e., the watchdog) |
1661
|
0
|
0
|
|
|
|
|
POSIX::_exit(1) if (defined(&POSIX::_exit)); |
1662
|
0
|
|
|
|
|
|
exit(1); |
1663
|
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
|
# fork() failed - fall through and try using a thread |
1666
|
|
|
|
|
|
|
} |
1667
|
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
|
# Use a watchdog thread because either 'threads' is loaded, |
1669
|
|
|
|
|
|
|
# or fork() failed |
1670
|
0
|
0
|
|
|
|
|
if (eval {require threads; 1}) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
'threads'->create(sub { |
1672
|
|
|
|
|
|
|
# Load POSIX if available |
1673
|
0
|
|
|
0
|
|
|
eval { require POSIX; }; |
|
0
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
|
|
1675
|
|
|
|
|
|
|
# Execute the timeout |
1676
|
0
|
|
|
|
|
|
my $time_left = $timeout; |
1677
|
0
|
|
|
|
|
|
do { |
1678
|
0
|
|
|
|
|
|
$time_left = $time_left - sleep($time_left); |
1679
|
|
|
|
|
|
|
} while ($time_left > 0); |
1680
|
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
# Kill the parent (and ourself) |
1682
|
0
|
|
|
|
|
|
select(STDERR); $| = 1; |
|
0
|
|
|
|
|
|
|
1683
|
0
|
|
|
|
|
|
_diag($timeout_msg); |
1684
|
0
|
0
|
|
|
|
|
POSIX::_exit(1) if (defined(&POSIX::_exit)); |
1685
|
0
|
0
|
|
|
|
|
my $sig = $is_vms ? 'TERM' : 'KILL'; |
1686
|
0
|
|
|
|
|
|
kill($sig, $pid_to_kill); |
1687
|
0
|
|
|
|
|
|
})->detach(); |
1688
|
0
|
|
|
|
|
|
return; |
1689
|
|
|
|
|
|
|
} |
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
# If everything above fails, then just use an alarm timeout |
1692
|
|
|
|
|
|
|
WATCHDOG_VIA_ALARM: |
1693
|
0
|
0
|
|
|
|
|
if (eval { alarm($timeout); 1; }) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
# Load POSIX if available |
1695
|
0
|
|
|
|
|
|
eval { require POSIX; }; |
|
0
|
|
|
|
|
|
|
1696
|
|
|
|
|
|
|
|
1697
|
|
|
|
|
|
|
# Alarm handler will do the actual 'killing' |
1698
|
|
|
|
|
|
|
$SIG{'ALRM'} = sub { |
1699
|
0
|
|
|
0
|
|
|
select(STDERR); $| = 1; |
|
0
|
|
|
|
|
|
|
1700
|
0
|
|
|
|
|
|
_diag($timeout_msg); |
1701
|
0
|
0
|
|
|
|
|
POSIX::_exit(1) if (defined(&POSIX::_exit)); |
1702
|
0
|
0
|
|
|
|
|
my $sig = $is_vms ? 'TERM' : 'KILL'; |
1703
|
0
|
|
|
|
|
|
kill($sig, $pid_to_kill); |
1704
|
0
|
|
|
|
|
|
}; |
1705
|
|
|
|
|
|
|
} |
1706
|
|
|
|
|
|
|
} |
1707
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
1; |