Commit | Line | Data |
---|---|---|
1479465f GJ |
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 | use strict; | |
21 | use warnings; | |
22 | ||
23 | our $VERSION = '1.02'; | |
24 | our @EXPORT = qw( | |
25 | spawn | |
26 | wait_child | |
27 | ); | |
28 | ||
29 | use Carp; | |
30 | use Exporter qw(import); | |
31 | ||
32 | use Dpkg::ErrorHandling; | |
33 | use Dpkg::Gettext; | |
34 | ||
35 | =encoding utf8 | |
36 | ||
37 | =head1 NAME | |
38 | ||
39 | Dpkg::IPC - helper functions for IPC | |
40 | ||
41 | =head1 DESCRIPTION | |
42 | ||
43 | Dpkg::IPC offers helper functions to allow you to execute | |
44 | other programs in an easy, yet flexible way, while hiding | |
45 | all the gory details of IPC (Inter-Process Communication) | |
46 | from you. | |
47 | ||
48 | =head1 FUNCTIONS | |
49 | ||
50 | =over 4 | |
51 | ||
52 | =item $pid = spawn(%opts) | |
53 | ||
54 | Creates a child process and executes another program in it. | |
55 | The arguments are interpreted as a hash of options, specifying | |
56 | how to handle the in and output of the program to execute. | |
57 | Returns the pid of the child process (unless the wait_child | |
58 | option was given). | |
59 | ||
60 | Any error will cause the function to exit with one of the | |
61 | Dpkg::ErrorHandling functions. | |
62 | ||
63 | Options: | |
64 | ||
65 | =over 4 | |
66 | ||
67 | =item exec | |
68 | ||
69 | Can be either a scalar, i.e. the name of the program to be | |
70 | executed, or an array reference, i.e. the name of the program | |
71 | plus additional arguments. Note that the program will never be | |
72 | executed via the shell, so you can't specify additional arguments | |
73 | in the scalar string and you can't use any shell facilities like | |
74 | globbing. | |
75 | ||
76 | Mandatory Option. | |
77 | ||
78 | =item from_file, to_file, error_to_file | |
79 | ||
80 | Filename as scalar. Standard input/output/error of the | |
81 | child process will be redirected to the file specified. | |
82 | ||
83 | =item from_handle, to_handle, error_to_handle | |
84 | ||
85 | Filehandle. Standard input/output/error of the child process will be | |
86 | dup'ed from the handle. | |
87 | ||
88 | =item from_pipe, to_pipe, error_to_pipe | |
89 | ||
90 | Scalar reference or object based on IO::Handle. A pipe will be opened for | |
91 | each of the two options and either the reading (C<to_pipe> and | |
92 | C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in | |
93 | the referenced scalar. Standard input/output/error of the child process | |
94 | will be dup'ed to the other ends of the pipes. | |
95 | ||
96 | =item from_string, to_string, error_to_string | |
97 | ||
98 | Scalar reference. Standard input/output/error of the child | |
99 | process will be redirected to the string given as reference. Note | |
100 | that it wouldn't be strictly necessary to use a scalar reference | |
101 | for C<from_string>, as the string is not modified in any way. This was | |
102 | chosen only for reasons of symmetry with C<to_string> and | |
103 | C<error_to_string>. C<to_string> and C<error_to_string> imply the | |
104 | C<wait_child> option. | |
105 | ||
106 | =item wait_child | |
107 | ||
108 | Scalar. If containing a true value, wait_child() will be called before | |
109 | returning. The return value of spawn() will be a true value, not the pid. | |
110 | ||
111 | =item nocheck | |
112 | ||
113 | Scalar. Option of the wait_child() call. | |
114 | ||
115 | =item timeout | |
116 | ||
117 | Scalar. Option of the wait_child() call. | |
118 | ||
119 | =item chdir | |
120 | ||
121 | Scalar. The child process will chdir in the indicated directory before | |
122 | calling exec. | |
123 | ||
124 | =item env | |
125 | ||
126 | Hash reference. The child process will populate %ENV with the items of the | |
127 | hash before calling exec. This allows exporting environment variables. | |
128 | ||
129 | =item delete_env | |
130 | ||
131 | Array reference. The child process will remove all environment variables | |
132 | listed in the array before calling exec. | |
133 | ||
134 | =item sig | |
135 | ||
136 | Hash reference. The child process will populate %SIG with the items of the | |
137 | hash before calling exec. This allows setting signal dispositions. | |
138 | ||
139 | =item delete_sig | |
140 | ||
141 | Array reference. The child process will reset all signals listed in the | |
142 | array to their default dispositions before calling exec. | |
143 | ||
144 | =back | |
145 | ||
146 | =cut | |
147 | ||
148 | sub _sanity_check_opts { | |
149 | my (%opts) = @_; | |
150 | ||
151 | croak 'exec parameter is mandatory in spawn()' | |
152 | unless $opts{exec}; | |
153 | ||
154 | my $to = my $error_to = my $from = 0; | |
155 | foreach my $thing (qw(file handle string pipe)) { | |
156 | $to++ if $opts{"to_$thing"}; | |
157 | $error_to++ if $opts{"error_to_$thing"}; | |
158 | $from++ if $opts{"from_$thing"}; | |
159 | } | |
160 | croak 'not more than one of to_* parameters is allowed' | |
161 | if $to > 1; | |
162 | croak 'not more than one of error_to_* parameters is allowed' | |
163 | if $error_to > 1; | |
164 | croak 'not more than one of from_* parameters is allowed' | |
165 | if $from > 1; | |
166 | ||
167 | foreach my $param (qw(to_string error_to_string from_string)) { | |
168 | if (exists $opts{$param} and | |
169 | (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) { | |
170 | croak "parameter $param must be a scalar reference"; | |
171 | } | |
172 | } | |
173 | ||
174 | foreach my $param (qw(to_pipe error_to_pipe from_pipe)) { | |
175 | 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 | croak "parameter $param must be a scalar reference or " . | |
179 | 'an IO::Handle object'; | |
180 | } | |
181 | } | |
182 | ||
183 | if (exists $opts{timeout} and defined($opts{timeout}) and | |
184 | $opts{timeout} !~ /^\d+$/) { | |
185 | croak 'parameter timeout must be an integer'; | |
186 | } | |
187 | ||
188 | if (exists $opts{env} and ref($opts{env}) ne 'HASH') { | |
189 | croak 'parameter env must be a hash reference'; | |
190 | } | |
191 | ||
192 | if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') { | |
193 | croak 'parameter delete_env must be an array reference'; | |
194 | } | |
195 | ||
196 | if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') { | |
197 | croak 'parameter sig must be a hash reference'; | |
198 | } | |
199 | ||
200 | if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') { | |
201 | croak 'parameter delete_sig must be an array reference'; | |
202 | } | |
203 | ||
204 | return %opts; | |
205 | } | |
206 | ||
207 | sub spawn { | |
208 | my (%opts) = @_; | |
209 | my @prog; | |
210 | ||
211 | _sanity_check_opts(%opts); | |
212 | $opts{close_in_child} //= []; | |
213 | if (ref($opts{exec}) =~ /ARRAY/) { | |
214 | push @prog, @{$opts{exec}}; | |
215 | } elsif (not ref($opts{exec})) { | |
216 | push @prog, $opts{exec}; | |
217 | } else { | |
218 | croak 'invalid exec parameter in spawn()'; | |
219 | } | |
220 | my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe); | |
221 | if ($opts{to_string}) { | |
222 | $opts{to_pipe} = \$to_string_pipe; | |
223 | $opts{wait_child} = 1; | |
224 | } | |
225 | if ($opts{error_to_string}) { | |
226 | $opts{error_to_pipe} = \$error_to_string_pipe; | |
227 | $opts{wait_child} = 1; | |
228 | } | |
229 | if ($opts{from_string}) { | |
230 | $opts{from_pipe} = \$from_string_pipe; | |
231 | } | |
232 | # Create pipes if needed | |
233 | my ($input_pipe, $output_pipe, $error_pipe); | |
234 | if ($opts{from_pipe}) { | |
235 | pipe($opts{from_handle}, $input_pipe) | |
236 | or syserr(g_('pipe for %s'), "@prog"); | |
237 | ${$opts{from_pipe}} = $input_pipe; | |
238 | push @{$opts{close_in_child}}, $input_pipe; | |
239 | } | |
240 | if ($opts{to_pipe}) { | |
241 | pipe($output_pipe, $opts{to_handle}) | |
242 | or syserr(g_('pipe for %s'), "@prog"); | |
243 | ${$opts{to_pipe}} = $output_pipe; | |
244 | push @{$opts{close_in_child}}, $output_pipe; | |
245 | } | |
246 | if ($opts{error_to_pipe}) { | |
247 | pipe($error_pipe, $opts{error_to_handle}) | |
248 | or syserr(g_('pipe for %s'), "@prog"); | |
249 | ${$opts{error_to_pipe}} = $error_pipe; | |
250 | push @{$opts{close_in_child}}, $error_pipe; | |
251 | } | |
252 | # Fork and exec | |
253 | my $pid = fork(); | |
254 | syserr(g_('cannot fork for %s'), "@prog") unless defined $pid; | |
255 | if (not $pid) { | |
256 | # Define environment variables | |
257 | if ($opts{env}) { | |
258 | foreach (keys %{$opts{env}}) { | |
259 | $ENV{$_} = $opts{env}{$_}; | |
260 | } | |
261 | } | |
262 | if ($opts{delete_env}) { | |
263 | delete $ENV{$_} foreach (@{$opts{delete_env}}); | |
264 | } | |
265 | # Define signal dispositions. | |
266 | if ($opts{sig}) { | |
267 | foreach (keys %{$opts{sig}}) { | |
268 | $SIG{$_} = $opts{sig}{$_}; | |
269 | } | |
270 | } | |
271 | if ($opts{delete_sig}) { | |
272 | delete $SIG{$_} foreach (@{$opts{delete_sig}}); | |
273 | } | |
274 | # Change the current directory | |
275 | if ($opts{chdir}) { | |
276 | chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir}); | |
277 | } | |
278 | # Redirect STDIN if needed | |
279 | if ($opts{from_file}) { | |
280 | open(STDIN, '<', $opts{from_file}) | |
281 | or syserr(g_('cannot open %s'), $opts{from_file}); | |
282 | } elsif ($opts{from_handle}) { | |
283 | open(STDIN, '<&', $opts{from_handle}) | |
284 | or syserr(g_('reopen stdin')); | |
285 | # has been duped, can be closed | |
286 | push @{$opts{close_in_child}}, $opts{from_handle}; | |
287 | } | |
288 | # Redirect STDOUT if needed | |
289 | if ($opts{to_file}) { | |
290 | open(STDOUT, '>', $opts{to_file}) | |
291 | or syserr(g_('cannot write %s'), $opts{to_file}); | |
292 | } elsif ($opts{to_handle}) { | |
293 | open(STDOUT, '>&', $opts{to_handle}) | |
294 | or syserr(g_('reopen stdout')); | |
295 | # has been duped, can be closed | |
296 | push @{$opts{close_in_child}}, $opts{to_handle}; | |
297 | } | |
298 | # Redirect STDERR if needed | |
299 | if ($opts{error_to_file}) { | |
300 | open(STDERR, '>', $opts{error_to_file}) | |
301 | or syserr(g_('cannot write %s'), $opts{error_to_file}); | |
302 | } elsif ($opts{error_to_handle}) { | |
303 | open(STDERR, '>&', $opts{error_to_handle}) | |
304 | or syserr(g_('reopen stdout')); | |
305 | # has been duped, can be closed | |
306 | push @{$opts{close_in_child}}, $opts{error_to_handle}; | |
307 | } | |
308 | # Close some inherited filehandles | |
309 | close($_) foreach (@{$opts{close_in_child}}); | |
310 | # Execute the program | |
311 | exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog"); | |
312 | } | |
313 | # Close handle that we can't use any more | |
314 | close($opts{from_handle}) if exists $opts{from_handle}; | |
315 | close($opts{to_handle}) if exists $opts{to_handle}; | |
316 | close($opts{error_to_handle}) if exists $opts{error_to_handle}; | |
317 | ||
318 | if ($opts{from_string}) { | |
319 | print { $from_string_pipe } ${$opts{from_string}}; | |
320 | close($from_string_pipe); | |
321 | } | |
322 | if ($opts{to_string}) { | |
323 | local $/ = undef; | |
324 | ${$opts{to_string}} = readline($to_string_pipe); | |
325 | } | |
326 | if ($opts{error_to_string}) { | |
327 | local $/ = undef; | |
328 | ${$opts{error_to_string}} = readline($error_to_string_pipe); | |
329 | } | |
330 | if ($opts{wait_child}) { | |
331 | my $cmdline = "@prog"; | |
332 | if ($opts{env}) { | |
333 | foreach (keys %{$opts{env}}) { | |
334 | $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline"; | |
335 | } | |
336 | } | |
337 | wait_child($pid, nocheck => $opts{nocheck}, | |
338 | timeout => $opts{timeout}, cmdline => $cmdline); | |
339 | return 1; | |
340 | } | |
341 | ||
342 | return $pid; | |
343 | } | |
344 | ||
345 | ||
346 | =item wait_child($pid, %opts) | |
347 | ||
348 | Takes as first argument the pid of the process to wait for. | |
349 | Remaining arguments are taken as a hash of options. Returns | |
350 | nothing. Fails if the child has been ended by a signal or | |
351 | if it exited non-zero. | |
352 | ||
353 | Options: | |
354 | ||
355 | =over 4 | |
356 | ||
357 | =item cmdline | |
358 | ||
359 | String to identify the child process in error messages. | |
360 | Defaults to "child process". | |
361 | ||
362 | =item nocheck | |
363 | ||
364 | If true do not check the return status of the child (and thus | |
365 | do not fail it has been killed or if it exited with a | |
366 | non-zero return code). | |
367 | ||
368 | =item timeout | |
369 | ||
370 | Set a maximum time to wait for the process, after that kill the process and | |
371 | fail with an error message. | |
372 | ||
373 | =back | |
374 | ||
375 | =cut | |
376 | ||
377 | sub wait_child { | |
378 | my ($pid, %opts) = @_; | |
379 | $opts{cmdline} //= g_('child process'); | |
380 | croak 'no PID set, cannot wait end of process' unless $pid; | |
381 | eval { | |
382 | local $SIG{ALRM} = sub { die "alarm\n" }; | |
383 | alarm($opts{timeout}) if defined($opts{timeout}); | |
384 | $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline}); | |
385 | alarm(0) if defined($opts{timeout}); | |
386 | }; | |
387 | if ($@) { | |
388 | die $@ unless $@ eq "alarm\n"; | |
389 | 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 | $opts{cmdline}, $opts{timeout}); | |
394 | } | |
395 | unless ($opts{nocheck}) { | |
396 | subprocerr($opts{cmdline}) if $?; | |
397 | } | |
398 | } | |
399 | ||
400 | 1; | |
401 | __END__ | |
402 | ||
403 | =back | |
404 | ||
405 | =head1 CHANGES | |
406 | ||
407 | =head2 Version 1.02 (dpkg 1.18.0) | |
408 | ||
409 | Change options: wait_child() now kills the process when reaching the 'timeout'. | |
410 | ||
411 | =head2 Version 1.01 (dpkg 1.17.11) | |
412 | ||
413 | New options: spawn() now accepts 'sig' and 'delete_sig'. | |
414 | ||
415 | =head2 Version 1.00 (dpkg 1.15.6) | |
416 | ||
417 | Mark the module as public. | |
418 | ||
419 | =head1 SEE ALSO | |
420 | ||
421 | Dpkg, Dpkg::ErrorHandling |