package Forks::Super::Job::Emulate;
use strict;
use warnings;
use base 'Forks::Super::Job';
use Carp;
use Forks::Super::Debug ':all';
use Forks::Super::Util ':all';
our $VERSION = '0.84';
my $emulate_id = 0;
sub emulate {
my $job = shift;
$emulate_id += 4;
$job->{real_pid} = $job->{pid} = $$ * 1000000 + $emulate_id;
$job->{is_emulation} = 1;
local $Forks::Super::Job::Ipc::USE_TIE_FH = 0;
local $Forks::Super::Job::Ipc::USE_TIE_SH = 0;
local $Forks::Super::Job::Ipc::USE_TIE_PH = 0;
$_->() for @Forks::Super::Jobs::POSTFORK_CHILD;
if (!$job->{cmd} && !$job->{exec} && !$job->{sub}) {
croak "FSJ::Emulate: must use cmd/exec/sub option with emulate";
}
Forks::Super::Job::_postlaunch_parent1($job->{pid}, $job);
{
package Forks::Super::Job::Ipc;
local (our(%IPC_FILES, @IPC_FILES, $IPC_DIR_DEDICATED,
@SAFEOPEN, %SIG_OLD));
local $Forks::Super::Debug::EM = 1;
local *STDIN = *STDIN;
local *STDOUT = *STDOUT;
local *STDERR = *STDERR;
$SIG{ALRM} = sub { die "emulation timeout\n" };
my $timeout = delete $job->{timeout};
if ($timeout) {
alarm $timeout;
}
$job->{is_child} = 1;
eval {
$job->_postlaunch_child;
};
alarm 0;
if ($@ && $@ =~ /emulation timeout/) {
$job->{status} = 255 << 8;
$job->{error} = $@;
}
Forks::Super::Job::Ipc::_child_share($job);
delete $job->{is_child};
}
$job->_postlaunch_parent2;
$_->() for @Forks::Super::Jobs::POSTFORK_PARENT;
return $job;
}
sub _postlaunch_child_to_exec {
# exec must be interpreted as cmd in emulation mode
my $job = shift;
$job->{cmd} ||= delete $job->{exec};
carp "Forks::Super: exec option changed to cmd in emulation mode";
return $job->_postlaunch_child_to_cmd;
}
sub _postlaunch_child_to_cmd {
my $job = shift;
if ($job->{debug}) {
debug("Executing command [ @{$job->{cmd}} ] {EMULATION MODE}");
}
my $c1;
if (&IS_WIN32) {
$c1 = system( @{$job->{cmd}} );
Forks::Super::Job::Ipc::_close_child_fh($job);
Forks::Super::Sigchld::_preliminary_reap($job,$c1);
debug("WIN32 returned, exit code of $$ was $c1 ", $c1>>8)
if $job->{debug};
} elsif (1) {
our %EMULATE_PID;
my $this_pid = $$;
my $retries = $job->{retries} || 0;
my $exec_pid = Forks::Super::Job::_CORE_fork();
while (!defined $exec_pid && $retries-- > 0) {
warn "Forks::Super::Job::_postlaunch_child_to_cmd: ",
"system fork call returned undef. Retrying ...\n";
Forks::Super::Util::pause(1.0);
$exec_pid = Forks::Super::Job::_CORE_fork();
}
if (!defined $exec_pid) {
croak "Forks::Super::Job::_postlaunch_child_to_cmd: ",
"Child process unable to create new fork to run cmd";
}
$EMULATE_PID{$exec_pid} = $job;
if ($$ != $this_pid) {
exec( @{$job->{cmd}} ) or
Carp::confess 'exec for cmd-style fork failed ';
}
$job->{debug} && debug(" exec pid is $exec_pid for job $job");
$job->set_signal_pid($exec_pid);
$job->{exec_pid} = $exec_pid;
$Forks::Super::Job::CHILD_EXEC_PID = $exec_pid;
# XXX - do something with this in _cleanup_child?
my $z = CORE::waitpid $exec_pid, 0;
if ($z == $exec_pid) {
# reaped here
$c1 = $?;
Forks::Super::Job::Ipc::_close_child_fh($job);
Forks::Super::Sigchld::_preliminary_reap($job,$c1);
debug("waitpid returned $z, exit code of $$ was $c1 ", $c1>>8)
if $job->{debug};
} elsif ($job->{debug}) {
# not reaped here
debug("$$ was reaped in SIGCHLD handler status=$job->{status}");
}
} else {
$c1 = system( @{$job->{cmd}} );
Forks::Super::Job::Ipc::_close_child_fh($job);
Forks::Super::Sigchld::_preliminary_reap($job,$c1);
}
}
sub _config_callback_child {
my $job = shift;
# no op in emulation mode
return;
}
1;
=head1 NAME
Forks::Super::Job::Emulate - support emulation mode for Job object
=head1 VERSION
0.84
=head1 DESCRIPTION
In I<emulation> mode (when a non-zero C<emulate> argument is passed
to L<fork|Forks::Super/"fork">), no background process is created.
Rather, the C<fork> call performs the background task in the main
process and returns a L<Forks::Super::Job|Forks::Super::Job> object
that resembles a completed background job.
This package is part of the L<Forks::Super|Forks::Super>
distribution. Most users will have little reason to directly
call the methods of this package.
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2016, Marty O'Brien.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.
See http://dev.perl.org/licenses/ for more information.
=cut
__END__
emulation tests:
job should be added to @Forks::Super::ALL_JOBS
with external command
can set cpu affinity and os priority of external command
with subroutine call
can set cpu affinity and os priority while sub is running
! may not exit from sub call in emulation mode
back in the parent
signal (kill) should fail
cpu affinity should be restored
os priority should be restored
can wait or waitpid on job one time
overloaded FSJ functions work
bg_qx
bg_eval
emulated process respects timeout
x emulated jobs can be named
x emulated jobs can be delayed for deterministic amount of time
x share respected, but easier to implement
after chdir in emulated job, parent dir should be restored