line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test2::Harness::Runner; |
2
|
24
|
|
|
24
|
|
124448
|
use strict; |
|
24
|
|
|
|
|
25
|
|
|
24
|
|
|
|
|
505
|
|
3
|
24
|
|
|
24
|
|
50
|
use warnings; |
|
24
|
|
|
|
|
25
|
|
|
24
|
|
|
|
|
673
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.000013'; |
6
|
|
|
|
|
|
|
|
7
|
24
|
|
|
24
|
|
8136
|
use Test2::Event::Diag; |
|
24
|
|
|
|
|
4518
|
|
|
24
|
|
|
|
|
420
|
|
8
|
24
|
|
|
24
|
|
7236
|
use Test2::Harness::Proc; |
|
24
|
|
|
|
|
47
|
|
|
24
|
|
|
|
|
598
|
|
9
|
24
|
|
|
24
|
|
100
|
use Config; |
|
24
|
|
|
|
|
23
|
|
|
24
|
|
|
|
|
730
|
|
10
|
|
|
|
|
|
|
|
11
|
24
|
|
|
24
|
|
72
|
use Test2::Util::HashBase qw/headers merge via _preload_list/; |
|
24
|
|
|
|
|
25
|
|
|
24
|
|
|
|
|
51
|
|
12
|
24
|
|
|
24
|
|
2425
|
use Test2::Util qw/CAN_REALLY_FORK/; |
|
24
|
|
|
|
|
24
|
|
|
24
|
|
|
|
|
822
|
|
13
|
|
|
|
|
|
|
|
14
|
24
|
|
|
24
|
|
74
|
use Carp qw/croak/; |
|
24
|
|
|
|
|
24
|
|
|
24
|
|
|
|
|
802
|
|
15
|
24
|
|
|
24
|
|
73
|
use Symbol qw/gensym/; |
|
24
|
|
|
|
|
23
|
|
|
24
|
|
|
|
|
858
|
|
16
|
24
|
|
|
24
|
|
10369
|
use IPC::Open3 qw/open3/; |
|
24
|
|
|
|
|
46551
|
|
|
24
|
|
|
|
|
1150
|
|
17
|
24
|
|
|
24
|
|
14349
|
use File::Temp qw/tempfile/; |
|
24
|
|
|
|
|
237419
|
|
|
24
|
|
|
|
|
1203
|
|
18
|
24
|
|
|
24
|
|
99
|
use Scalar::Util 'openhandle'; |
|
24
|
|
|
|
|
24
|
|
|
24
|
|
|
|
|
32182
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
our ($DO_FILE, $SET_ENV); |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub init { |
23
|
70
|
|
|
70
|
0
|
115872
|
my $self = shift; |
24
|
70
|
|
|
|
|
246
|
$self->{+HEADERS} = {}; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
croak "'$self->{+VIA}' is not a valid value for the 'via' attribute" |
27
|
70
|
50
|
66
|
|
|
718
|
if exists($self->{+VIA}) && !$self->can("via_$self->{+VIA}"); |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
sub fatal_error { |
31
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
32
|
0
|
|
|
|
|
0
|
my ($msg) = @_; |
33
|
|
|
|
|
|
|
|
34
|
0
|
|
|
|
|
0
|
print STDERR <<" EOT"; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
******************************************************************************* |
37
|
|
|
|
|
|
|
* * |
38
|
|
|
|
|
|
|
* Test2::Harness::Runner * |
39
|
|
|
|
|
|
|
* INTERNAL FATAL ERROR * |
40
|
|
|
|
|
|
|
* * |
41
|
|
|
|
|
|
|
******************************************************************************* |
42
|
|
|
|
|
|
|
$msg |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
EOT |
45
|
|
|
|
|
|
|
|
46
|
0
|
|
|
|
|
0
|
CORE::exit(255); |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub start { |
50
|
625
|
|
|
625
|
0
|
858
|
my $self = shift; |
51
|
625
|
|
|
|
|
1768
|
my ($file, %params) = @_; |
52
|
|
|
|
|
|
|
|
53
|
625
|
50
|
|
|
|
13457
|
die "'$file' is not a valid test file" |
54
|
|
|
|
|
|
|
unless -f $file; |
55
|
|
|
|
|
|
|
|
56
|
625
|
|
|
|
|
2907
|
my $header = $self->header($file); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# Localize+copy |
59
|
625
|
|
|
|
|
5480
|
local $ENV{T2_FORMATTER} = $ENV{T2_FORMATTER}; |
60
|
625
|
100
|
66
|
|
|
2093
|
if (exists $header->{features}->{formatter} && !$header->{features}->{formatter}) { |
61
|
26
|
|
|
|
|
99
|
delete $ENV{T2_FORMATTER}; |
62
|
|
|
|
|
|
|
|
63
|
26
|
|
|
|
|
78
|
my $env = $params{env}; |
64
|
|
|
|
|
|
|
delete $env->{T2_FORMATTER} |
65
|
26
|
50
|
|
|
|
162
|
if $env; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
625
|
|
|
|
|
1522
|
my $via = $self->{+VIA}; |
69
|
|
|
|
|
|
|
|
70
|
625
|
100
|
|
|
|
1245
|
return $self->via_open3(@_) unless $via; |
71
|
621
|
100
|
|
|
|
2829
|
return $self->via_open3(@_) if $via eq 'open3'; |
72
|
|
|
|
|
|
|
|
73
|
222
|
50
|
|
|
|
1857
|
unless (CAN_REALLY_FORK) { |
74
|
0
|
|
|
|
|
0
|
my $event = Test2::Event::Diag->new( |
75
|
|
|
|
|
|
|
message => "This system is not capable of forking, falling back to IPC::Open3.", |
76
|
|
|
|
|
|
|
diagnostics => 1, |
77
|
|
|
|
|
|
|
); |
78
|
|
|
|
|
|
|
|
79
|
0
|
|
|
|
|
0
|
my $proc = $self->via_open3(@_); |
80
|
0
|
|
|
|
|
0
|
return ($proc, $event); |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
222
|
100
|
|
|
|
3898
|
if ($header->{switches}) { |
84
|
6
|
|
|
|
|
114
|
my $event = Test2::Event::Diag->new( |
85
|
|
|
|
|
|
|
message => "Test file '$file' uses switches in the #! line, Falling back to IPC::Open3.", |
86
|
|
|
|
|
|
|
diagnostics => 1, |
87
|
|
|
|
|
|
|
); |
88
|
|
|
|
|
|
|
|
89
|
6
|
|
|
|
|
210
|
my $proc = $self->via_open3(@_); |
90
|
6
|
|
|
|
|
132
|
return ($proc, $event); |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
216
|
50
|
33
|
|
|
1483
|
if (exists($header->{features}->{preload}) && !$header->{features}->{preload}) { |
94
|
0
|
|
|
|
|
0
|
my $event = Test2::Event::Diag->new( |
95
|
|
|
|
|
|
|
message => "Test file '$file' uses has turned off preloading, Falling back to IPC::Open3.", |
96
|
|
|
|
|
|
|
diagnostics => 1, |
97
|
|
|
|
|
|
|
); |
98
|
|
|
|
|
|
|
|
99
|
0
|
|
|
|
|
0
|
my $proc = $self->via_open3(@_); |
100
|
0
|
|
|
|
|
0
|
return ($proc, $event); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
$self->fatal_error("You cannot use switches with preloading, aborting...") |
104
|
216
|
50
|
|
|
|
477
|
if @{$params{switches}}; |
|
216
|
|
|
|
|
1163
|
|
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
$self->fatal_error("Something preloaded Test::Builder, aborting...") |
107
|
216
|
50
|
|
|
|
1159
|
if $INC{'Test/Builder.pm'}; |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
$self->fatal_error("Something preloaded and initialized Test2::API, Aborting...") |
110
|
216
|
50
|
33
|
|
|
1244
|
if $INC{'Test2/API.pm'} && Test2::API::test2_init_done(); |
111
|
|
|
|
|
|
|
|
112
|
216
|
|
|
|
|
1920
|
return $self->via_do(@_); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub _parse_shbang { |
116
|
679
|
|
|
679
|
|
15314
|
my $self = shift; |
117
|
679
|
|
|
|
|
1157
|
my $line = shift; |
118
|
|
|
|
|
|
|
|
119
|
679
|
50
|
|
|
|
1381
|
return {} if !defined $line; |
120
|
|
|
|
|
|
|
|
121
|
679
|
|
|
|
|
1017
|
my %shbang; |
122
|
|
|
|
|
|
|
|
123
|
679
|
|
|
|
|
4396
|
my $shbang_re = qr{ |
124
|
|
|
|
|
|
|
^ |
125
|
|
|
|
|
|
|
\#!.*\bperl.*? # the perl path |
126
|
|
|
|
|
|
|
(?: \s (-.+) )? # the switches, maybe |
127
|
|
|
|
|
|
|
\s* |
128
|
|
|
|
|
|
|
$ |
129
|
|
|
|
|
|
|
}xi; |
130
|
|
|
|
|
|
|
|
131
|
679
|
100
|
|
|
|
4974
|
if ( $line =~ $shbang_re ) { |
132
|
67
|
100
|
|
|
|
470
|
my @switches = grep { m/\S/ } split /\s+/, $1 if defined $1; |
|
61
|
|
|
|
|
280
|
|
133
|
67
|
|
|
|
|
179
|
$shbang{switches} = \@switches; |
134
|
67
|
|
|
|
|
177
|
$shbang{shbang} = $line; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
679
|
|
|
|
|
2349
|
return \%shbang; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub header { |
141
|
1278
|
|
|
1278
|
0
|
12896
|
my $self = shift; |
142
|
1278
|
|
|
|
|
1589
|
my ($file) = @_; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
return $self->{+HEADERS}->{$file} |
145
|
1278
|
100
|
|
|
|
4289
|
if $self->{+HEADERS}->{$file}; |
146
|
|
|
|
|
|
|
|
147
|
653
|
|
|
|
|
3319
|
my %header = ( |
148
|
|
|
|
|
|
|
shbang => "", |
149
|
|
|
|
|
|
|
features => {}, |
150
|
|
|
|
|
|
|
); |
151
|
|
|
|
|
|
|
|
152
|
653
|
50
|
|
|
|
27902
|
open(my $fh, '<', $file) or die "Could not open file $file: $!"; |
153
|
|
|
|
|
|
|
|
154
|
653
|
|
|
|
|
11966
|
for(my $ln = 0; my $line = <$fh>; $ln++) { |
155
|
3277
|
|
|
|
|
3182
|
chomp($line); |
156
|
3277
|
100
|
|
|
|
9311
|
next if $line =~ m/^\s*$/; |
157
|
|
|
|
|
|
|
|
158
|
2509
|
100
|
|
|
|
3587
|
if( $ln == 0 ) { |
159
|
649
|
|
|
|
|
2449
|
my $shbang = $self->_parse_shbang($line); |
160
|
649
|
|
|
|
|
2599
|
for my $key (keys %$shbang) { |
161
|
98
|
50
|
|
|
|
347
|
$header{$key} = $shbang->{$key} if defined $shbang->{$key}; |
162
|
|
|
|
|
|
|
} |
163
|
649
|
100
|
|
|
|
2270
|
next if $shbang->{shbang}; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
2460
|
100
|
|
|
|
8967
|
next if $line =~ m/^(use|require|BEGIN)/; |
167
|
659
|
100
|
|
|
|
2208
|
last unless $line =~ m/^\s*#/; |
168
|
|
|
|
|
|
|
|
169
|
32
|
50
|
|
|
|
254
|
next unless $line =~ m/^\s*#\s*HARNESS-(.+)$/; |
170
|
|
|
|
|
|
|
|
171
|
32
|
|
|
|
|
264
|
my ($dir, @args) = split /-/, lc($1); |
172
|
32
|
100
|
|
|
|
149
|
if($dir eq 'no') { |
|
|
50
|
|
|
|
|
|
173
|
28
|
|
|
|
|
82
|
my ($feature) = @args; |
174
|
28
|
|
|
|
|
188
|
$header{features}->{$feature} = 0; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
elsif($dir eq 'yes') { |
177
|
4
|
|
|
|
|
5
|
my ($feature) = @args; |
178
|
4
|
|
|
|
|
22
|
$header{features}->{$feature} = 1; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
else { |
181
|
0
|
|
|
|
|
0
|
warn "Unknown harness directive '$dir' at $file line $ln.\n"; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
} |
184
|
653
|
|
|
|
|
4842
|
close($fh); |
185
|
|
|
|
|
|
|
|
186
|
653
|
|
|
|
|
4320
|
$self->{+HEADERS}->{$file} = \%header; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub via_open3 { |
190
|
409
|
|
|
409
|
1
|
527
|
my $self = shift; |
191
|
409
|
|
|
|
|
1466
|
my ($file, %params) = @_; |
192
|
|
|
|
|
|
|
|
193
|
409
|
50
|
|
|
|
1514
|
return $self->via_win32(@_) |
194
|
|
|
|
|
|
|
if $^O eq 'MSWin32'; |
195
|
|
|
|
|
|
|
|
196
|
409
|
|
50
|
|
|
891
|
my $env = $params{env} || {}; |
197
|
409
|
|
|
|
|
746
|
my $libs = $params{libs}; |
198
|
409
|
|
|
|
|
411
|
my $switches = $params{switches}; |
199
|
409
|
|
|
|
|
843
|
my $header = $self->header($file); |
200
|
|
|
|
|
|
|
|
201
|
409
|
|
|
|
|
2079
|
my $in = gensym; |
202
|
409
|
|
|
|
|
6782
|
my $out = gensym; |
203
|
409
|
50
|
|
|
|
3147
|
my $err = $self->{+MERGE} ? $out : gensym; |
204
|
|
|
|
|
|
|
|
205
|
409
|
|
|
|
|
2414
|
my @switches; |
206
|
409
|
50
|
|
|
|
1408
|
push @switches => map { ("-I$_") } @$libs if $libs; |
|
4463
|
|
|
|
|
7182
|
|
207
|
409
|
|
50
|
|
|
13719
|
push @switches => map { ("-I$_") } split $Config{path_sep}, ($ENV{PERL5LIB} || ""); |
|
818
|
|
|
|
|
1719
|
|
208
|
409
|
50
|
|
|
|
1923
|
push @switches => @$switches if $switches; |
209
|
409
|
100
|
|
|
|
774
|
push @switches => @{$header->{switches}} if $header->{switches}; |
|
27
|
|
|
|
|
108
|
|
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# local $ENV{$_} = $env->{$_} for keys %$env; does not work... |
212
|
409
|
|
|
|
|
7991
|
my $old = {%ENV}; |
213
|
409
|
|
|
|
|
6385
|
$ENV{$_} = $env->{$_} for keys %$env; |
214
|
|
|
|
|
|
|
|
215
|
409
|
|
|
|
|
3032
|
my $pid = open3( |
216
|
|
|
|
|
|
|
$in, $out, $err, |
217
|
|
|
|
|
|
|
$^X, @switches, $file |
218
|
|
|
|
|
|
|
); |
219
|
|
|
|
|
|
|
|
220
|
409
|
|
|
|
|
787129
|
$ENV{$_} = $old->{$_} for keys %$env; |
221
|
|
|
|
|
|
|
|
222
|
409
|
50
|
|
|
|
1638
|
die "Failed to execute '" . join(' ' => $^X, @switches, $file) . "'" unless $pid; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
my $proc = Test2::Harness::Proc->new( |
225
|
|
|
|
|
|
|
file => $file, |
226
|
|
|
|
|
|
|
pid => $pid, |
227
|
|
|
|
|
|
|
in_fh => $in, |
228
|
|
|
|
|
|
|
out_fh => $out, |
229
|
409
|
50
|
|
|
|
7068
|
err_fh => $self->{+MERGE} ? undef : $err, |
230
|
|
|
|
|
|
|
); |
231
|
|
|
|
|
|
|
|
232
|
409
|
|
|
|
|
16043
|
return $proc; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub via_do { |
236
|
216
|
|
|
216
|
1
|
425
|
my $self = shift; |
237
|
216
|
|
|
|
|
939
|
my ($file, %params) = @_; |
238
|
|
|
|
|
|
|
|
239
|
216
|
|
50
|
|
|
1074
|
my $env = $params{env} || {}; |
240
|
216
|
|
|
|
|
585
|
my $libs = $params{libs}; |
241
|
216
|
|
|
|
|
496
|
my $header = $self->header($file); |
242
|
|
|
|
|
|
|
|
243
|
216
|
|
|
|
|
336
|
my ($in_read, $in_write, $out_read, $out_write, $err_read, $err_write); |
244
|
|
|
|
|
|
|
|
245
|
216
|
50
|
|
|
|
4422
|
pipe($in_read, $in_write) or die "Could not open pipe!"; |
246
|
216
|
50
|
|
|
|
2960
|
pipe($out_read, $out_write) or die "Could not open pipe!"; |
247
|
216
|
50
|
|
|
|
765
|
if ($self->{+MERGE}) { |
248
|
0
|
|
|
|
|
0
|
($err_read, $err_write) = ($out_read, $out_write); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
else { |
251
|
216
|
50
|
|
|
|
2893
|
pipe($err_read, $err_write) or die "Could not open pipe!"; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Generate the preload list |
255
|
216
|
|
|
|
|
1346
|
$self->preload_list; |
256
|
|
|
|
|
|
|
|
257
|
216
|
|
|
|
|
114127
|
my $pid = fork; |
258
|
216
|
50
|
|
|
|
4511
|
die "Could not fork!" unless defined $pid; |
259
|
|
|
|
|
|
|
|
260
|
216
|
100
|
|
|
|
3922
|
if ($pid) { |
261
|
|
|
|
|
|
|
return Test2::Harness::Proc->new( |
262
|
|
|
|
|
|
|
file => $file, |
263
|
|
|
|
|
|
|
pid => $pid, |
264
|
|
|
|
|
|
|
in_fh => $in_write, |
265
|
|
|
|
|
|
|
out_fh => $out_read, |
266
|
196
|
50
|
|
|
|
13262
|
err_fh => $self->{+MERGE} ? undef : $err_read, |
267
|
|
|
|
|
|
|
) |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
20
|
|
|
|
|
1233
|
close(STDIN); |
271
|
20
|
50
|
|
|
|
1752
|
open(STDIN, '<&', $in_read) || die "Could not open new STDIN: $!"; |
272
|
|
|
|
|
|
|
|
273
|
20
|
|
|
|
|
442
|
close(STDOUT); |
274
|
20
|
50
|
|
|
|
947
|
open(STDOUT, '>&', $out_write) || die "Could not open new STDOUT: $!"; |
275
|
|
|
|
|
|
|
|
276
|
20
|
|
|
|
|
531
|
close(STDERR); |
277
|
20
|
50
|
|
|
|
811
|
open(STDERR, '>&', $err_write) || die "Could not open new STDERR: $!"; |
278
|
|
|
|
|
|
|
|
279
|
20
|
50
|
|
|
|
1633
|
unshift @INC => @$libs if $libs; |
280
|
20
|
|
|
|
|
351
|
@ARGV = (); |
281
|
|
|
|
|
|
|
|
282
|
20
|
|
|
0
|
|
1002
|
$SET_ENV = sub { $ENV{$_} = $env->{$_} for keys %$env }; |
|
0
|
|
|
|
|
0
|
|
283
|
|
|
|
|
|
|
|
284
|
20
|
|
|
|
|
160
|
$DO_FILE = $file; |
285
|
20
|
|
|
|
|
1210
|
$0 = $file; |
286
|
|
|
|
|
|
|
|
287
|
20
|
|
|
|
|
751
|
$self->reset_DATA($file); |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# Stuff copied shamelessly from forkprove |
290
|
|
|
|
|
|
|
#################### |
291
|
|
|
|
|
|
|
# if FindBin is preloaded, reset it with the new $0 |
292
|
20
|
50
|
|
|
|
214
|
FindBin::init() if defined &FindBin::init; |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# restore defaults |
295
|
20
|
|
|
|
|
536
|
Getopt::Long::ConfigDefaults(); |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# reset the state of empty pattern matches, so that they have the same |
298
|
|
|
|
|
|
|
# behavior as running in a clean process. |
299
|
|
|
|
|
|
|
# see "The empty pattern //" in perlop. |
300
|
|
|
|
|
|
|
# note that this has to be dynamically scoped and can't go to other subs |
301
|
20
|
|
|
|
|
1085
|
"" =~ /^/; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# Test::Builder is loaded? Reset the $Test object to make it unaware |
304
|
|
|
|
|
|
|
# that it's a forked off proecess so that subtests won't run |
305
|
20
|
50
|
|
|
|
268
|
if ($INC{'Test/Builder.pm'}) { |
306
|
0
|
0
|
|
|
|
0
|
if (defined $Test::Builder::Test) { |
307
|
0
|
|
|
|
|
0
|
$Test::Builder::Test->reset; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
else { |
310
|
0
|
|
|
|
|
0
|
Test::Builder->new; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# avoid child processes sharing the same seed value as the parent |
315
|
20
|
|
|
|
|
650
|
srand(); |
316
|
|
|
|
|
|
|
#################### |
317
|
|
|
|
|
|
|
# End stuff copied from forkprove |
318
|
|
|
|
|
|
|
|
319
|
20
|
|
|
|
|
267
|
my $ok = eval { |
320
|
24
|
|
|
24
|
|
122
|
no warnings 'exiting'; |
|
24
|
|
|
|
|
46
|
|
|
24
|
|
|
|
|
3512
|
|
321
|
20
|
|
|
|
|
27741
|
last T2_DO_FILE; |
322
|
0
|
|
|
|
|
0
|
1; |
323
|
|
|
|
|
|
|
}; |
324
|
0
|
|
|
|
|
0
|
my $err = $@; |
325
|
|
|
|
|
|
|
|
326
|
0
|
0
|
|
|
|
0
|
die $err unless $err =~ m/Label not found for "last T2_DO_FILE"/; |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
# Test files do not always return a true value, so we cannot use require. We |
329
|
|
|
|
|
|
|
# also cannot trust $! |
330
|
|
|
|
|
|
|
package main; |
331
|
0
|
|
|
|
|
0
|
$Test2::Harness::Runner::SET_ENV->(); |
332
|
0
|
|
|
|
|
0
|
$@ = ''; |
333
|
0
|
|
|
|
|
0
|
do $file; |
334
|
0
|
0
|
|
|
|
0
|
die $@ if $@; |
335
|
0
|
|
|
|
|
0
|
exit 0; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
{ |
339
|
24
|
|
|
24
|
|
117
|
no warnings 'once'; |
|
24
|
|
|
|
|
27
|
|
|
24
|
|
|
|
|
9260
|
|
340
|
|
|
|
|
|
|
*via_win32 = \&via_files; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
sub via_files { |
343
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
344
|
0
|
|
|
|
|
0
|
my ($file, %params) = @_; |
345
|
|
|
|
|
|
|
|
346
|
0
|
|
0
|
|
|
0
|
my $env = $params{env} || {}; |
347
|
0
|
|
|
|
|
0
|
my $libs = $params{libs}; |
348
|
0
|
|
|
|
|
0
|
my $switches = $params{switches}; |
349
|
0
|
|
|
|
|
0
|
my $header = $self->header($file); |
350
|
|
|
|
|
|
|
|
351
|
0
|
0
|
|
|
|
0
|
my ($in_write, $in) = tempfile(CLEANUP => 1) or die "XXX"; |
352
|
0
|
0
|
|
|
|
0
|
my ($out_write, $out) = tempfile(CLEANUP => 1) or die "XXX"; |
353
|
0
|
0
|
|
|
|
0
|
my ($err_write, $err) = tempfile(CLEANUP => 1) or die "XXX"; |
354
|
0
|
0
|
|
|
|
0
|
open(my $in_read, '<', $in) or die "$!"; |
355
|
0
|
0
|
|
|
|
0
|
open(my $out_read, '<', $out) or die "$!"; |
356
|
0
|
0
|
|
|
|
0
|
open(my $err_read, '<', $err) or die "$!"; |
357
|
|
|
|
|
|
|
|
358
|
0
|
|
|
|
|
0
|
my @switches; |
359
|
0
|
0
|
|
|
|
0
|
push @switches => map { ("-I$_") } @$libs if $libs; |
|
0
|
|
|
|
|
0
|
|
360
|
0
|
|
0
|
|
|
0
|
push @switches => map { ("-I$_") } split $Config{path_sep}, ($ENV{PERL5LIB} || ""); |
|
0
|
|
|
|
|
0
|
|
361
|
0
|
0
|
|
|
|
0
|
push @switches => @$switches if $switches; |
362
|
0
|
0
|
|
|
|
0
|
push @switches => @{$header->{switches}} if $header->{switches}; |
|
0
|
|
|
|
|
0
|
|
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
# local $ENV{$_} = $env->{$_} for keys %$env; does not work... |
365
|
0
|
|
|
|
|
0
|
my $old = {%ENV}; |
366
|
0
|
|
|
|
|
0
|
$ENV{$_} = $env->{$_} for keys %$env; |
367
|
|
|
|
|
|
|
|
368
|
0
|
|
|
|
|
0
|
my $pid = open3( |
369
|
|
|
|
|
|
|
"<&" . fileno($in_read), ">&" . fileno($out_write), ">&" . fileno($err_write), |
370
|
|
|
|
|
|
|
$^X, @switches, $file |
371
|
|
|
|
|
|
|
); |
372
|
|
|
|
|
|
|
|
373
|
0
|
|
|
|
|
0
|
$ENV{$_} = $old->{$_} for keys %$env; |
374
|
|
|
|
|
|
|
|
375
|
0
|
0
|
|
|
|
0
|
die "Failed to execute '" . join(' ' => $^X, @switches, $file) . "'" unless $pid; |
376
|
|
|
|
|
|
|
|
377
|
0
|
|
|
|
|
0
|
my $proc = Test2::Harness::Proc->new( |
378
|
|
|
|
|
|
|
file => $file, |
379
|
|
|
|
|
|
|
pid => $pid, |
380
|
|
|
|
|
|
|
in_fh => $in_write, |
381
|
|
|
|
|
|
|
out_fh => $out_read, |
382
|
|
|
|
|
|
|
err_fh => $err_read, |
383
|
|
|
|
|
|
|
); |
384
|
|
|
|
|
|
|
|
385
|
0
|
|
|
|
|
0
|
return $proc; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# Heavily modified from forkprove |
389
|
|
|
|
|
|
|
sub preload_list { |
390
|
236
|
|
|
236
|
0
|
372
|
my $self = shift; |
391
|
|
|
|
|
|
|
|
392
|
236
|
100
|
|
|
|
1120
|
return @{$self->{+_PRELOAD_LIST}} if $self->{+_PRELOAD_LIST}; |
|
215
|
|
|
|
|
943
|
|
393
|
|
|
|
|
|
|
|
394
|
21
|
|
|
|
|
42
|
my $list = $self->{+_PRELOAD_LIST} = []; |
395
|
|
|
|
|
|
|
|
396
|
21
|
|
|
|
|
2247
|
for my $loaded (keys %INC) { |
397
|
2856
|
100
|
|
|
|
5103
|
next unless $loaded =~ /\.pm$/; |
398
|
|
|
|
|
|
|
|
399
|
2814
|
|
|
|
|
2142
|
my $mod = $loaded; |
400
|
2814
|
|
|
|
|
3255
|
$mod =~ s{/}{::}g; |
401
|
2814
|
|
|
|
|
3717
|
$mod =~ s{\.pm$}{}; |
402
|
|
|
|
|
|
|
|
403
|
2814
|
|
|
|
|
1680
|
my $fh = do { |
404
|
24
|
|
|
24
|
|
97
|
no strict 'refs'; |
|
24
|
|
|
|
|
25
|
|
|
24
|
|
|
|
|
4936
|
|
405
|
2814
|
|
|
|
|
1470
|
*{ $mod . '::DATA' } |
|
2814
|
|
|
|
|
16065
|
|
406
|
|
|
|
|
|
|
}; |
407
|
|
|
|
|
|
|
|
408
|
2814
|
50
|
|
|
|
5040
|
next unless openhandle($fh); |
409
|
0
|
|
|
|
|
0
|
push @$list => [ $mod, $INC{$loaded}, tell($fh) ]; |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
|
412
|
21
|
|
|
|
|
168
|
return @$list; |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# Heavily modified from forkprove |
416
|
|
|
|
|
|
|
sub reset_DATA { |
417
|
20
|
|
|
20
|
0
|
262
|
my $self = shift; |
418
|
20
|
|
|
|
|
133
|
my ($file) = @_; |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
# open DATA from test script |
421
|
20
|
50
|
|
|
|
437
|
if (openhandle(\*main::DATA)) { |
422
|
0
|
|
|
|
|
0
|
close ::DATA; |
423
|
0
|
0
|
|
|
|
0
|
if (open my $fh, $file) { |
424
|
0
|
|
|
|
|
0
|
my $code = do { local $/; <$fh> }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
425
|
0
|
0
|
|
|
|
0
|
if(my($data) = $code =~ /^__(?:END|DATA)__$(.*)/ms){ |
426
|
0
|
0
|
|
|
|
0
|
open ::DATA, '<', \$data |
427
|
|
|
|
|
|
|
or die "Can't open string as DATA. $!"; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
20
|
|
|
|
|
275
|
for my $set ($self->preload_list) { |
433
|
0
|
|
|
|
|
|
my ($mod, $file, $pos) = @$set; |
434
|
|
|
|
|
|
|
|
435
|
0
|
|
|
|
|
|
my $fh = do { |
436
|
24
|
|
|
24
|
|
115
|
no strict 'refs'; |
|
24
|
|
|
|
|
24
|
|
|
24
|
|
|
|
|
2923
|
|
437
|
0
|
|
|
|
|
|
*{ $mod . '::DATA' } |
|
0
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
}; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# note that we need to ensure that each forked copy is using a |
441
|
|
|
|
|
|
|
# different file handle, or else concurrent processes will interfere |
442
|
|
|
|
|
|
|
# with each other |
443
|
|
|
|
|
|
|
|
444
|
0
|
0
|
|
|
|
|
close $fh if openhandle($fh); |
445
|
|
|
|
|
|
|
|
446
|
0
|
0
|
|
|
|
|
if (open $fh, '<', $file) { |
447
|
0
|
|
|
|
|
|
seek($fh, $pos, 0); |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
else { |
450
|
0
|
|
|
|
|
|
warn "Couldn't reopen DATA for $mod ($file): $!"; |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
1; |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
__END__ |