summaryrefslogtreecommitdiff
path: root/scripts/Dpkg/IPC.pm
blob: ba2aca5f66c4faed6a7bc0b3e1d23d405fef0e5b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
# Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org>
# Copyright © 2008 Frank Lichtenheld <djpig@debian.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

package Dpkg::IPC;

use strict;
use warnings;

our $VERSION = '1.00';

use Dpkg::ErrorHandling;
use Dpkg::Gettext;

use base qw(Exporter);
our @EXPORT = qw(spawn wait_child);

=encoding utf8

=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 METHODS

=over 4

=item spawn

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.

=back

=cut

sub _sanity_check_opts {
    my (%opts) = @_;

    internerr('exec parameter is mandatory in spawn()')
	unless $opts{exec};

    my $to = my $error_to = my $from = 0;
    foreach (qw(file handle string pipe)) {
	$to++ if $opts{"to_$_"};
	$error_to++ if $opts{"error_to_$_"};
	$from++ if $opts{"from_$_"};
    }
    internerr('not more than one of to_* parameters is allowed')
	if $to > 1;
    internerr('not more than one of error_to_* parameters is allowed')
	if $error_to > 1;
    internerr('not more than one of from_* parameters is allowed')
	if $from > 1;

    foreach (qw(to_string error_to_string from_string)) {
	if (exists $opts{$_} and
	    (!ref($opts{$_}) or ref($opts{$_}) ne 'SCALAR')) {
	    internerr("parameter $_ must be a scalar reference");
	}
    }

    foreach (qw(to_pipe error_to_pipe from_pipe)) {
	if (exists $opts{$_} and
	    (!ref($opts{$_}) or (ref($opts{$_}) ne 'SCALAR' and
				 not $opts{$_}->isa('IO::Handle')))) {
	    internerr("parameter $_ must be a scalar reference or an IO::Handle object");
	}
    }

    if (exists $opts{timeout} and defined($opts{timeout}) and
        $opts{timeout} !~ /^\d+$/) {
	internerr('parameter timeout must be an integer');
    }

    if (exists $opts{env} and ref($opts{env}) ne 'HASH') {
	internerr('parameter env must be a hash reference');
    }

    if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') {
	internerr('parameter delete_env must be an array reference');
    }

    return %opts;
}

