File Coverage

File:Dpkg/IPC.pm
Coverage:81.9%

linestmtbrancondsubpodtimecode
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
18package Dpkg::IPC;
19
20
622
622
622
1767
560
7889
use strict;
21
622
622
622
1211
562
18758
use warnings;
22
23our $VERSION = '1.02';
24our @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
148sub _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
207sub 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
377sub 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
4001;
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