File Coverage

blib/lib/Test2/Harness/Runner.pm
Criterion Covered Total %
statement 186 253 73.5
branch 67 136 49.2
condition 9 22 40.9
subroutine 24 27 88.8
pod 3 9 33.3
total 289 447 64.6


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__