line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Spawn::Safe; |
2
|
|
|
|
|
|
|
|
3
|
5
|
|
|
5
|
|
129335
|
use strict; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
190
|
|
4
|
5
|
|
|
5
|
|
6755
|
use IO::Select; |
|
5
|
|
|
|
|
18515
|
|
|
5
|
|
|
|
|
1145
|
|
5
|
5
|
|
|
5
|
|
5900
|
use POSIX ":sys_wait_h"; |
|
5
|
|
|
|
|
45150
|
|
|
5
|
|
|
|
|
40
|
|
6
|
5
|
|
|
5
|
|
7865
|
use Carp qw/croak/; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
250
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# Based off of the smallest PIPE_BUF I've seen. |
9
|
5
|
|
|
5
|
|
30
|
use constant PIPE_BUF_SIZE => 512; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
455
|
|
10
|
|
|
|
|
|
|
|
11
|
5
|
|
|
5
|
|
265
|
use vars qw( $VERSION ); |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
380
|
|
12
|
|
|
|
|
|
|
$VERSION = '2.006'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
BEGIN { |
15
|
5
|
|
|
5
|
|
30
|
use Exporter (); |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
275
|
|
16
|
5
|
|
|
5
|
|
15
|
our ( @ISA, @EXPORT ); |
17
|
|
|
|
|
|
|
|
18
|
5
|
|
|
|
|
85
|
@ISA = qw(Exporter); |
19
|
5
|
|
|
|
|
6385
|
@EXPORT = qw/ spawn_safe /; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 NAME |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
Spawn::Safe - Fork and exec a process "safely". |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 EXAMPLE |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
A basic example: |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
use Spawn::Safe; |
31
|
|
|
|
|
|
|
use Data::Dumper; |
32
|
|
|
|
|
|
|
my $results = spawn_safe({ argv => [ 'ls', '-al', '/var/' ], timeout => 2 }); |
33
|
|
|
|
|
|
|
die Dumper $results; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
As a replacement for backticks: |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
use Spawn::Safe; |
38
|
|
|
|
|
|
|
# $output = `ls -al /var/`; |
39
|
|
|
|
|
|
|
$output = spawn_safe(qw{ ls -al /var/ })->{stdout}; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=head1 SYNOPSIS |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
Spawn::Safe is a module designed to make "safe" calls to outside binaries |
44
|
|
|
|
|
|
|
easier and more reliable. Spawn::Safe never invokes a shell (unless the shell |
45
|
|
|
|
|
|
|
is explicitly requested), so escaping for the shell is not a concern. An |
46
|
|
|
|
|
|
|
optional timeout is made available, so scripts will not hang forever, and the |
47
|
|
|
|
|
|
|
caller is able to retrieve both stdout and stderr. An optional string can be |
48
|
|
|
|
|
|
|
passed to the executed program's standard input stream. |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head1 FUNCTIONS |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=head2 spawn_safe |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
Spawn (via fork and exec) the specified binary and capture its output. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=head3 Parameters |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
If passed a single scalar, spawn_safe will assume that to be the the target |
59
|
|
|
|
|
|
|
binary, and execute it without a limit on runtime. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
If passed an array, spawn_safe will execute the first element of the array as |
62
|
|
|
|
|
|
|
the target binary, with the remaining elements passed as parameters to the |
63
|
|
|
|
|
|
|
target binary, without a limit on runtime. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
The preferred mode is to pass in a single hash reference. When called this |
66
|
|
|
|
|
|
|
way, the following keys are available: |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=over 4 |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=item * argv |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
Either a string containing the name of the binary which will be called with no |
73
|
|
|
|
|
|
|
parameters: |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
my $r = spawn_safe({ argv => 'ls' }); |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
Or an array reference containing the binary and all of its parameters: |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my $r = spawn_safe({ argv => [ 'ls', '-al' ] }); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=item * timeout |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
The amount of time, in seconds, the binary will be allowed to run before being |
84
|
|
|
|
|
|
|
killed and a timeout error being returned. If false (or is otherwise undefined |
85
|
|
|
|
|
|
|
or unset), the timeout will be infinite. |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=item * env |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
A hash reference containing the new environment for the executed binary. If |
90
|
|
|
|
|
|
|
false (or otherwise undefined or unset), it will default to the current |
91
|
|
|
|
|
|
|
environment. You must specify the complete environment, as the current |
92
|
|
|
|
|
|
|
environment will be overwritten as a whole. To alter only one variable, a copy |
93
|
|
|
|
|
|
|
of the enviornment must be made, altered, and then passed in as a whole, eg: |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
my %new_env = %ENV; |
96
|
|
|
|
|
|
|
$new_env{'TMP'} = '/var/tmp/'; |
97
|
|
|
|
|
|
|
my $r = spawn_safe({ argv => 'ls', env => \%new_env }); |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
Please note that if a new environment is specified, the new binary's |
100
|
|
|
|
|
|
|
environment will be altered before the call to exec() (but after the fork(), |
101
|
|
|
|
|
|
|
so the caller's environment will be unchanged), so the new environment will |
102
|
|
|
|
|
|
|
take effect before the new binary is launched. This means that if you alter a |
103
|
|
|
|
|
|
|
part of the environment needed to launch the binary (eg, by changing PATH, |
104
|
|
|
|
|
|
|
LD_LIBRARY_PATH, etc), these new variables will need to be set such that the |
105
|
|
|
|
|
|
|
binary can be executed successfully. |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=item * stdin |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
A string to be passed to the target binary's standard input stream. The string |
110
|
|
|
|
|
|
|
will be written into the stream and then the stream will be closed. |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
my $r = spawn_safe({ argv => [ '/usr/bin/tr', 'a', 'b' ], stdin => 'aaa' }); |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=back |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=head3 Return value |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
A hash reference will be returned containing one of the following sets of |
119
|
|
|
|
|
|
|
values: |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=over 4 |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=item * If the binary could not be spawned, the single key, 'error' will be |
124
|
|
|
|
|
|
|
set, which is a text description of the reason the binary could not be spawned. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
=item * If the binary was executed successfully, but terminated due to a |
127
|
|
|
|
|
|
|
timeout, the keys 'error', 'stdout', and 'stderr', will be set. The value for |
128
|
|
|
|
|
|
|
'error' will be set to 'timed out'. Any data collected from the executed |
129
|
|
|
|
|
|
|
binary's stdout or stderr will also be made available, but since the binary was |
130
|
|
|
|
|
|
|
forcefully terminated, the data may be incomplete. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item * If the binary was executed successfully and ran to completion, the keys |
133
|
|
|
|
|
|
|
'exit_code', 'stdout, and 'stderr', will all be available. |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
=back |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
The key "exit_zero" will always be present, which is true if the binary is |
138
|
|
|
|
|
|
|
executed successfully and exited with a code of zero. |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head3 Notes |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
The current PATH will be searched for the binary, if available. Open |
143
|
|
|
|
|
|
|
filehandles are subject to Perl's standard close-on-exec behavior. A shell will |
144
|
|
|
|
|
|
|
not be invoked unless explicitly defined as the target binary, as such output |
145
|
|
|
|
|
|
|
redirection and other shell features are unavailable. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
If passed invalid parameters, spawn_safe will croak. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
Please note that when specifying a timeout, alarm() is no longer used. If the |
150
|
|
|
|
|
|
|
clock is stepped significantly backwards during a timeout, a possibly false |
151
|
|
|
|
|
|
|
timeout error may be thrown. Timeout accuracy should be within one second. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
If a timeout does occur, the spawned program will be sent a SIGKILL before |
154
|
|
|
|
|
|
|
spawn_safe returns. |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=head1 COMPATIBILITY |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
This module attempts to work on MSWin32 but I've been unable to get it working |
159
|
|
|
|
|
|
|
due to strange issues with IO::Select. I haven't been able to track down the |
160
|
|
|
|
|
|
|
exact cause, so for now I don't believe this module functions on MSWin32. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
Linux and BSD are tested and supported platforms. |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
=cut |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub spawn_safe { |
167
|
14
|
|
|
14
|
1
|
27528
|
my ( $params ) = @_; |
168
|
14
|
|
|
|
|
30
|
my @binary_and_params; |
169
|
|
|
|
|
|
|
my $timeout; |
170
|
0
|
|
|
|
|
0
|
my $start_time; |
171
|
0
|
|
|
|
|
0
|
my $new_env; |
172
|
0
|
|
|
|
|
0
|
my $for_stdin; |
173
|
14
|
|
|
|
|
2601
|
my $for_stdin_offset = 0; |
174
|
|
|
|
|
|
|
|
175
|
14
|
50
|
|
|
|
78
|
if ( ref $params eq '' ) { |
|
|
50
|
|
|
|
|
|
176
|
0
|
|
|
|
|
0
|
@binary_and_params = @_; |
177
|
|
|
|
|
|
|
} elsif ( ref $params eq 'HASH' ) { |
178
|
14
|
50
|
|
|
|
56
|
if ( !$params->{'argv'} ) { |
179
|
0
|
|
|
|
|
0
|
croak "Invalid parameters (missing argv)"; |
180
|
|
|
|
|
|
|
} |
181
|
14
|
50
|
|
|
|
51
|
if ( ref $params->{'argv'} eq 'ARRAY' ) { |
|
|
0
|
|
|
|
|
|
182
|
14
|
|
|
|
|
23
|
@binary_and_params = @{ $params->{'argv'} }; |
|
14
|
|
|
|
|
271
|
|
183
|
|
|
|
|
|
|
} elsif ( ref $params->{'argv'} eq '' ) { |
184
|
0
|
|
|
|
|
0
|
@binary_and_params = $params->{'argv'}; |
185
|
|
|
|
|
|
|
} else { |
186
|
0
|
|
|
|
|
0
|
croak "Invalid parameters (what is argv?)"; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
14
|
50
|
|
|
|
53
|
if ( ref $params->{'env'} eq 'HASH' ) { |
190
|
0
|
|
|
|
|
0
|
$new_env = $params->{'env'}; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
14
|
|
50
|
|
|
212
|
$timeout = $params->{'timeout'} || undef; |
194
|
14
|
|
100
|
|
|
117
|
$for_stdin = $params->{'stdin'} || undef; |
195
|
|
|
|
|
|
|
} else { |
196
|
0
|
|
|
|
|
0
|
croak "Invalid parameters"; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
14
|
|
|
|
|
23
|
my ( $child_pid, $exit_code ); |
200
|
0
|
|
|
|
|
0
|
my ( $parent_read_stdout, $child_write_stdout ); |
201
|
0
|
|
|
|
|
0
|
my ( $parent_read_stderr, $child_write_stderr ); |
202
|
0
|
|
|
|
|
0
|
my ( $parent_signal, $child_wait ); |
203
|
0
|
|
|
|
|
0
|
my ( $parent_read_errors, $child_write_errors ); |
204
|
0
|
|
|
|
|
0
|
my ( $child_read_stdin, $parent_write_stdin ); |
205
|
|
|
|
|
|
|
|
206
|
14
|
|
|
|
|
77
|
my ( $read_stdout, $read_stderr, $read_errors ) = ( '' ) x 3; |
207
|
|
|
|
|
|
|
|
208
|
14
|
50
|
|
|
|
878
|
pipe( $parent_read_stdout, $child_write_stdout ) || die $!; |
209
|
14
|
50
|
|
|
|
443
|
pipe( $parent_read_stderr, $child_write_stderr ) || die $!; |
210
|
14
|
50
|
|
|
|
2857
|
pipe( $parent_read_errors, $child_write_errors ) || die $!; |
211
|
14
|
50
|
|
|
|
367
|
pipe( $child_read_stdin, $parent_write_stdin ) || die $!; |
212
|
14
|
50
|
|
|
|
347
|
pipe( $child_wait, $parent_signal ) || die $!; |
213
|
|
|
|
|
|
|
|
214
|
14
|
|
|
|
|
19399
|
$child_pid = fork(); |
215
|
14
|
50
|
|
|
|
3987
|
if ( !defined $child_pid ) { |
216
|
0
|
|
|
|
|
0
|
die "Unable to fork: $!"; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
14
|
100
|
|
|
|
282
|
if ( !$child_pid ) { |
220
|
4
|
|
|
|
|
1022
|
close( $parent_signal ); |
221
|
4
|
|
|
|
|
227
|
close( $parent_read_stdout ); |
222
|
4
|
|
|
|
|
65
|
close( $parent_read_stderr ); |
223
|
4
|
|
|
|
|
71
|
close( $parent_read_errors ); |
224
|
4
|
|
|
|
|
60
|
close( $parent_write_stdin ); |
225
|
|
|
|
|
|
|
|
226
|
4
|
50
|
|
|
|
177
|
if ( tied( *STDIN ) ) { untie *STDIN; } |
|
0
|
|
|
|
|
0
|
|
227
|
4
|
50
|
|
|
|
406
|
if ( tied( *STDOUT ) ) { untie *STDOUT; } |
|
0
|
|
|
|
|
0
|
|
228
|
4
|
50
|
|
|
|
46
|
if ( tied( *STDERR ) ) { untie *STDERR; } |
|
0
|
|
|
|
|
0
|
|
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# Be 5.6 compatible and do it the old way. |
231
|
4
|
50
|
|
|
|
1500
|
open( STDOUT, '>&' . fileno( $child_write_stdout ) ) || goto CHILD_ERR; |
232
|
4
|
50
|
|
|
|
228
|
open( STDERR, '>&' . fileno( $child_write_stderr ) ) || goto CHILD_ERR; |
233
|
4
|
50
|
|
|
|
155
|
open( STDIN, '<&' . fileno( $child_read_stdin ) ) || goto CHILD_ERR; |
234
|
|
|
|
|
|
|
|
235
|
4
|
50
|
|
|
|
85
|
if ( $new_env ) { %ENV = %{$new_env}; } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
236
|
|
|
|
|
|
|
|
237
|
4
|
|
|
|
|
1521
|
<$child_wait>; |
238
|
4
|
|
|
|
|
98
|
close( $child_wait ); |
239
|
|
|
|
|
|
|
|
240
|
4
|
|
|
|
|
6
|
{ exec { $binary_and_params[0] } @binary_and_params; } |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
0
|
|
241
|
|
|
|
|
|
|
CHILD_ERR: |
242
|
0
|
|
|
|
|
0
|
print $child_write_errors $!; |
243
|
0
|
|
|
|
|
0
|
close( $child_write_errors ); |
244
|
0
|
|
|
|
|
0
|
close( $child_write_stdout ); |
245
|
0
|
|
|
|
|
0
|
close( $child_write_stderr ); |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# Exit code here isn't actually used. |
248
|
0
|
|
|
|
|
0
|
exit 42; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
10
|
|
|
|
|
506
|
close( $child_write_stdout ); |
252
|
10
|
|
|
|
|
175
|
close( $child_write_stderr ); |
253
|
10
|
|
|
|
|
150
|
close( $child_read_stdin ); |
254
|
10
|
|
|
|
|
119
|
close( $child_wait ); |
255
|
10
|
|
|
|
|
78
|
close( $child_write_errors ); |
256
|
10
|
|
50
|
|
|
1584
|
my $sel = IO::Select->new( $parent_read_stdout, $parent_read_stderr, $parent_read_errors ) |
257
|
|
|
|
|
|
|
|| die "Failed to create IO::Select object!"; |
258
|
10
|
|
|
|
|
2057
|
my $wsel; |
259
|
|
|
|
|
|
|
|
260
|
10
|
100
|
|
|
|
50
|
if ( defined $for_stdin ) { |
261
|
1
|
|
50
|
|
|
28
|
$wsel = IO::Select->new( $parent_write_stdin ) |
262
|
|
|
|
|
|
|
|| die "Failed to create IO::Select object!"; |
263
|
|
|
|
|
|
|
} else { |
264
|
9
|
|
|
|
|
108
|
close( $parent_write_stdin ); |
265
|
|
|
|
|
|
|
} |
266
|
10
|
|
|
|
|
146
|
close( $parent_signal ); |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# Don't bother calling time if we're never going to timeout. |
269
|
10
|
50
|
|
|
|
75
|
$start_time = defined $timeout ? time() : 1; |
270
|
10
|
|
|
|
|
18
|
my $select_time = $timeout; |
271
|
10
|
|
|
|
|
45
|
MAIN_WHILE: while ( 1 ) { |
272
|
93
|
|
|
|
|
1818
|
my ( $readus, $writeus, undef ) = IO::Select::select( $sel, $wsel, undef, $select_time ); |
273
|
93
|
100
|
|
|
|
6543784
|
if ( ref $readus eq 'ARRAY' ) { |
274
|
91
|
|
|
|
|
633
|
foreach my $readme ( @{$readus} ) { |
|
91
|
|
|
|
|
252
|
|
275
|
66
|
|
|
|
|
116
|
my $read; |
276
|
66
|
|
|
|
|
550
|
my $r = sysread( $readme, $read, PIPE_BUF_SIZE ); |
277
|
66
|
100
|
66
|
|
|
1199
|
if ( ( !defined $r ) || ( $r < 1 ) ) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
278
|
26
|
|
|
|
|
130
|
$sel->remove( $readme ); |
279
|
26
|
100
|
|
|
|
1632
|
if ( $sel->count() == 0 ) { last MAIN_WHILE; } |
|
8
|
|
|
|
|
68
|
|
280
|
|
|
|
|
|
|
} elsif ( $readme == $parent_read_stdout ) { |
281
|
37
|
|
|
|
|
235
|
$read_stdout .= $read; |
282
|
|
|
|
|
|
|
} elsif ( $readme == $parent_read_stderr ) { |
283
|
0
|
|
|
|
|
0
|
$read_stderr .= $read; |
284
|
|
|
|
|
|
|
} elsif ( $readme == $parent_read_errors ) { |
285
|
3
|
|
|
|
|
54
|
$read_errors .= $read; |
286
|
|
|
|
|
|
|
} else { |
287
|
0
|
|
|
|
|
0
|
die 'Should not be here!'; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
} |
291
|
85
|
100
|
|
|
|
600
|
if ( ref $writeus eq 'ARRAY' ) { |
292
|
83
|
|
|
|
|
89
|
foreach my $writeme ( @{$writeus} ) { |
|
83
|
|
|
|
|
414
|
|
293
|
33
|
50
|
|
|
|
92
|
if ( $writeme == $parent_write_stdin ) { |
294
|
33
|
50
|
|
|
|
74
|
my $write_size = PIPE_BUF_SIZE <= length( $for_stdin ) ? PIPE_BUF_SIZE : length( $for_stdin ); |
295
|
33
|
|
|
|
|
1270
|
syswrite( $parent_write_stdin, $for_stdin, $write_size, $for_stdin_offset ); |
296
|
33
|
|
|
|
|
40
|
$for_stdin_offset += $write_size; |
297
|
33
|
100
|
|
|
|
937
|
if ( $for_stdin_offset >= length( $for_stdin ) ) { |
298
|
1
|
|
|
|
|
8
|
$wsel->remove( $parent_write_stdin ); |
299
|
1
|
|
|
|
|
63
|
close( $parent_write_stdin ); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
} |
304
|
85
|
50
|
|
|
|
339
|
if ( defined $timeout ) { |
305
|
|
|
|
|
|
|
# We do a little gymnastics here to check if the time has rolled |
306
|
|
|
|
|
|
|
# backwards (ie, ntpd stepped the time backwards). If it went |
307
|
|
|
|
|
|
|
# backwards, there's no way to tell how long we've waited, so |
308
|
|
|
|
|
|
|
# it's probably safer to assume we've waited too long. Hopefully |
309
|
|
|
|
|
|
|
# steps backwards will be infrequent, as ntpd usually slews rather |
310
|
|
|
|
|
|
|
# than steps. |
311
|
|
|
|
|
|
|
# If the time rolls over, we should end up with a hugely negative |
312
|
|
|
|
|
|
|
# $timeout after subtraction, so that will probably trigger a |
313
|
|
|
|
|
|
|
# timeout as well. Imperfect, but somewhat better than waiting |
314
|
|
|
|
|
|
|
# forever. Fortunately this probably won't ever come up. |
315
|
85
|
|
|
|
|
112
|
my $timenow = time(); |
316
|
85
|
|
|
|
|
106
|
$select_time = $timeout - ( $timenow - $start_time ); |
317
|
85
|
100
|
66
|
|
|
678
|
if ( $timenow < $start_time || $select_time <= 0 ) { |
318
|
2
|
|
|
|
|
34
|
undef $start_time; |
319
|
2
|
|
|
|
|
16
|
last; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
# Did we timeout? undef $start_time is our timeout flag. |
324
|
10
|
100
|
|
|
|
54
|
if ( defined $start_time ) { |
325
|
8
|
|
|
|
|
214
|
waitpid( $child_pid, 0 ); |
326
|
8
|
|
|
|
|
94
|
$exit_code = $? >> 8; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
10
|
|
|
|
|
235
|
close( $parent_read_stdout ); |
330
|
10
|
|
|
|
|
310
|
close( $parent_read_stderr ); |
331
|
10
|
|
|
|
|
108
|
close( $parent_read_errors ); |
332
|
|
|
|
|
|
|
|
333
|
10
|
100
|
|
|
|
40
|
if ( !defined $start_time ) { |
334
|
|
|
|
|
|
|
# If the child is still running, kill it. |
335
|
2
|
50
|
|
|
|
54
|
if ( waitpid( $child_pid, WNOHANG ) != -1 ) { |
336
|
2
|
|
|
|
|
96
|
kill( 9, $child_pid ); |
337
|
2
|
|
|
|
|
444
|
waitpid( $child_pid, 0 ); |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
return { |
341
|
2
|
|
|
|
|
192
|
'error' => 'timed out', |
342
|
|
|
|
|
|
|
'stdout' => $read_stdout, |
343
|
|
|
|
|
|
|
'stderr' => $read_stderr, |
344
|
|
|
|
|
|
|
'exit_zero' => 0, |
345
|
|
|
|
|
|
|
}; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
8
|
100
|
|
|
|
29
|
if ( $read_errors ) { |
349
|
|
|
|
|
|
|
return { |
350
|
3
|
|
|
|
|
210
|
'error' => $read_errors, |
351
|
|
|
|
|
|
|
'exit_zero' => 0, |
352
|
|
|
|
|
|
|
}; |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
return { |
355
|
5
|
|
|
|
|
513
|
'exit_code' => $exit_code, |
356
|
|
|
|
|
|
|
'stdout' => $read_stdout, |
357
|
|
|
|
|
|
|
'stderr' => $read_stderr, |
358
|
|
|
|
|
|
|
'exit_zero' => $exit_code == 0, |
359
|
|
|
|
|
|
|
}; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
=head1 LICENSE |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
This module is licensed under the same terms as Perl itself. |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
=head1 CHANGES |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
=head2 Version 2.006 - 2013-11-12, jeagle |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
Modify PIPE_BUF_SIZE to be more conservative to ensure non-blocking writes on |
371
|
|
|
|
|
|
|
all OSs. |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
=head2 Version 2.005 - 2013-11-11, jeagle |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
Add stdin option, clarify docs, add exit_zero return flag. |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
=head2 Version 2.004 - 2012-08-13, jeagle |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
Include license. Oops. |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=head2 Version 2.003 - 2012-04-01, jeagle |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
Untie any tied filehandles before we re-open them to ourselves to work around |
384
|
|
|
|
|
|
|
any weird tie behavior (should fix issues running under FCGI). Thanks Charly. |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
=head2 Version 2.002 - 2012-01-04, jeagle |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
Correct documentation (RT#72831, thanks Stas) |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
Update unit tests to specify number of tests instead of using no_plan, |
391
|
|
|
|
|
|
|
otherwse CPAN Testers reports tests fail. |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=head2 Version 2.001 - 2011-06-13, jeagle |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
Give the spawned program its own STDIN. |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=head2 Version 2.000 - 2011-05-12, jeagle |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
Correct timeout handling. Attempt to correct unit tests for MSWin32, but |
400
|
|
|
|
|
|
|
there seems to be an issue with IO::Select preventing it from working |
401
|
|
|
|
|
|
|
properly. Update docs for MSWin32. |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=head2 Version 1.9 - 2011-05-10, jeagle |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
Don't use clock_gettime(), use time() and return a timeout if time steps |
406
|
|
|
|
|
|
|
backwards. |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
=head2 Version 1.8 - 2011-05-09, jeagle |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
Clean up docs, stop using SIGALARM for timeouts. |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=head2 Version 1.7 - 2010-07-09, jeagle |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
Clean up for release to CPAN. |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=head2 Version 0.4 - 2009-05-13, jeagle |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
Correct a warning issued when using spawn_safe without a timeout. |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
Fix compatibility with perl < 5.8. |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=head2 Version 0.3 - 2009-04-21, jeagle |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
Clarify documentation regarding use of SIGALRM and for passing of a new |
425
|
|
|
|
|
|
|
environment. |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
Correct a warning thrown by exec(). |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
Correct an issue with incorrectly handled timeouts. |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=head2 Version 0.2 - 2009-04-20, jeagle |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
Modify API, breaking compatibility, for clarity and expandability. |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
Add the ability to specify the target program's environment. |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
Return the (partial) stdout and stderr on a timeout. |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
Update and clarify documentation. |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
=head2 Version 0.1 - 2009-04-11, jeagle |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
Inital release. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=cut |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
1; |