File: | Dpkg/IPC.pm |
Coverage: | 81.9% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> | ||||||
2 | # Copyright © 2008 Frank Lichtenheld <djpig@debian.org> | ||||||
3 | # Copyright © 2008-2010, 2012-2015 Guillem Jover <guillem@debian.org> | ||||||
4 | # | ||||||
5 | # This program is free software; you can redistribute it and/or modify | ||||||
6 | # it under the terms of the GNU General Public License as published by | ||||||
7 | # the Free Software Foundation; either version 2 of the License, or | ||||||
8 | # (at your option) any later version. | ||||||
9 | # | ||||||
10 | # This program is distributed in the hope that it will be useful, | ||||||
11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||
12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||||
13 | # GNU General Public License for more details. | ||||||
14 | # | ||||||
15 | # You should have received a copy of the GNU General Public License | ||||||
16 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | ||||||
17 | |||||||
18 | package Dpkg::IPC; | ||||||
19 | |||||||
20 | 622 622 622 | 1767 560 7889 | use strict; | ||||
21 | 622 622 622 | 1211 562 18758 | use warnings; | ||||
22 | |||||||
23 | our $VERSION = '1.02'; | ||||||
24 | our @EXPORT = qw( | ||||||
25 | spawn | ||||||
26 | wait_child | ||||||
27 | ); | ||||||
28 | |||||||
29 | 622 622 622 | 1226 604 18176 | use Carp; | ||||
30 | 622 622 622 | 1180 611 8878 | use Exporter qw(import); | ||||
31 | |||||||
32 | 622 622 622 | 1280 546 18137 | use Dpkg::ErrorHandling; | ||||
33 | 622 622 622 | 1177 601 526850 | use Dpkg::Gettext; | ||||
34 | |||||||
35 | =encoding utf8 | ||||||
36 | |||||||
37 - 146 | =head1 NAME Dpkg::IPC - helper functions for IPC =head1 DESCRIPTION Dpkg::IPC offers helper functions to allow you to execute other programs in an easy, yet flexible way, while hiding all the gory details of IPC (Inter-Process Communication) from you. =head1 FUNCTIONS =over 4 =item $pid = spawn(%opts) Creates a child process and executes another program in it. The arguments are interpreted as a hash of options, specifying how to handle the in and output of the program to execute. Returns the pid of the child process (unless the wait_child option was given). Any error will cause the function to exit with one of the Dpkg::ErrorHandling functions. Options: =over 4 =item exec Can be either a scalar, i.e. the name of the program to be executed, or an array reference, i.e. the name of the program plus additional arguments. Note that the program will never be executed via the shell, so you can't specify additional arguments in the scalar string and you can't use any shell facilities like globbing. Mandatory Option. =item from_file, to_file, error_to_file Filename as scalar. Standard input/output/error of the child process will be redirected to the file specified. =item from_handle, to_handle, error_to_handle Filehandle. Standard input/output/error of the child process will be dup'ed from the handle. =item from_pipe, to_pipe, error_to_pipe Scalar reference or object based on IO::Handle. A pipe will be opened for each of the two options and either the reading (C<to_pipe> and C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in the referenced scalar. Standard input/output/error of the child process will be dup'ed to the other ends of the pipes. =item from_string, to_string, error_to_string Scalar reference. Standard input/output/error of the child process will be redirected to the string given as reference. Note that it wouldn't be strictly necessary to use a scalar reference for C<from_string>, as the string is not modified in any way. This was chosen only for reasons of symmetry with C<to_string> and C<error_to_string>. C<to_string> and C<error_to_string> imply the C<wait_child> option. =item wait_child Scalar. If containing a true value, wait_child() will be called before returning. The return value of spawn() will be a true value, not the pid. =item nocheck Scalar. Option of the wait_child() call. =item timeout Scalar. Option of the wait_child() call. =item chdir Scalar. The child process will chdir in the indicated directory before calling exec. =item env Hash reference. The child process will populate %ENV with the items of the hash before calling exec. This allows exporting environment variables. =item delete_env Array reference. The child process will remove all environment variables listed in the array before calling exec. =item sig Hash reference. The child process will populate %SIG with the items of the hash before calling exec. This allows setting signal dispositions. =item delete_sig Array reference. The child process will reset all signals listed in the array to their default dispositions before calling exec. =back =cut | ||||||
147 | |||||||
148 | sub _check_opts { | ||||||
149 | 134931 | 347077 | my (%opts) = @_; | ||||
150 | |||||||
151 | croak 'exec parameter is mandatory in spawn()' | ||||||
152 | 134931 | 250694 | unless $opts{exec}; | ||||
153 | |||||||
154 | 134931 | 172569 | my $to = my $error_to = my $from = 0; | ||||
155 | 134931 | 324749 | foreach my $thing (qw(file handle string pipe)) { | ||||
156 | 539724 | 580606 | $to++ if $opts{"to_$thing"}; | ||||
157 | 539724 | 674537 | $error_to++ if $opts{"error_to_$thing"}; | ||||
158 | 539724 | 525527 | $from++ if $opts{"from_$thing"}; | ||||
159 | } | ||||||
160 | 134931 | 172372 | croak 'not more than one of to_* parameters is allowed' | ||||
161 | if $to > 1; | ||||||
162 | 134931 | 133334 | croak 'not more than one of error_to_* parameters is allowed' | ||||
163 | if $error_to > 1; | ||||||
164 | 134931 | 148253 | croak 'not more than one of from_* parameters is allowed' | ||||
165 | if $from > 1; | ||||||
166 | |||||||
167 | 134931 | 151017 | foreach my $param (qw(to_string error_to_string from_string)) { | ||||
168 | 404793 | 1181011 | if (exists $opts{$param} and | ||||
169 | (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) { | ||||||
170 | 0 | 0 | croak "parameter $param must be a scalar reference"; | ||||
171 | } | ||||||
172 | } | ||||||
173 | |||||||
174 | 134931 | 126084 | foreach my $param (qw(to_pipe error_to_pipe from_pipe)) { | ||||
175 | 404793 | 400366 | if (exists $opts{$param} and | ||||
176 | (not ref $opts{$param} or (ref $opts{$param} ne 'SCALAR' and | ||||||
177 | not $opts{$param}->isa('IO::Handle')))) { | ||||||
178 | 0 | 0 | croak "parameter $param must be a scalar reference or " . | ||||
179 | 'an IO::Handle object'; | ||||||
180 | } | ||||||
181 | } | ||||||
182 | |||||||
183 | 134931 | 237591 | if (exists $opts{timeout} and defined($opts{timeout}) and | ||||
184 | $opts{timeout} !~ /^\d+$/) { | ||||||
185 | 0 | 0 | croak 'parameter timeout must be an integer'; | ||||
186 | } | ||||||
187 | |||||||
188 | 134931 | 166343 | if (exists $opts{env} and ref($opts{env}) ne 'HASH') { | ||||
189 | 0 | 0 | croak 'parameter env must be a hash reference'; | ||||
190 | } | ||||||
191 | |||||||
192 | 134931 | 207495 | if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') { | ||||
193 | 0 | 0 | croak 'parameter delete_env must be an array reference'; | ||||
194 | } | ||||||
195 | |||||||
196 | 134931 | 174528 | if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') { | ||||
197 | 0 | 0 | croak 'parameter sig must be a hash reference'; | ||||
198 | } | ||||||
199 | |||||||
200 | 134931 | 180371 | if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') { | ||||
201 | 0 | 0 | croak 'parameter delete_sig must be an array reference'; | ||||
202 | } | ||||||
203 | |||||||
204 | 134931 | 144817 | return %opts; | ||||
205 | } | ||||||
206 | |||||||
207 | sub spawn { | ||||||
208 | 134931 | 1 | 313489 | my (%opts) = @_; | |||
209 | 134931 | 115716 | my @prog; | ||||
210 | |||||||
211 | 134931 | 468026 | _check_opts(%opts); | ||||
212 | 134931 | 705711 | $opts{close_in_child} //= []; | ||||
213 | 134931 | 346777 | if (ref($opts{exec}) =~ /ARRAY/) { | ||||
214 | 134919 134919 | 120438 224326 | push @prog, @{$opts{exec}}; | ||||
215 | } elsif (not ref($opts{exec})) { | ||||||
216 | 12 | 16 | push @prog, $opts{exec}; | ||||
217 | } else { | ||||||
218 | 0 | 0 | croak 'invalid exec parameter in spawn()'; | ||||
219 | } | ||||||
220 | 134931 | 113888 | my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe); | ||||
221 | 134931 | 200369 | if ($opts{to_string}) { | ||||
222 | 397 | 668 | $opts{to_pipe} = \$to_string_pipe; | ||||
223 | 397 | 525 | $opts{wait_child} = 1; | ||||
224 | } | ||||||
225 | 134931 | 138889 | if ($opts{error_to_string}) { | ||||
226 | 134806 | 157367 | $opts{error_to_pipe} = \$error_to_string_pipe; | ||||
227 | 134806 | 126844 | $opts{wait_child} = 1; | ||||
228 | } | ||||||
229 | 134931 | 142263 | if ($opts{from_string}) { | ||||
230 | 5 | 5 | $opts{from_pipe} = \$from_string_pipe; | ||||
231 | } | ||||||
232 | # Create pipes if needed | ||||||
233 | 134931 | 117062 | my ($input_pipe, $output_pipe, $error_pipe); | ||||
234 | 134931 | 173962 | if ($opts{from_pipe}) { | ||||
235 | 18 | 325 | pipe($opts{from_handle}, $input_pipe) | ||||
236 | or syserr(g_('pipe for %s'), "@prog"); | ||||||
237 | 18 18 | 12 18 | ${$opts{from_pipe}} = $input_pipe; | ||||
238 | 18 18 | 17 18 | push @{$opts{close_in_child}}, $input_pipe; | ||||
239 | } | ||||||
240 | 134931 | 176740 | if ($opts{to_pipe}) { | ||||
241 | pipe($output_pipe, $opts{to_handle}) | ||||||
242 | 406 | 9318 | or syserr(g_('pipe for %s'), "@prog"); | ||||
243 | 406 406 | 347 572 | ${$opts{to_pipe}} = $output_pipe; | ||||
244 | 406 406 | 485 690 | push @{$opts{close_in_child}}, $output_pipe; | ||||
245 | } | ||||||
246 | 134931 | 157440 | if ($opts{error_to_pipe}) { | ||||
247 | pipe($error_pipe, $opts{error_to_handle}) | ||||||
248 | 134806 | 2687261 | or syserr(g_('pipe for %s'), "@prog"); | ||||
249 | 134806 134806 | 296917 138070 | ${$opts{error_to_pipe}} = $error_pipe; | ||||
250 | 134806 134806 | 121136 319750 | push @{$opts{close_in_child}}, $error_pipe; | ||||
251 | } | ||||||
252 | # Fork and exec | ||||||
253 | 134931 | 59939738 | my $pid = fork(); | ||||
254 | 134931 | 1630792 | syserr(g_('cannot fork for %s'), "@prog") unless defined $pid; | ||||
255 | 134931 | 184372 | if (not $pid) { | ||||
256 | # Define environment variables | ||||||
257 | 595 | 18743 | if ($opts{env}) { | ||||
258 | 2 2 | 16 86 | foreach (keys %{$opts{env}}) { | ||||
259 | 6 | 156 | $ENV{$_} = $opts{env}{$_}; | ||||
260 | } | ||||||
261 | } | ||||||
262 | 595 | 7421 | if ($opts{delete_env}) { | ||||
263 | 3 3 | 11 60 | delete $ENV{$_} foreach (@{$opts{delete_env}}); | ||||
264 | } | ||||||
265 | # Define signal dispositions. | ||||||
266 | 595 | 13041 | if ($opts{sig}) { | ||||
267 | 0 0 | 0 0 | foreach (keys %{$opts{sig}}) { | ||||
268 | 0 | 0 | $SIG{$_} = $opts{sig}{$_}; | ||||
269 | } | ||||||
270 | } | ||||||
271 | 595 | 5154 | if ($opts{delete_sig}) { | ||||
272 | 0 0 | 0 0 | delete $SIG{$_} foreach (@{$opts{delete_sig}}); | ||||
273 | } | ||||||
274 | # Change the current directory | ||||||
275 | 595 | 2913 | if ($opts{chdir}) { | ||||
276 | 3 | 133 | chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir}); | ||||
277 | } | ||||||
278 | # Redirect STDIN if needed | ||||||
279 | 595 | 4530 | if ($opts{from_file}) { | ||||
280 | open(STDIN, '<', $opts{from_file}) | ||||||
281 | 27 | 4163 | or syserr(g_('cannot open %s'), $opts{from_file}); | ||||
282 | } elsif ($opts{from_handle}) { | ||||||
283 | open(STDIN, '<&', $opts{from_handle}) | ||||||
284 | 9 | 565 | or syserr(g_('reopen stdin')); | ||||
285 | # has been duped, can be closed | ||||||
286 | 9 9 | 14 70 | push @{$opts{close_in_child}}, $opts{from_handle}; | ||||
287 | } | ||||||
288 | # Redirect STDOUT if needed | ||||||
289 | 595 | 5320 | if ($opts{to_file}) { | ||||
290 | open(STDOUT, '>', $opts{to_file}) | ||||||
291 | 27 | 1290 | or syserr(g_('cannot write %s'), $opts{to_file}); | ||||
292 | } elsif ($opts{to_handle}) { | ||||||
293 | open(STDOUT, '>&', $opts{to_handle}) | ||||||
294 | 30 | 1987 | or syserr(g_('reopen stdout')); | ||||
295 | # has been duped, can be closed | ||||||
296 | 30 30 | 385 221 | push @{$opts{close_in_child}}, $opts{to_handle}; | ||||
297 | } | ||||||
298 | # Redirect STDERR if needed | ||||||
299 | 595 | 11136 | if ($opts{error_to_file}) { | ||||
300 | open(STDERR, '>', $opts{error_to_file}) | ||||||
301 | 4 | 88 | or syserr(g_('cannot write %s'), $opts{error_to_file}); | ||||
302 | } elsif ($opts{error_to_handle}) { | ||||||
303 | open(STDERR, '>&', $opts{error_to_handle}) | ||||||
304 | 569 | 43031 | or syserr(g_('reopen stdout')); | ||||
305 | # has been duped, can be closed | ||||||
306 | 569 569 | 792 4075 | push @{$opts{close_in_child}}, $opts{error_to_handle}; | ||||
307 | } | ||||||
308 | # Close some inherited filehandles | ||||||
309 | 595 595 | 817 7645 | close($_) foreach (@{$opts{close_in_child}}); | ||||
310 | # Execute the program | ||||||
311 | 595 595 | 557 0 | exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog"); | ||||
312 | } | ||||||
313 | # Close handle that we can't use any more | ||||||
314 | 134336 | 183771 | close($opts{from_handle}) if exists $opts{from_handle}; | ||||
315 | 134336 | 146940 | close($opts{to_handle}) if exists $opts{to_handle}; | ||||
316 | 134336 | 2598123 | close($opts{error_to_handle}) if exists $opts{error_to_handle}; | ||||
317 | |||||||
318 | 134336 | 158014 | if ($opts{from_string}) { | ||||
319 | 4 4 4 | 12 12 28 | print { $from_string_pipe } ${$opts{from_string}}; | ||||
320 | 4 | 24 | close($from_string_pipe); | ||||
321 | } | ||||||
322 | 134336 | 152634 | if ($opts{to_string}) { | ||||
323 | 376 | 10016 | local $/ = undef; | ||||
324 | 376 376 | 454 176275755 | ${$opts{to_string}} = readline($to_string_pipe); | ||||
325 | } | ||||||
326 | 134336 | 758096 | if ($opts{error_to_string}) { | ||||
327 | 134237 | 2169757 | local $/ = undef; | ||||
328 | 134237 134237 | 96750 31880859186 | ${$opts{error_to_string}} = readline($error_to_string_pipe); | ||||
329 | } | ||||||
330 | 134336 | 658960 | if ($opts{wait_child}) { | ||||
331 | 134321 | 1221955 | my $cmdline = "@prog"; | ||||
332 | 134321 | 238501 | if ($opts{env}) { | ||||
333 | 3 3 | 3 32 | foreach (keys %{$opts{env}}) { | ||||
334 | 9 | 17 | $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline"; | ||||
335 | } | ||||||
336 | } | ||||||
337 | wait_child($pid, nocheck => $opts{nocheck}, | ||||||
338 | 134321 | 1414020 | timeout => $opts{timeout}, cmdline => $cmdline); | ||||
339 | 134320 | 4873394 | return 1; | ||||
340 | } | ||||||
341 | |||||||
342 | 15 | 1171 | return $pid; | ||||
343 | } | ||||||
344 | |||||||
345 | |||||||
346 - 375 | =item wait_child($pid, %opts) Takes as first argument the pid of the process to wait for. Remaining arguments are taken as a hash of options. Returns nothing. Fails if the child has been ended by a signal or if it exited non-zero. Options: =over 4 =item cmdline String to identify the child process in error messages. Defaults to "child process". =item nocheck If true do not check the return status of the child (and thus do not fail it has been killed or if it exited with a non-zero return code). =item timeout Set a maximum time to wait for the process, after that kill the process and fail with an error message. =back =cut | ||||||
376 | |||||||
377 | sub wait_child { | ||||||
378 | 134336 | 1 | 1518572 | my ($pid, %opts) = @_; | |||
379 | 134336 | 311883 | $opts{cmdline} //= g_('child process'); | ||||
380 | 134336 | 171701 | croak 'no PID set, cannot wait end of process' unless $pid; | ||||
381 | 134336 | 200831 | eval { | ||||
382 | 134336 1 | 2753026 73 | local $SIG{ALRM} = sub { die "alarm\n" }; | ||||
383 | 134336 | 236981 | alarm($opts{timeout}) if defined($opts{timeout}); | ||||
384 | 134336 | 143654171 | $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline}); | ||||
385 | 134335 | 750152 | alarm(0) if defined($opts{timeout}); | ||||
386 | }; | ||||||
387 | 134336 | 177467 | if ($@) { | ||||
388 | 1 | 16 | die $@ unless $@ eq "alarm\n"; | ||||
389 | 1 | 25 | kill 'TERM', $pid; | ||||
390 | error(P_("%s didn't complete in %d second", | ||||||
391 | "%s didn't complete in %d seconds", | ||||||
392 | $opts{timeout}), | ||||||
393 | 1 | 43 | $opts{cmdline}, $opts{timeout}); | ||||
394 | } | ||||||
395 | 134335 | 288769 | unless ($opts{nocheck}) { | ||||
396 | 17 | 106 | subprocerr($opts{cmdline}) if $?; | ||||
397 | } | ||||||
398 | } | ||||||
399 | |||||||
400 | 1; | ||||||
401 | |||||||
402 | =back | ||||||
403 | |||||||
404 - 420 | =head1 CHANGES =head2 Version 1.02 (dpkg 1.18.0) Change options: wait_child() now kills the process when reaching the 'timeout'. =head2 Version 1.01 (dpkg 1.17.11) New options: spawn() now accepts 'sig' and 'delete_sig'. =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =head1 SEE ALSO Dpkg, Dpkg::ErrorHandling |