1 |
56 |
alirezamon |
package Proc::Background::Unix;
|
2 |
|
|
$Proc::Background::Unix::VERSION = '1.30';
|
3 |
|
|
# ABSTRACT: Unix-specific implementation of process create/wait/kill
|
4 |
|
|
require 5.004_04;
|
5 |
|
|
|
6 |
|
|
use strict;
|
7 |
|
|
use Exporter;
|
8 |
|
|
use Carp;
|
9 |
|
|
use POSIX qw( :errno_h :sys_wait_h );
|
10 |
|
|
|
11 |
|
|
# Test for existence of FD_CLOEXEC, needed for child-error-through-pipe trick
|
12 |
|
|
my ($FD_CLOEXEC);
|
13 |
|
|
eval {
|
14 |
|
|
require Fcntl;
|
15 |
|
|
$FD_CLOEXEC= Fcntl::FD_CLOEXEC();
|
16 |
|
|
};
|
17 |
|
|
|
18 |
|
|
# For un-explained mysterious reasons, Time::HiRes::alarm seem to misbehave on 5.10 and earlier
|
19 |
|
|
# but core alarm works fine.
|
20 |
|
|
my $alarm= ($] >= 5.012)? do { require Time::HiRes; \&Time::HiRes::alarm; }
|
21 |
|
|
: sub {
|
22 |
|
|
# round up to whole seconds
|
23 |
|
|
CORE::alarm(POSIX::ceil($_[0]));
|
24 |
|
|
};
|
25 |
|
|
|
26 |
|
|
@Proc::Background::Unix::ISA = qw(Exporter);
|
27 |
|
|
|
28 |
|
|
# Start the background process. If it is started sucessfully, then record
|
29 |
|
|
# the process id in $self->{_os_obj}.
|
30 |
|
|
sub _start {
|
31 |
|
|
my ($self, $options)= @_;
|
32 |
|
|
|
33 |
|
|
# There are three main scenarios for how-to-exec:
|
34 |
|
|
# * single-string command, to be handled by shell
|
35 |
|
|
# * arrayref command, to be handled by execve
|
36 |
|
|
# * arrayref command with 'exe' (fake argv0)
|
37 |
|
|
# and one that isn't logical:
|
38 |
|
|
# * single-string command with exe
|
39 |
|
|
# throw an error for that last one rather than trying something awkward
|
40 |
|
|
# like splitting the command string.
|
41 |
|
|
|
42 |
|
|
my @argv;
|
43 |
|
|
my $cmd= $self->{_command};
|
44 |
|
|
my $exe= $self->{_exe};
|
45 |
|
|
|
46 |
|
|
if (ref $cmd eq 'ARRAY') {
|
47 |
|
|
@argv= @$cmd;
|
48 |
|
|
($exe, my $err) = Proc::Background::_resolve_path(defined $exe? $exe : $argv[0]);
|
49 |
|
|
return $self->_fatal($err) unless defined $exe;
|
50 |
|
|
$self->{_exe}= $exe;
|
51 |
|
|
} elsif (defined $exe) {
|
52 |
|
|
croak "Can't combine 'exe' option with single-string 'command', use arrayref 'command' instead.";
|
53 |
|
|
}
|
54 |
|
|
|
55 |
|
|
if (defined $options->{cwd}) {
|
56 |
|
|
-d $options->{cwd}
|
57 |
|
|
or return $self->_fatal("directory does not exist: '$options->{cwd}'");
|
58 |
|
|
}
|
59 |
|
|
|
60 |
|
|
my ($new_stdin, $new_stdout, $new_stderr);
|
61 |
|
|
$new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN)
|
62 |
|
|
if exists $options->{stdin};
|
63 |
|
|
$new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT)
|
64 |
|
|
if exists $options->{stdout};
|
65 |
|
|
$new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR)
|
66 |
|
|
if exists $options->{stderr};
|
67 |
|
|
|
68 |
|
|
# Fork a child process.
|
69 |
|
|
my ($pipe_r, $pipe_w);
|
70 |
|
|
if (defined $FD_CLOEXEC) {
|
71 |
|
|
# use a pipe for the child to report exec() errors
|
72 |
|
|
pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!");
|
73 |
|
|
# This pipe needs to be in the non-preserved range that doesn't exist after exec().
|
74 |
|
|
# In the edge case where a pipe received a FD less than $^F, the CLOEXEC flag isn't set.
|
75 |
|
|
# Try again on higher descriptors, then close the lower ones.
|
76 |
|
|
my @rejects;
|
77 |
|
|
while (fileno $pipe_r <= $^F or fileno $pipe_w <= $^F) {
|
78 |
|
|
push @rejects, $pipe_r, $pipe_w;
|
79 |
|
|
pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!");
|
80 |
|
|
}
|
81 |
|
|
}
|
82 |
|
|
my $pid;
|
83 |
|
|
{
|
84 |
|
|
if ($pid = fork()) {
|
85 |
|
|
# parent
|
86 |
|
|
$self->{_os_obj} = $pid;
|
87 |
|
|
$self->{_pid} = $pid;
|
88 |
|
|
if (defined $pipe_r) {
|
89 |
|
|
close $pipe_w;
|
90 |
|
|
# wait for child to reply or close the pipe
|
91 |
|
|
local $SIG{PIPE}= sub {};
|
92 |
|
|
my $msg= '';
|
93 |
|
|
while (0 < read $pipe_r, $msg, 1024, length $msg) {}
|
94 |
|
|
close $pipe_r;
|
95 |
|
|
# If child wrote anything to the pipe, it failed to exec.
|
96 |
|
|
# Reap it before dying.
|
97 |
|
|
if (length $msg) {
|
98 |
|
|
waitpid $pid, 0;
|
99 |
|
|
return $self->_fatal($msg);
|
100 |
|
|
}
|
101 |
|
|
}
|
102 |
|
|
last;
|
103 |
|
|
} elsif (defined $pid) {
|
104 |
|
|
# child
|
105 |
|
|
# Make absolutely sure nothing in this block interacts with the rest of the
|
106 |
|
|
# process state, and that flow control never skips the _exit().
|
107 |
|
|
eval {
|
108 |
|
|
local $SIG{__DIE__}= undef;
|
109 |
|
|
eval {
|
110 |
|
|
chdir($options->{cwd}) or die "chdir($options->{cwd}): $!\n"
|
111 |
|
|
if defined $options->{cwd};
|
112 |
|
|
|
113 |
|
|
open STDIN, '<&', $new_stdin or die "Can't redirect STDIN: $!\n"
|
114 |
|
|
if defined $new_stdin;
|
115 |
|
|
open STDOUT, '>&', $new_stdout or die "Can't redirect STDOUT: $!\n"
|
116 |
|
|
if defined $new_stdout;
|
117 |
|
|
open STDERR, '>&', $new_stderr or die "Can't redirect STDERR: $!\n"
|
118 |
|
|
if defined $new_stderr;
|
119 |
|
|
|
120 |
|
|
if (defined $exe) {
|
121 |
|
|
exec { $exe } @argv or die "$0: exec failed: $!\n";
|
122 |
|
|
} else {
|
123 |
|
|
exec $cmd or die "$0: exec failed: $!\n";
|
124 |
|
|
}
|
125 |
|
|
};
|
126 |
|
|
if (defined $pipe_w) {
|
127 |
|
|
print $pipe_w $@;
|
128 |
|
|
close $pipe_w; # force it to flush. Nothing else needs closed because we are about to _exit
|
129 |
|
|
} else {
|
130 |
|
|
print STDERR $@;
|
131 |
|
|
}
|
132 |
|
|
};
|
133 |
|
|
POSIX::_exit(1);
|
134 |
|
|
} elsif ($! == EAGAIN) {
|
135 |
|
|
sleep 5;
|
136 |
|
|
redo;
|
137 |
|
|
} else {
|
138 |
|
|
return $self->_fatal("fork: $!");
|
139 |
|
|
}
|
140 |
|
|
}
|
141 |
|
|
|
142 |
|
|
$self;
|
143 |
|
|
}
|
144 |
|
|
|
145 |
|
|
sub _resolve_file_handle {
|
146 |
|
|
my ($thing, $mode, $default)= @_;
|
147 |
|
|
if (!defined $thing) {
|
148 |
|
|
open my $fh, $mode, '/dev/null' or croak "open(/dev/null): $!";
|
149 |
|
|
return $fh;
|
150 |
|
|
} elsif (ref $thing) {
|
151 |
|
|
# use 'undef' to mean no-change
|
152 |
|
|
return (fileno($thing) == fileno($default))? undef : $thing;
|
153 |
|
|
} else {
|
154 |
|
|
open my $fh, $mode, $thing or croak "open($thing): $!";
|
155 |
|
|
return $fh;
|
156 |
|
|
}
|
157 |
|
|
}
|
158 |
|
|
|
159 |
|
|
# Wait for the child.
|
160 |
|
|
# (0, exit_value) : sucessfully waited on.
|
161 |
|
|
# (1, undef) : process already reaped and exit value lost.
|
162 |
|
|
# (2, undef) : process still running.
|
163 |
|
|
sub _waitpid {
|
164 |
|
|
my ($self, $blocking, $wait_seconds) = @_;
|
165 |
|
|
|
166 |
|
|
{
|
167 |
|
|
# Try to wait on the process.
|
168 |
|
|
# Implement the optional timeout with the 'alarm' call.
|
169 |
|
|
my $result= 0;
|
170 |
|
|
if ($blocking && $wait_seconds) {
|
171 |
|
|
local $SIG{ALRM}= sub { die "alarm\n" };
|
172 |
|
|
$alarm->($wait_seconds);
|
173 |
|
|
eval { $result= waitpid($self->{_os_obj}, 0); };
|
174 |
|
|
$alarm->(0);
|
175 |
|
|
}
|
176 |
|
|
else {
|
177 |
|
|
$result= waitpid($self->{_os_obj}, $blocking? 0 : WNOHANG);
|
178 |
|
|
}
|
179 |
|
|
|
180 |
|
|
# Process finished. Grab the exit value.
|
181 |
|
|
if ($result == $self->{_os_obj}) {
|
182 |
|
|
delete $self->{_suspended};
|
183 |
|
|
return (0, $?);
|
184 |
|
|
}
|
185 |
|
|
# Process already reaped. We don't know the exist status.
|
186 |
|
|
elsif ($result == -1 and $! == ECHILD) {
|
187 |
|
|
return (1, 0);
|
188 |
|
|
}
|
189 |
|
|
# Process still running.
|
190 |
|
|
elsif ($result == 0) {
|
191 |
|
|
return (2, 0);
|
192 |
|
|
}
|
193 |
|
|
# If we reach here, then waitpid caught a signal, so let's retry it.
|
194 |
|
|
redo;
|
195 |
|
|
}
|
196 |
|
|
return 0;
|
197 |
|
|
}
|
198 |
|
|
|
199 |
|
|
sub _suspend {
|
200 |
|
|
kill STOP => $_[0]->{_os_obj};
|
201 |
|
|
}
|
202 |
|
|
|
203 |
|
|
sub _resume {
|
204 |
|
|
kill CONT => $_[0]->{_os_obj};
|
205 |
|
|
}
|
206 |
|
|
|
207 |
|
|
sub _terminate {
|
208 |
|
|
my $self = shift;
|
209 |
|
|
my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 );
|
210 |
|
|
# Try to kill the process with different signals. Calling alive() will
|
211 |
|
|
# collect the exit status of the program.
|
212 |
|
|
while (@kill_sequence and $self->alive) {
|
213 |
|
|
my $sig= shift @kill_sequence;
|
214 |
|
|
my $delay= shift @kill_sequence;
|
215 |
|
|
kill($sig, $self->{_os_obj});
|
216 |
|
|
next unless defined $delay;
|
217 |
|
|
last if $self->_reap(1, $delay); # block before sending next signal
|
218 |
|
|
}
|
219 |
|
|
}
|
220 |
|
|
|
221 |
|
|
1;
|
222 |
|
|
|
223 |
|
|
__END__
|
224 |
|
|
|
225 |
|
|
=pod
|
226 |
|
|
|
227 |
|
|
=encoding UTF-8
|
228 |
|
|
|
229 |
|
|
=head1 NAME
|
230 |
|
|
|
231 |
|
|
Proc::Background::Unix - Unix-specific implementation of process create/wait/kill
|
232 |
|
|
|
233 |
|
|
=head1 DESCRIPTION
|
234 |
|
|
|
235 |
|
|
This module does not have a public interface. Use L<Proc::Background>.
|
236 |
|
|
|
237 |
|
|
=head1 NAME
|
238 |
|
|
|
239 |
|
|
Proc::Background::Unix - Implementation of process management for Unix systems
|
240 |
|
|
|
241 |
|
|
=head1 IMPLEMENTATION
|
242 |
|
|
|
243 |
|
|
=head2 Command vs. Exec
|
244 |
|
|
|
245 |
|
|
Unix systems start a new process by creating a mirror of the current process
|
246 |
|
|
(C<fork>) and then having it alter its own state to prepare for the new
|
247 |
|
|
program, and then calling C<exec> to replace the running code with code loaded
|
248 |
|
|
from a new file. However, there is a second common method where the user
|
249 |
|
|
wants to specify a command line string as they would type it in their shell.
|
250 |
|
|
In this case, the actual program being executed is the shell, and the command
|
251 |
|
|
line is given as one element of its argument list.
|
252 |
|
|
|
253 |
|
|
Perl already supports both methods, such that if you pass one string to C<exec>
|
254 |
|
|
containing shell characters, it calls the shell, and if you pass multiple
|
255 |
|
|
arguments, it directly invokes C<exec>.
|
256 |
|
|
|
257 |
|
|
This module mostly just lets Perl's C<exec> do its job, but also checks for
|
258 |
|
|
the existence of the executable first, to make errors easier to catch. This
|
259 |
|
|
check is skipped if there is a single-string command line.
|
260 |
|
|
|
261 |
|
|
Unix lets you run a different executable than what is listed in the first
|
262 |
|
|
argument. (this feature lets one Unix executable behave as multiple
|
263 |
|
|
different programs depending on what name it sees in the first argument)
|
264 |
|
|
You can use that feature by passing separate options of C<exe> and C<command>
|
265 |
|
|
to this module's constructor instead of a simple argument list. But, you
|
266 |
|
|
can't mix a C<exe> option with a shell-interpreted command line string.
|
267 |
|
|
|
268 |
|
|
=head2 Errors during Exec
|
269 |
|
|
|
270 |
|
|
If the C<autodie> option is enabled, and the system supports C<FD_CLOEXEC>,
|
271 |
|
|
this module uses a trick where the forked child relays any errors through
|
272 |
|
|
a pipe so that the parent can throw and handle the exception directly instead
|
273 |
|
|
of creating a child process that is dead-on-arrival with the error on STDERR.
|
274 |
|
|
|
275 |
|
|
=head1 AUTHORS
|
276 |
|
|
|
277 |
|
|
=over 4
|
278 |
|
|
|
279 |
|
|
=item *
|
280 |
|
|
|
281 |
|
|
Blair Zajac <blair@orcaware.com>
|
282 |
|
|
|
283 |
|
|
=item *
|
284 |
|
|
|
285 |
|
|
Michael Conrad <mike@nrdvana.net>
|
286 |
|
|
|
287 |
|
|
=back
|
288 |
|
|
|
289 |
|
|
=head1 VERSION
|
290 |
|
|
|
291 |
|
|
version 1.30
|
292 |
|
|
|
293 |
|
|
=head1 COPYRIGHT AND LICENSE
|
294 |
|
|
|
295 |
|
|
This software is copyright (c) 2021 by Michael Conrad, (C) 1998-2009 by Blair Zajac.
|
296 |
|
|
|
297 |
|
|
This is free software; you can redistribute it and/or modify it under
|
298 |
|
|
the same terms as the Perl 5 programming language system itself.
|
299 |
|
|
|
300 |
|
|
=cut
|