use strict;
our $VERSION = '0.001040';
use POSIX;
use Scalar::Util qw/openhandle/;
use Test2::Util qw/clone_io CAN_REALLY_FORK pkg_to_file/;
use Test2::Harness::Util qw/write_file/;
use Test2::Harness::Util::IPC qw/swap_io/;
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;
# -w switch is ok, otherwise it is a no-go
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;
# In parent
return ($pid, undef) if $pid;
# In Child
my $file = $job->file;
# toggle -w switch late
$^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;
}
# if FindBin is preloaded, reset it with the new $0
FindBin::init() if defined &FindBin::init;
# restore defaults
Getopt::Long::ConfigDefaults() if defined &Getopt::Long::ConfigDefaults;
# reset the state of empty pattern matches, so that they have the same
# behavior as running in a clean process.
# see "The empty pattern //" in perlop.
# note that this has to be dynamically scoped and can't go to other subs
"" =~ /^/;
# Keep a copy of the old STDERR for a while so we can still report errors
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);
# avoid child processes sharing the same seed value as the parent
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);
}
# Heavily modified from forkprove
sub _reset_DATA {
my $class = shift;
my ($file) = @_;
# open DATA from test script
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'};
};
# note that we need to ensure that each forked copy is using a
# different file handle, or else concurrent processes will interfere
# with each other
close $fh if openhandle($fh);
if (open $fh, '<', $file) {
seek($fh, $pos, 0);
}
else {
warn "Couldn't reopen DATA for $mod ($file): $!";
}
}
}
# Heavily modified from forkprove
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;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Harness::Job::Runner::Fork - Logic for running a test job by forking.
=head1 DESCRIPTION
=head1 SOURCE
The source code repository for Test2-Harness can be found at
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2017 Chad Granum E<lt>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut