line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Proc::Background::Unix; |
2
|
|
|
|
|
|
|
$Proc::Background::Unix::VERSION = '1.31'; |
3
|
|
|
|
|
|
|
# ABSTRACT: Unix-specific implementation of process create/wait/kill |
4
|
|
|
|
|
|
|
require 5.004_04; |
5
|
|
|
|
|
|
|
|
6
|
22
|
|
|
22
|
|
138
|
use strict; |
|
22
|
|
|
|
|
44
|
|
|
22
|
|
|
|
|
630
|
|
7
|
22
|
|
|
22
|
|
109
|
use Exporter; |
|
22
|
|
|
|
|
45
|
|
|
22
|
|
|
|
|
680
|
|
8
|
22
|
|
|
22
|
|
105
|
use Carp; |
|
22
|
|
|
|
|
44
|
|
|
22
|
|
|
|
|
1028
|
|
9
|
22
|
|
|
22
|
|
11639
|
use POSIX qw( :errno_h :sys_wait_h ); |
|
22
|
|
|
|
|
174342
|
|
|
22
|
|
|
|
|
110
|
|
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
|
108
|
|
|
108
|
|
482
|
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
|
108
|
|
|
|
|
248
|
my @argv; |
43
|
108
|
|
|
|
|
465
|
my $cmd= $self->{_command}; |
44
|
108
|
|
|
|
|
376
|
my $exe= $self->{_exe}; |
45
|
|
|
|
|
|
|
|
46
|
108
|
100
|
|
|
|
1174
|
if (ref $cmd eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
47
|
103
|
|
|
|
|
616
|
@argv= @$cmd; |
48
|
103
|
50
|
|
|
|
752
|
($exe, my $err) = Proc::Background::_resolve_path(defined $exe? $exe : $argv[0]); |
49
|
103
|
100
|
|
|
|
531
|
return $self->_fatal($err) unless defined $exe; |
50
|
101
|
|
|
|
|
417
|
$self->{_exe}= $exe; |
51
|
|
|
|
|
|
|
} elsif (defined $exe) { |
52
|
0
|
|
|
|
|
0
|
croak "Can't combine 'exe' option with single-string 'command', use arrayref 'command' instead."; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
106
|
100
|
|
|
|
666
|
if (defined $options->{cwd}) { |
56
|
|
|
|
|
|
|
-d $options->{cwd} |
57
|
7
|
100
|
|
|
|
140
|
or return $self->_fatal("directory does not exist: '$options->{cwd}'"); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
104
|
|
|
|
|
292
|
my ($new_stdin, $new_stdout, $new_stderr); |
61
|
|
|
|
|
|
|
$new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN) |
62
|
104
|
100
|
|
|
|
480
|
if exists $options->{stdin}; |
63
|
|
|
|
|
|
|
$new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT) |
64
|
104
|
100
|
|
|
|
406
|
if exists $options->{stdout}; |
65
|
|
|
|
|
|
|
$new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR) |
66
|
104
|
100
|
|
|
|
729
|
if exists $options->{stderr}; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# Fork a child process. |
69
|
104
|
|
|
|
|
315
|
my ($pipe_r, $pipe_w); |
70
|
104
|
50
|
|
|
|
412
|
if (defined $FD_CLOEXEC) { |
71
|
|
|
|
|
|
|
# use a pipe for the child to report exec() errors |
72
|
104
|
50
|
|
|
|
7635
|
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
|
104
|
|
|
|
|
510
|
my @rejects; |
77
|
104
|
|
33
|
|
|
2536
|
while (fileno $pipe_r <= $^F or fileno $pipe_w <= $^F) { |
78
|
0
|
|
|
|
|
0
|
push @rejects, $pipe_r, $pipe_w; |
79
|
0
|
0
|
|
|
|
0
|
pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!"); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
} |
82
|
104
|
|
|
|
|
430
|
my $pid; |
83
|
|
|
|
|
|
|
{ |
84
|
104
|
100
|
|
|
|
223
|
if ($pid = fork()) { |
|
104
|
50
|
|
|
|
110511
|
|
|
|
0
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# parent |
86
|
87
|
|
|
|
|
4319
|
$self->{_os_obj} = $pid; |
87
|
87
|
|
|
|
|
1804
|
$self->{_pid} = $pid; |
88
|
87
|
50
|
|
|
|
1668
|
if (defined $pipe_r) { |
89
|
87
|
|
|
|
|
4507
|
close $pipe_w; |
90
|
|
|
|
|
|
|
# wait for child to reply or close the pipe |
91
|
87
|
|
|
0
|
|
14726
|
local $SIG{PIPE}= sub {}; |
92
|
87
|
|
|
|
|
1758
|
my $msg= ''; |
93
|
87
|
|
|
|
|
30520664
|
while (0 < read $pipe_r, $msg, 1024, length $msg) {} |
94
|
87
|
|
|
|
|
3212
|
close $pipe_r; |
95
|
|
|
|
|
|
|
# If child wrote anything to the pipe, it failed to exec. |
96
|
|
|
|
|
|
|
# Reap it before dying. |
97
|
87
|
50
|
|
|
|
3451
|
if (length $msg) { |
98
|
0
|
|
|
|
|
0
|
waitpid $pid, 0; |
99
|
0
|
|
|
|
|
0
|
return $self->_fatal($msg); |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
} |
102
|
87
|
|
|
|
|
552
|
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
|
17
|
|
|
0
|
|
5040
|
$SIG{$_}= sub{die;} for qw( INT HUP QUIT TERM ); # clear custom signal handlers |
|
0
|
|
|
|
|
0
|
|
108
|
17
|
|
|
|
|
1983
|
$SIG{$_}= 'DEFAULT' for qw( __WARN__ __DIE__ ); |
109
|
17
|
|
|
|
|
647
|
eval { |
110
|
17
|
|
|
|
|
411
|
eval { |
111
|
|
|
|
|
|
|
chdir($options->{cwd}) or die "chdir($options->{cwd}): $!\n" |
112
|
17
|
100
|
50
|
|
|
1079
|
if defined $options->{cwd}; |
113
|
|
|
|
|
|
|
|
114
|
17
|
100
|
50
|
|
|
837
|
open STDIN, '<&'.fileno($new_stdin) or die "Can't redirect STDIN: $!\n" |
115
|
|
|
|
|
|
|
if defined $new_stdin; |
116
|
17
|
100
|
50
|
|
|
992
|
open STDOUT, '>&'.fileno($new_stdout) or die "Can't redirect STDOUT: $!\n" |
117
|
|
|
|
|
|
|
if defined $new_stdout; |
118
|
17
|
100
|
50
|
|
|
382
|
open STDERR, '>&'.fileno($new_stderr) or die "Can't redirect STDERR: $!\n" |
119
|
|
|
|
|
|
|
if defined $new_stderr; |
120
|
|
|
|
|
|
|
|
121
|
17
|
100
|
|
|
|
272
|
if (defined $exe) { |
122
|
16
|
0
|
|
|
|
89
|
exec { $exe } @argv or die "$0: exec failed: $!\n"; |
|
16
|
|
|
|
|
0
|
|
123
|
|
|
|
|
|
|
} else { |
124
|
1
|
0
|
|
|
|
0
|
exec $cmd or die "$0: exec failed: $!\n"; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
}; |
127
|
0
|
0
|
|
|
|
0
|
if (defined $pipe_w) { |
128
|
0
|
|
|
|
|
0
|
print $pipe_w $@; |
129
|
0
|
|
|
|
|
0
|
close $pipe_w; # force it to flush. Nothing else needs closed because we are about to _exit |
130
|
|
|
|
|
|
|
} else { |
131
|
0
|
|
|
|
|
0
|
print STDERR $@; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
}; |
134
|
0
|
|
|
|
|
0
|
POSIX::_exit(1); |
135
|
|
|
|
|
|
|
} elsif ($! == EAGAIN) { |
136
|
0
|
|
|
|
|
0
|
sleep 5; |
137
|
0
|
|
|
|
|
0
|
redo; |
138
|
|
|
|
|
|
|
} else { |
139
|
0
|
|
|
|
|
0
|
return $self->_fatal("fork: $!"); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
87
|
|
|
|
|
6623
|
$self; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub _resolve_file_handle { |
147
|
32
|
|
|
32
|
|
137
|
my ($thing, $mode, $default)= @_; |
148
|
32
|
100
|
|
|
|
124
|
if (!defined $thing) { |
|
|
100
|
|
|
|
|
|
149
|
11
|
50
|
|
|
|
413
|
open my $fh, $mode, '/dev/null' or croak "open(/dev/null): $!"; |
150
|
11
|
|
|
|
|
56
|
return $fh; |
151
|
|
|
|
|
|
|
} elsif (ref $thing) { |
152
|
|
|
|
|
|
|
# use 'undef' to mean no-change |
153
|
19
|
100
|
|
|
|
86
|
return (fileno($thing) == fileno($default))? undef : $thing; |
154
|
|
|
|
|
|
|
} else { |
155
|
2
|
50
|
|
|
|
98
|
open my $fh, $mode, $thing or croak "open($thing): $!"; |
156
|
2
|
|
|
|
|
24
|
return $fh; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# Wait for the child. |
161
|
|
|
|
|
|
|
# (0, exit_value) : sucessfully waited on. |
162
|
|
|
|
|
|
|
# (1, undef) : process already reaped and exit value lost. |
163
|
|
|
|
|
|
|
# (2, undef) : process still running. |
164
|
|
|
|
|
|
|
sub _waitpid { |
165
|
204
|
|
|
204
|
|
1005
|
my ($self, $blocking, $wait_seconds) = @_; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
{ |
168
|
|
|
|
|
|
|
# Try to wait on the process. |
169
|
|
|
|
|
|
|
# Implement the optional timeout with the 'alarm' call. |
170
|
204
|
|
|
|
|
790
|
my $result= 0; |
|
204
|
|
|
|
|
546
|
|
171
|
204
|
100
|
100
|
|
|
1566
|
if ($blocking && $wait_seconds) { |
172
|
57
|
|
|
14
|
|
2273
|
local $SIG{ALRM}= sub { die "alarm\n" }; |
|
14
|
|
|
|
|
758
|
|
173
|
57
|
|
|
|
|
1059
|
$alarm->($wait_seconds); |
174
|
57
|
|
|
|
|
575
|
eval { $result= waitpid($self->{_os_obj}, 0); }; |
|
57
|
|
|
|
|
14562754
|
|
175
|
57
|
|
|
|
|
2899
|
$alarm->(0); |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
else { |
178
|
147
|
100
|
|
|
|
22103032
|
$result= waitpid($self->{_os_obj}, $blocking? 0 : WNOHANG); |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# Process finished. Grab the exit value. |
182
|
204
|
100
|
33
|
|
|
2396
|
if ($result == $self->{_os_obj}) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
183
|
87
|
|
|
|
|
634
|
delete $self->{_suspended}; |
184
|
87
|
|
|
|
|
2669
|
return (0, $?); |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
# Process already reaped. We don't know the exist status. |
187
|
|
|
|
|
|
|
elsif ($result == -1 and $! == ECHILD) { |
188
|
0
|
|
|
|
|
0
|
return (1, 0); |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
# Process still running. |
191
|
|
|
|
|
|
|
elsif ($result == 0) { |
192
|
117
|
|
|
|
|
1056
|
return (2, 0); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
# If we reach here, then waitpid caught a signal, so let's retry it. |
195
|
0
|
|
|
|
|
0
|
redo; |
196
|
|
|
|
|
|
|
} |
197
|
0
|
|
|
|
|
0
|
return 0; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub _suspend { |
201
|
0
|
|
|
0
|
|
0
|
kill STOP => $_[0]->{_os_obj}; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub _resume { |
205
|
0
|
|
|
0
|
|
0
|
kill CONT => $_[0]->{_os_obj}; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
sub _terminate { |
209
|
26
|
|
|
26
|
|
180
|
my $self = shift; |
210
|
26
|
50
|
33
|
|
|
1185
|
my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 ); |
|
0
|
|
|
|
|
0
|
|
211
|
|
|
|
|
|
|
# Try to kill the process with different signals. Calling alive() will |
212
|
|
|
|
|
|
|
# collect the exit status of the program. |
213
|
26
|
|
33
|
|
|
510
|
while (@kill_sequence and $self->alive) { |
214
|
26
|
|
|
|
|
109
|
my $sig= shift @kill_sequence; |
215
|
26
|
|
|
|
|
300
|
my $delay= shift @kill_sequence; |
216
|
26
|
|
|
|
|
1973
|
kill($sig, $self->{_os_obj}); |
217
|
26
|
50
|
|
|
|
235
|
next unless defined $delay; |
218
|
26
|
50
|
|
|
|
279
|
last if $self->_reap(1, $delay); # block before sending next signal |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
1; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
__END__ |