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
18=encoding utf8
19
20 - 31
=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.

=cut
32
33package Dpkg::IPC 1.02;
34
35
1959
1959
1959
5239
1450
29572
use strict;
36
1959
1959
1959
3310
1401
64128
use warnings;
37
38our @EXPORT = qw(
39    spawn
40    wait_child
41);
42
43
1959
1959
1959
4011
1134
71832
use Carp;
44
1959
1959
1959
4988
1620
22888
use Exporter qw(import);
45
46
1959
1959
1959
5212
1483
67090
use Dpkg::ErrorHandling;
47
1959
1959
1959
5612
1386
2253830
use Dpkg::Gettext;
48
49 - 147
=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
L<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 L<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
148
149sub _check_opts {
150
409494
715055
    my (%opts) = @_;
151
152    croak 'exec parameter is mandatory in spawn()'
153
409494
776438
        unless $opts{exec};
154
155
409494
459081
    my $to = my $error_to = my $from = 0;
156
409494
643035
    foreach my $thing (qw(file handle string pipe)) {
157
1637976
1756453
        $to++ if $opts{"to_$thing"};
158
1637976
1705025
        $error_to++ if $opts{"error_to_$thing"};
159
1637976
1832440
        $from++ if $opts{"from_$thing"};
160    }
161
409494
493976
    croak 'not more than one of to_* parameters is allowed'
162        if $to > 1;
163
409494
473315
    croak 'not more than one of error_to_* parameters is allowed'
164        if $error_to > 1;
165
409494
491350
    croak 'not more than one of from_* parameters is allowed'
166        if $from > 1;
167
168
409494
420259
    foreach my $param (qw(to_string error_to_string from_string)) {
169
1228482
3870419
        if (exists $opts{$param} and
170            (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) {
171
0
0
            croak "parameter $param must be a scalar reference";
172        }
173    }
174
175
409494
413749
    foreach my $param (qw(to_pipe error_to_pipe from_pipe)) {
176
1228482
1264403
        if (exists $opts{$param} and
177            (not ref $opts{$param} or (ref $opts{$param} ne 'SCALAR' and
178             not $opts{$param}->isa('IO::Handle')))) {
179
0
0
            croak "parameter $param must be a scalar reference or " .
180                  'an IO::Handle object';
181        }
182    }
183
184
409494
1056143
    if (exists $opts{timeout} and defined($opts{timeout}) and
185        $opts{timeout} !~ /^\d+$/) {
186
0
0
        croak 'parameter timeout must be an integer';
187    }
188
189
409494
573891
    if (exists $opts{env} and ref($opts{env}) ne 'HASH') {
190
0
0
        croak 'parameter env must be a hash reference';
191    }
192
193
409494
601003
    if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') {
194
0
0
        croak 'parameter delete_env must be an array reference';
195    }
196
197
409494
617144
    if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') {
198
0
0
        croak 'parameter sig must be a hash reference';
199    }
200
201
409494
612119
    if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') {
202
0
0
        croak 'parameter delete_sig must be an array reference';
203    }
204
205
409494
555803
    return %opts;
206}
207
208sub spawn {
209
409494
1
1116483
    my (%opts) = @_;
210
409494
391966
    my @prog;
211
212
409494
1020165
    _check_opts(%opts);
213
409494
1895841
    $opts{close_in_child} //= [];
214
409494
1569921
    if (ref($opts{exec}) =~ /ARRAY/) {
215
409458
409458
327319
734022
        push @prog, @{$opts{exec}};
216    } elsif (not ref($opts{exec})) {
217
36
41
        push @prog, $opts{exec};
218    } else {
219
0
0
        croak 'invalid exec parameter in spawn()';
220    }
221
409494
405680
    my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe);
222
409494
607258
    if ($opts{to_string}) {
223
3972
5557
        $opts{to_pipe} = \$to_string_pipe;
224
3972
4832
        $opts{wait_child} = 1;
225    }
226
409494
548280
    if ($opts{error_to_string}) {
227
409080
543831
        $opts{error_to_pipe} = \$error_to_string_pipe;
228
409080
413448
        $opts{wait_child} = 1;
229    }
230
409494
469536
    if ($opts{from_string}) {
231
15
15
        $opts{from_pipe} = \$from_string_pipe;
232    }
233    # Create pipes if needed
234
409494
322590
    my ($input_pipe, $output_pipe, $error_pipe);
235
409494
525297
    if ($opts{from_pipe}) {
236
54
1026
        pipe($opts{from_handle}, $input_pipe)
237            or syserr(g_('pipe for %s'), "@prog");
238
54
54
44
71
        ${$opts{from_pipe}} = $input_pipe;
239
54
54
38
59
        push @{$opts{close_in_child}}, $input_pipe;
240    }
241
409494
564454
    if ($opts{to_pipe}) {
242        pipe($output_pipe, $opts{to_handle})
243
3999
90774
            or syserr(g_('pipe for %s'), "@prog");
244
3999
3999
4261
5576
        ${$opts{to_pipe}} = $output_pipe;
245
3999
3999
4281
5968
        push @{$opts{close_in_child}}, $output_pipe;
246    }
247
409494
448683
    if ($opts{error_to_pipe}) {
248        pipe($error_pipe, $opts{error_to_handle})
249
409080
9176662
            or syserr(g_('pipe for %s'), "@prog");
250
409080
409080
608084
803245
        ${$opts{error_to_pipe}} = $error_pipe;
251
409080
409080
511573
918659
        push @{$opts{close_in_child}}, $error_pipe;
252    }
253    # Fork and exec
254
409494
300998257
    my $pid = fork();
