419 lines
12 KiB
Perl
419 lines
12 KiB
Perl
# Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org>
|
|
# Copyright © 2008 Frank Lichtenheld <djpig@debian.org>
|
|
# Copyright © 2008-2010, 2012-2015 Guillem Jover <guillem@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 <https://www.gnu.org/licenses/>.
|
|
|
|
=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.
|
|
|
|
=cut
|
|
|
|
package Dpkg::IPC 1.02;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
our @EXPORT = qw(
|
|
spawn
|
|
wait_child
|
|
);
|
|
|
|
use Carp;
|
|
use Exporter qw(import);
|
|
|
|
use Dpkg::ErrorHandling;
|
|
use Dpkg::Gettext;
|
|
|
|
=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 B<exec> (required)
|
|
|
|
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.
|
|
|
|
=item B<from_file>, B<to_file>, B<error_to_file>
|
|
|
|
Filename as scalar. Standard input/output/error of the
|
|
child process will be redirected to the file specified.
|
|
|
|
=item B<from_handle>, B<to_handle>, B<error_to_handle>
|
|
|
|
Filehandle. Standard input/output/error of the child process will be
|
|
dup'ed from the handle.
|
|
|
|
=item B<from_pipe>, B<to_pipe>, B<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 B<from_string>, B<to_string>, B<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 B<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 B<nocheck>
|
|
|
|
Scalar. Option of the wait_child() call.
|
|
|
|
=item B<timeout>
|
|
|
|
Scalar. Option of the wait_child() call.
|
|
|
|
=item B<chdir>
|
|
|
|
Scalar. The child process will chdir in the indicated directory before
|
|
calling exec.
|
|
|
|
=item B<env>
|
|
|
|
Hash reference. The child process will populate %ENV with the items of the
|
|
hash before calling exec. This allows exporting environment variables.
|
|
|
|
=item B<delete_env>
|
|
|
|
Array reference. The child process will remove all environment variables
|
|
listed in the array before calling exec.
|
|
|
|
=item B<sig>
|
|
|
|
Hash reference. The child process will populate %SIG with the items of the
|
|
hash before calling exec. This allows setting signal dispositions.
|
|
|
|
=item B<delete_sig>
|
|
|
|
Array reference. The child process will reset all signals listed in the
|
|
array to their default dispositions before calling exec.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub _check_opts {
|
|
my (%opts) = @_;
|
|
|
|
croak 'exec parameter is mandatory in spawn()'
|
|
unless $opts{exec};
|
|
|
|
my $to = my $error_to = my $from = 0;
|
|
foreach my $thing (qw(file handle string pipe)) {
|
|
$to++ if $opts{"to_$thing"};
|
|
$error_to++ if $opts{"error_to_$thing"};
|
|
$from++ if $opts{"from_$thing"};
|
|
}
|
|
croak 'not more than one of to_* parameters is allowed'
|
|
if $to > 1;
|
|
croak 'not more than one of error_to_* parameters is allowed'
|
|
if $error_to > 1;
|
|
croak 'not more than one of from_* parameters is allowed'
|
|
if $from > 1;
|
|
|
|
foreach my $param (qw(to_string error_to_string from_string)) {
|
|
if (exists $opts{$param} and
|
|
(not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) {
|
|
croak "parameter $param must be a scalar reference";
|
|
}
|
|
}
|
|
|
|
foreach my $param (qw(to_pipe error_to_pipe from_pipe)) {
|
|
if (exists $opts{$param} and
|
|
(not ref $opts{$param} or (ref $opts{$param} ne 'SCALAR' and
|
|
not $opts{$param}->isa('IO::Handle')))) {
|
|
croak "parameter $param must be a scalar reference or " .
|
|
'an IO::Handle object';
|
|
}
|
|
}
|
|
|
|
if (exists $opts{timeout} and defined($opts{timeout}) and
|
|
$opts{timeout} !~ /^\d+$/) {
|
|
croak 'parameter timeout must be an integer';
|
|
}
|
|
|
|
if (exists $opts{env} and ref($opts{env}) ne 'HASH') {
|
|
croak 'parameter env must be a hash reference';
|
|
}
|
|
|
|
if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') {
|
|
croak 'parameter delete_env must be an array reference';
|
|
}
|
|
|
|
if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') {
|
|
croak 'parameter sig must be a hash reference';
|
|
}
|
|
|
|
if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') {
|
|
croak 'parameter delete_sig must be an array reference';
|
|
}
|
|
|
|
return %opts;
|
|
}
|
|
|
|
sub spawn {
|
|
my (%opts) = @_;
|
|
my @prog;
|
|
|
|
_check_opts(%opts);
|
|
$opts{close_in_child} //= [];
|
|
if (ref($opts{exec}) =~ /ARRAY/) {
|
|
push @prog, @{$opts{exec}};
|
|
} elsif (not ref($opts{exec})) {
|
|
push @prog, $opts{exec};
|
|
} else {
|
|
croak '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)
|
|
or 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})
|
|
or 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})
|
|
or 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}});
|
|
}
|
|
# Define signal dispositions.
|
|
if ($opts{sig}) {
|
|
foreach (keys %{$opts{sig}}) {
|
|
$SIG{$_} = $opts{sig}{$_};
|
|
}
|
|
}
|
|
if ($opts{delete_sig}) {
|
|
delete $SIG{$_} foreach (@{$opts{delete_sig}});
|
|
}
|
|
# Change the current directory
|
|
if ($opts{chdir}) {
|
|
chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir});
|
|
}
|
|
# Redirect STDIN if needed
|
|
if ($opts{from_file}) {
|
|
open(STDIN, '<', $opts{from_file})
|
|
or syserr(g_('cannot open %s'), $opts{from_file});
|
|
} elsif ($opts{from_handle}) {
|
|
open(STDIN, '<&', $opts{from_handle})
|
|
or syserr(g_('reopen stdin'));
|
|
# has been duped, can be closed
|
|
push @{$opts{close_in_child}}, $opts{from_handle};
|
|
}
|
|
# Redirect STDOUT if needed
|
|
if ($opts{to_file}) {
|
|
open(STDOUT, '>', $opts{to_file})
|
|
or syserr(g_('cannot write %s'), $opts{to_file});
|
|
} elsif ($opts{to_handle}) {
|
|
open(STDOUT, '>&', $opts{to_handle})
|
|
or syserr(g_('reopen stdout'));
|
|
# has been duped, can be closed
|
|
push @{$opts{close_in_child}}, $opts{to_handle};
|
|
}
|
|
# Redirect STDERR if needed
|
|
if ($opts{error_to_file}) {
|
|
open(STDERR, '>', $opts{error_to_file})
|
|
or syserr(g_('cannot write %s'), $opts{error_to_file});
|
|
} elsif ($opts{error_to_handle}) {
|
|
open(STDERR, '>&', $opts{error_to_handle})
|
|
or syserr(g_('reopen stdout'));
|
|
# has been duped, can be closed
|
|
push @{$opts{close_in_child}}, $opts{error_to_handle};
|
|
}
|
|
# 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($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
|
|
|
|
sub wait_child {
|
|
my ($pid, %opts) = @_;
|
|
$opts{cmdline} //= g_('child process');
|
|
croak '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";
|
|
kill 'TERM', $pid;
|
|
error(P_("%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;
|
|
|
|
=back
|
|
|
|
=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>.
|