our
$VERSION
=
'0.001040'
;
use
Test2::Util
qw/clone_io CAN_REALLY_FORK pkg_to_file/
;
sub
viable {
my
$class
=
shift
;
my
(
$test
) =
@_
;
return
0
unless
CAN_REALLY_FORK();
return
0
if
$ENV
{HARNESS_PERL_SWITCHES};
my
$job
=
$test
->job;
return
0
if
!
$job
->use_fork;
return
0
if
grep
{ !m/\s*-w\s*/ } @{
$job
->switches};
return
1;
}
sub
run {
my
$class
=
shift
;
my
(
$test
) =
@_
;
my
$job
=
$test
->job;
my
$preloads
=
$job
->preload || [];
$_
->pre_fork(
$job
)
for
@$preloads
;
my
$pid
=
fork
();
die
"Failed to fork: $!"
unless
defined
$pid
;
return
(
$pid
,
undef
)
if
$pid
;
my
$file
=
$job
->file;
$^W = 1
if
grep
{ m/\s*-w\s*/ } @{
$job
->switches};
$SIG
{TERM} =
'DEFAULT'
;
$SIG
{INT} =
'DEFAULT'
;
$SIG
{HUP} =
'DEFAULT'
;
my
$env
=
$job
->env_vars;
{
no
warnings
'uninitialized'
;
$ENV
{
$_
} =
$env
->{
$_
}
for
keys
%$env
;
}
$ENV
{T2_HARNESS_FORKED} = 1;
$ENV
{T2_HARNESS_PRELOAD} = 1;
my
(
$in_file
,
$out_file
,
$err_file
,
$event_file
) =
$test
->output_filenames;
$0 = File::Spec->abs2rel(
$file
);
$class
->_reset_DATA(
$file
);
@ARGV
= ();
$_
->post_fork(
$job
)
for
@$preloads
;
my
$importer
=
eval
<<' EOT' or die $@;
package main;
#line 0 "-"
sub { shift->import(@_) }
EOT
for
my
$mod
(@{
$job
->load_import || []}) {
my
@args
;
if
(
$mod
=~ s/=(.*)$//) {
@args
=
split
/,/, $1;
}
my
$file
= pkg_to_file(
$mod
);
local
$0 =
'-'
;
require
$file
;
$importer
->(
$mod
,
@args
);
}
for
my
$mod
(@{
$job
->load || []}) {
my
$file
= pkg_to_file(
$mod
);
require
$file
;
}
FindBin::init()
if
defined
&FindBin::init
;
Getopt::Long::ConfigDefaults()
if
defined
&Getopt::Long::ConfigDefaults
;
""
=~ /^/;
my
$stderr
= clone_io(\
*STDERR
);
write_file(
$in_file
,
$job
->input);
my
$die
=
sub
{
my
@caller
=
caller
;
my
@caller2
=
caller
(1);
my
$msg
=
"$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2]).\n"
;
print
$stderr
$msg
;
print
STDERR
$msg
;
POSIX::_exit(127);
};
swap_io(\
*STDIN
,
$in_file
,
$die
);
swap_io(\
*STDOUT
,
$out_file
,
$die
);
swap_io(\
*STDERR
,
$err_file
,
$die
);
srand
();
if
(
$INC
{
'Test2/API.pm'
}) {
Test2::API::test2_stop_preload();
Test2::API::test2_post_preload_reset();
}
my
%seen
;
@INC
=
grep
{ !
$seen
{
$_
}++ } (@{
$job
->libs},
@INC
);
if
(
$job
->use_stream) {
$ENV
{T2_FORMATTER} =
'Stream'
;
Test2::Formatter::Stream->
import
(
file
=>
$event_file
);
}
if
(
$job
->
times
) {
Test2::Plugin::Times->
import
();
}
@ARGV
= @{
$job
->args};
$_
->pre_launch(
$job
)
for
@$preloads
;
return
(
undef
,
$file
);
}
sub
_reset_DATA {
my
$class
=
shift
;
my
(
$file
) =
@_
;
if
(openhandle(\
*main::DATA
)) {
close
::DATA;
if
(
open
my
$fh
,
$file
) {
my
$code
=
do
{
local
$/; <
$fh
> };
if
(
my
(
$data
) =
$code
=~ /^__(?:END|DATA)__$(.*)/ms) {
open
::DATA,
'<'
, \
$data
or
die
"Can't open string as DATA. $!"
;
}
}
}
for
my
$set
(@{
$class
->preload_list}) {
my
(
$mod
,
$file
,
$pos
) =
@$set
;
my
$fh
=
do
{
no
strict
'refs'
;
*{
$mod
.
'::DATA'
};
};
close
$fh
if
openhandle(
$fh
);
if
(
open
$fh
,
'<'
,
$file
) {
seek
(
$fh
,
$pos
, 0);
}
else
{
warn
"Couldn't reopen DATA for $mod ($file): $!"
;
}
}
}
sub
preload_list {
my
$class
=
shift
;
my
$list
= [];
for
my
$loaded
(
keys
%INC
) {
next
unless
$loaded
=~ /\.pm$/;
my
$mod
=
$loaded
;
$mod
=~ s{/}{::}g;
$mod
=~ s{\.pm$}{};
my
$fh
=
do
{
no
strict
'refs'
;
no
warnings
'once'
;
*{
$mod
.
'::DATA'
};
};
next
unless
openhandle(
$fh
);
push
@$list
=> [
$mod
,
$INC
{
$loaded
},
tell
(
$fh
)];
}
return
$list
;
}
1;