255
409494
5267272
    syserr(g_('cannot fork for %s'), "@prog") unless defined $pid;
256
409494
629403
    if (not $pid) {
257        # Define environment variables
258
1872
64750
        if ($opts{env}) {
259
6
6
33
102
            foreach (keys %{$opts{env}}) {
260
12
328
                $ENV{$_} = $opts{env}{$_};
261            }
262        }
263
1872
26950
        if ($opts{delete_env}) {
264
9
9
17
148
            delete $ENV{$_} foreach (@{$opts{delete_env}});
265        }
266        # Define signal dispositions.
267
1872
21647
        if ($opts{sig}) {
268
0
0
0
0
            foreach (keys %{$opts{sig}}) {
269
0
0
                $SIG{$_} = $opts{sig}{$_};
270            }
271        }
272
1872
14164
        if ($opts{delete_sig}) {
273
0
0
0
0
            delete $SIG{$_} foreach (@{$opts{delete_sig}});
274        }
275        # Change the current directory
276
1872
10315
        if ($opts{chdir}) {
277
9
132
            chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir});
278        }
279        # Redirect STDIN if needed
280
1872
18329
        if ($opts{from_file}) {
281            open(STDIN, '<', $opts{from_file})
282
114
9476
                or syserr(g_('cannot open %s'), $opts{from_file});
283        } elsif ($opts{from_handle}) {
284            open(STDIN, '<&', $opts{from_handle})
285
27
1778
                or syserr(g_('reopen stdin'));
286            # has been duped, can be closed
287
27
27
59
184
            push @{$opts{close_in_child}}, $opts{from_handle};
288        }
289        # Redirect STDOUT if needed
290
1872
21166
        if ($opts{to_file}) {
291            open(STDOUT, '>', $opts{to_file})
292
114
4635
                or syserr(g_('cannot write %s'), $opts{to_file});
293        } elsif ($opts{to_handle}) {
294            open(STDOUT, '>&', $opts{to_handle})
295
141
8514
                or syserr(g_('reopen stdout'));
296            # has been duped, can be closed
297
141
141
1026
955
            push @{$opts{close_in_child}}, $opts{to_handle};
298        }
299        # Redirect STDERR if needed
300
1872
20811
        if ($opts{error_to_file}) {
301            open(STDERR, '>', $opts{error_to_file})
302
12
201
                or syserr(g_('cannot write %s'), $opts{error_to_file});
303        } elsif ($opts{error_to_handle}) {
304            open(STDERR, '>&', $opts{error_to_handle})
305
1791
119042
                or syserr(g_('reopen stdout'));
306            # has been duped, can be closed
307
1791
1791
4994
10785
            push @{$opts{close_in_child}}, $opts{error_to_handle};
308        }
309        # Close some inherited filehandles
310
1872
1872
5777
19334
        close($_) foreach (@{$opts{close_in_child}});
311        # Execute the program
312
1872
1872
10295
0
        exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog");
313    }
314    # Close handle that we can't use any more
315
407622
688838
    close($opts{from_handle}) if exists $opts{from_handle};
316
407622
651073
    close($opts{to_handle}) if exists $opts{to_handle};
317
407622
6620653
    close($opts{error_to_handle}) if exists $opts{error_to_handle};
318
319
407622
626601
    if ($opts{from_string}) {
320
12
12
12
28
44
60
        print { $from_string_pipe } ${$opts{from_string}};
321
12
44
        close($from_string_pipe);
322    }
323
407622
609711
    if ($opts{to_string}) {
324
3858
87319
        local $/ = undef;
325
3858
3858
4034
3141084635
        ${$opts{to_string}} = readline($to_string_pipe);
326    }
327
407622
2211903
    if ($opts{error_to_string}) {
328
407289
7030164
        local $/ = undef;
329
407289
407289
322147
146436163344
        ${$opts{error_to_string}} = readline($error_to_string_pipe);
330    }
331
407622
2673414
    if ($opts{wait_child}) {
332
407577
3281297
        my $cmdline = "@prog";
333
407577
931150
        if ($opts{env}) {
334
9
9
13
51
            foreach (keys %{$opts{env}}) {
335
18
42
                $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline";
336            }
337        }
338        wait_child($pid, nocheck => $opts{nocheck},
339
407577
3837724
                   timeout => $opts{timeout}, cmdline => $cmdline);
340
407574
15202778
        return 1;
341    }
342
343
45
2944
    return $pid;
344}
345
346
347 - 376
=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
377
378sub wait_child {
379
407622
1
4154963
    my ($pid, %opts) = @_;
380
407622
953736
    $opts{cmdline} //= g_('child process');
381
407622
519247
    croak 'no PID set, cannot wait end of process' unless $pid;
382
407622
601722
    eval {
383
407622
3
7964465
164
        local $SIG{ALRM} = sub { die "alarm\n" };
384
407622
859953
        alarm($opts{timeout}) if defined($opts{timeout});
385
407622
271063224
        $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline});
386
407619
2113347
        alarm(0) if defined($opts{timeout});
387    };
388
407622
645349
    if ($@) {
389
3
57
        die $@ unless $@ eq "alarm\n";
390
3
64
        kill 'TERM', $pid;
391        error(P_("%s didn't complete in %d second",
392                 "%s didn't complete in %d seconds",
393                 $opts{timeout}),
394
3
77
              $opts{cmdline}, $opts{timeout});
395    }
396
407619
1214660
    unless ($opts{nocheck}) {
397
51
343
        subprocerr($opts{cmdline}) if $?;
398    }
399}
400
4011;
402
403=back
404
405 - 421
=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

L<Dpkg>, L<Dpkg::ErrorHandling>.