chiark - git - mdw - dpkg/blob - scripts/Dpkg/IPC.pm

   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