sub spawn {
    my (%opts) = _sanity_check_opts(@_);
    $opts{close_in_child} ||= [];
    my @prog;
    if (ref($opts{exec}) =~ /ARRAY/) {
	push @prog, @{$opts{exec}};
    } elsif (not ref($opts{exec})) {
	push @prog, $opts{exec};
    } else {
	internerr('invalid exec parameter in spawn()');
    }
    my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe);
    if ($opts{to_string}) {
	$opts{to_pipe} = \$to_string_pipe;
	$opts{wait_child} = 1;
    }
    if ($opts{error_to_string}) {
	$opts{error_to_pipe} = \$error_to_string_pipe;
	$opts{wait_child} = 1;
    }
    if ($opts{from_string}) {
	$opts{from_pipe} = \$from_string_pipe;
    }
    # Create pipes if needed
    my ($input_pipe, $output_pipe, $error_pipe);
    if ($opts{from_pipe}) {
	pipe($opts{from_handle}, $input_pipe) ||
		syserr(_g('pipe for %s'), "@prog");
	${$opts{from_pipe}} = $input_pipe;
	push @{$opts{close_in_child}}, $input_pipe;
    }
    if ($opts{to_pipe}) {
	pipe($output_pipe, $opts{to_handle}) ||
		syserr(_g('pipe for %s'), "@prog");
	${$opts{to_pipe}} = $output_pipe;
	push @{$opts{close_in_child}}, $output_pipe;
    }
    if ($opts{error_to_pipe}) {
	pipe($error_pipe, $opts{error_to_handle}) ||
		syserr(_g('pipe for %s'), "@prog");
	${$opts{error_to_pipe}} = $error_pipe;
	push @{$opts{close_in_child}}, $error_pipe;
    }
    # Fork and exec
    my $pid = fork();
    syserr(_g('cannot fork for %s'), "@prog") unless defined $pid;
    if (not $pid) {
	# Define environment variables
	if ($opts{env}) {
	    foreach (keys %{$opts{env}}) {
		$ENV{$_} = $opts{env}{$_};
	    }
	}
	if ($opts{delete_env}) {
	    delete $ENV{$_} foreach (@{$opts{delete_env}});
	}
	# Change the current directory
	if ($opts{chdir}) {
	    chdir($opts{chdir}) || syserr(_g('chdir to %s'), $opts{chdir});
	}
	# Redirect STDIN if needed
	if ($opts{from_file}) {
	    open(STDIN, '<', $opts{from_file}) ||
		syserr(_g('cannot open %s'), $opts{from_file});
	} elsif ($opts{from_handle}) {
	    open(STDIN, '<&', $opts{from_handle}) || syserr(_g('reopen stdin'));
	    close($opts{from_handle}); # has been duped, can be closed
	}
	# Redirect STDOUT if needed
	if ($opts{to_file}) {
	    open(STDOUT, '>', $opts{to_file}) ||
		syserr(_g('cannot write %s'), $opts{to_file});
	} elsif ($opts{to_handle}) {
	    open(STDOUT, '>&', $opts{to_handle}) || syserr(_g('reopen stdout'));
	    close($opts{to_handle}); # has been duped, can be closed
	}
	# Redirect STDERR if needed
	if ($opts{error_to_file}) {
	    open(STDERR, '>', $opts{error_to_file}) ||
		syserr(_g('cannot write %s'), $opts{error_to_file});
	} elsif ($opts{error_to_handle}) {
	    open(STDERR, '>&', $opts{error_to_handle}) || syserr(_g('reopen stdout'));
	    close($opts{error_to_handle}); # has been duped, can be closed
	}
	# Close some inherited filehandles
	close($_) foreach (@{$opts{close_in_child}});
	# Execute the program
	exec({ $prog[0] } @prog) or syserr(_g('unable to execute %s'), "@prog");
    }
    # Close handle that we can't use any more
    close($opts{from_handle}) if exists $opts{from_handle};
    close($opts{to_handle}) if exists $opts{to_handle};
    close($opts{error_to_handle}) if exists $opts{error_to_handle};

    if ($opts{from_string}) {
	print $from_string_pipe ${$opts{from_string}};
	close($from_string_pipe);
    }
    if ($opts{to_string}) {
	local $/ = undef;
	${$opts{to_string}} = readline($to_string_pipe);
    }
    if ($opts{error_to_string}) {
	local $/ = undef;
	${$opts{error_to_string}} = readline($error_to_string_pipe);
    }
    if ($opts{wait_child}) {
	my $cmdline = "@prog";
	if ($opts{env}) {
	    foreach (keys %{$opts{env}}) {
		$cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline";
	    }
	}
	wait_child($pid, nocheck => $opts{nocheck},
                   timeout => $opts{timeout}, cmdline => $cmdline);
	return 1;
    }

    return $pid;
}


=item wait_child

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 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 fail
with an error message.

=back

=cut

sub wait_child {
    my ($pid, %opts) = @_;
    $opts{cmdline} ||= _g('child process');
    internerr('no PID set, cannot wait end of process') unless $pid;
    eval {
        local $SIG{ALRM} = sub { die "alarm\n" };
        alarm($opts{timeout}) if defined($opts{timeout});
        $pid == waitpid($pid, 0) or syserr(_g('wait for %s'), $opts{cmdline});
        alarm(0) if defined($opts{timeout});
    };
    if ($@) {
        die $@ unless $@ eq "alarm\n";
        error(ngettext("%s didn't complete in %d second",
                       "%s didn't complete in %d seconds",
                       $opts{timeout}),
              $opts{cmdline}, $opts{timeout});
    }
    unless ($opts{nocheck}) {
	subprocerr($opts{cmdline}) if $?;
    }
}

1;
__END__

=back

=head1 AUTHORS

Written by Raphaël Hertzog <hertzog@debian.org> and
Frank Lichtenheld <djpig@debian.org>.

=head1 SEE ALSO

Dpkg, Dpkg::ErrorHandling