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 =encoding utf8
  19
  20 =head1 NAME
  21
  22 Dpkg::IPC - helper functions for IPC
  23
  24 =head1 DESCRIPTION
  25
  26 Dpkg::IPC offers helper functions to allow you to execute
  27 other programs in an easy, yet flexible way, while hiding
  28 all the gory details of IPC (Inter-Process Communication)
  29 from you.
  30
  31 =cut
  32
  33 package Dpkg::IPC 1.02;
  34
  35 use strict;
  36 use warnings;
  37
  38 our @EXPORT = qw(
  39     spawn
  40     wait_child
  41 );
  42
  43 use Carp;
  44 use Exporter qw(import);
  45
  46 use Dpkg::ErrorHandling;
  47 use Dpkg::Gettext;
  48
  49 =head1 FUNCTIONS
  50
  51 =over 4
  52
  53 =item $pid = spawn(%opts)
  54
  55 Creates a child process and executes another program in it.
  56 The arguments are interpreted as a hash of options, specifying
  57 how to handle the in and output of the program to execute.
  58 Returns the pid of the child process (unless the wait_child
  59 option was given).
  60
  61 Any error will cause the function to exit with one of the
  62 L<Dpkg::ErrorHandling> functions.
  63
  64 Options:
  65
  66 =over 4
  67
  68 =item B<exec> (required)
  69
  70 Can be either a scalar, i.e. the name of the program to be
  71 executed, or an array reference, i.e. the name of the program
  72 plus additional arguments. Note that the program will never be
  73 executed via the shell, so you can't specify additional arguments
  74 in the scalar string and you can't use any shell facilities like
  75 globbing.
  76
  77 =item B<from_file>, B<to_file>, B<error_to_file>
  78
  79 Filename as scalar. Standard input/output/error of the
  80 child process will be redirected to the file specified.
  81
  82 =item B<from_handle>, B<to_handle>, B<error_to_handle>
  83
  84 Filehandle. Standard input/output/error of the child process will be
  85 dup'ed from the handle.
  86
  87 =item B<from_pipe>, B<to_pipe>, B<error_to_pipe>
  88
  89 Scalar reference or object based on L<IO::Handle>. A pipe will be opened for
  90 each of the two options and either the reading (C<to_pipe> and
  91 C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in
  92 the referenced scalar. Standard input/output/error of the child process
  93 will be dup'ed to the other ends of the pipes.
  94
  95 =item B<from_string>, B<to_string>, B<error_to_string>
  96
  97 Scalar reference. Standard input/output/error of the child
  98 process will be redirected to the string given as reference. Note
  99 that it wouldn't be strictly necessary to use a scalar reference
 100 for C<from_string>, as the string is not modified in any way. This was
 101 chosen only for reasons of symmetry with C<to_string> and
 102 C<error_to_string>. C<to_string> and C<error_to_string> imply the
 103 C<wait_child> option.
 104
 105 =item B<wait_child>
 106
 107 Scalar. If containing a true value, wait_child() will be called before
 108 returning. The return value of spawn() will be a true value, not the pid.
 109
 110 =item B<nocheck>
 111
 112 Scalar. Option of the wait_child() call.
 113
 114 =item B<timeout>
 115
 116 Scalar. Option of the wait_child() call.
 117
 118 =item B<chdir>
 119
 120 Scalar. The child process will chdir in the indicated directory before
 121 calling exec.
 122
 123 =item B<env>
 124
 125 Hash reference. The child process will populate %ENV with the items of the
 126 hash before calling exec. This allows exporting environment variables.
 127
 128 =item B<delete_env>
 129
 130 Array reference. The child process will remove all environment variables
 131 listed in the array before calling exec.
 132
 133 =item B<sig>
 134
 135 Hash reference. The child process will populate %SIG with the items of the
 136 hash before calling exec. This allows setting signal dispositions.
 137
 138 =item B<delete_sig>
 139
 140 Array reference. The child process will reset all signals listed in the
 141 array to their default dispositions before calling exec.
 142
 143 =back
 144
 145 =cut
 146
 147 sub _check_opts {
 148     my (%opts) = @_;
 149
 150     croak 'exec parameter is mandatory in spawn()'
 151         unless $opts{exec};
 152
 153     my $to = my $error_to = my $from = 0;
 154     foreach my $thing (qw(file handle string pipe)) {
 155         $to++ if $opts{"to_$thing"};
 156         $error_to++ if $opts{"error_to_$thing"};
 157         $from++ if $opts{"from_$thing"};
 158     }
 159     croak 'not more than one of to_* parameters is allowed'
 160         if $to > 1;
 161     croak 'not more than one of error_to_* parameters is allowed'
 162         if $error_to > 1;
 163     croak 'not more than one of from_* parameters is allowed'
 164         if $from > 1;
 165
 166     foreach my $param (qw(to_string error_to_string from_string)) {
 167         if (exists $opts{$param} and
 168             (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) {
 169             croak "parameter $param must be a scalar reference";
 170         }
 171     }
 172
 173     foreach my $param (qw(to_pipe error_to_pipe from_pipe)) {
 174         if (exists $opts{$param} and
 175             (not ref $opts{$param} or (ref $opts{$param} ne 'SCALAR' and
 176              not $opts{$param}->isa('IO::Handle')))) {
 177             croak "parameter $param must be a scalar reference or " .
 178                   'an IO::Handle object';
 179         }
 180     }
 181
 182     if (exists $opts{timeout} and defined($opts{timeout}) and
 183         $opts{timeout} !~ /^\d+$/) {
 184         croak 'parameter timeout must be an integer';
 185     }
 186
 187     if (exists $opts{env} and ref($opts{env}) ne 'HASH') {
 188         croak 'parameter env must be a hash reference';
 189     }
 190
 191     if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') {
 192         croak 'parameter delete_env must be an array reference';
 193     }
 194
 195     if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') {
 196         croak 'parameter sig must be a hash reference';
 197     }
 198
 199     if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') {
 200         croak 'parameter delete_sig must be an array reference';
 201     }
 202
 203     return %opts;
 204 }
 205
 206 sub spawn {
 207     my (%opts) = @_;
 208     my @prog;
 209
 210     _check_opts(%opts);
 211     $opts{close_in_child} //= [];
 212     if (ref($opts{exec}) =~ /ARRAY/) {
 213         push @prog, @{$opts{exec}};
 214     } elsif (not ref($opts{exec})) {
 215         push @prog, $opts{exec};
 216     } else {
 217         croak 'invalid exec parameter in spawn()';
 218     }
 219     my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe);
 220     if ($opts{to_string}) {
 221         $opts{to_pipe} = \$to_string_pipe;
 222         $opts{wait_child} = 1;
 223     }
 224     if ($opts{error_to_string}) {
 225         $opts{error_to_pipe} = \$error_to_string_pipe;
 226         $opts{wait_child} = 1;
 227     }
 228     if ($opts{from_string}) {
 229         $opts{from_pipe} = \$from_string_pipe;
 230     }
 231     # Create pipes if needed
 232     my ($input_pipe, $output_pipe, $error_pipe);
 233     if ($opts{from_pipe}) {
 234         pipe($opts{from_handle}, $input_pipe)
 235             or syserr(g_('pipe for %s'), "@prog");
 236         ${$opts{from_pipe}} = $input_pipe;
 237         push @{$opts{close_in_child}}, $input_pipe;
 238     }
 239     if ($opts{to_pipe}) {
 240         pipe($output_pipe, $opts{to_handle})
 241             or syserr(g_('pipe for %s'), "@prog");
 242         ${$opts{to_pipe}} = $output_pipe;
 243         push @{$opts{close_in_child}}, $output_pipe;
 244     }
 245     if ($opts{error_to_pipe}) {
 246         pipe($error_pipe, $opts{error_to_handle})
 247             or syserr(g_('pipe for %s'), "@prog");
 248         ${$opts{error_to_pipe}} = $error_pipe;
 249         push @{$opts{close_in_child}}, $error_pipe;
 250     }
 251     # Fork and exec
 252     my $pid = fork();
 253     syserr(g_('cannot fork for %s'), "@prog") unless defined $pid;
 254     if (not $pid) {
 255         # Define environment variables
 256         if ($opts{env}) {
 257             foreach (keys %{$opts{env}}) {
 258                 $ENV{$_} = $opts{env}{$_};
 259             }
 260         }
 261         if ($opts{delete_env}) {
 262             delete $ENV{$_} foreach (@{$opts{delete_env}});
 263         }
 264         # Define signal dispositions.
 265         if ($opts{sig}) {
 266             foreach (keys %{$opts{sig}}) {
 267                 $SIG{$_} = $opts{sig}{$_};
 268             }
 269         }
 270         if ($opts{delete_sig}) {
 271             delete $SIG{$_} foreach (@{$opts{delete_sig}});
 272         }
 273         # Change the current directory
 274         if ($opts{chdir}) {
 275             chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir});
 276         }
 277         # Redirect STDIN if needed
 278         if ($opts{from_file}) {
 279             open(STDIN, '<', $opts{from_file})
 280                 or syserr(g_('cannot open %s'), $opts{from_file});
 281         } elsif ($opts{from_handle}) {
 282             open(STDIN, '<&', $opts{from_handle})
 283                 or syserr(g_('reopen stdin'));
 284             # has been duped, can be closed
 285             push @{$opts{close_in_child}}, $opts{from_handle};
 286         }
 287         # Redirect STDOUT if needed
 288         if ($opts{to_file}) {
 289             open(STDOUT, '>', $opts{to_file})
 290                 or syserr(g_('cannot write %s'), $opts{to_file});
 291         } elsif ($opts{to_handle}) {
 292             open(STDOUT, '>&', $opts{to_handle})
 293                 or syserr(g_('reopen stdout'));
 294             # has been duped, can be closed
 295             push @{$opts{close_in_child}}, $opts{to_handle};
 296         }
 297         # Redirect STDERR if needed
 298         if ($opts{error_to_file}) {
 299             open(STDERR, '>', $opts{error_to_file})
 300                 or syserr(g_('cannot write %s'), $opts{error_to_file});
 301         } elsif ($opts{error_to_handle}) {
 302             open(STDERR, '>&', $opts{error_to_handle})
 303                 or syserr(g_('reopen stdout'));
 304             # has been duped, can be closed
 305             push @{$opts{close_in_child}}, $opts{error_to_handle};
 306         }
 307         # Close some inherited filehandles
 308         close($_) foreach (@{$opts{close_in_child}});
 309         # Execute the program
 310         exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog");
 311     }
 312     # Close handle that we can't use any more
 313     close($opts{from_handle}) if exists $opts{from_handle};
 314     close($opts{to_handle}) if exists $opts{to_handle};
 315     close($opts{error_to_handle}) if exists $opts{error_to_handle};
 316
 317     if ($opts{from_string}) {
 318         print { $from_string_pipe } ${$opts{from_string}};
 319         close($from_string_pipe);
 320     }
 321     if ($opts{to_string}) {
 322         local $/ = undef;
 323         ${$opts{to_string}} = readline($to_string_pipe);
 324     }
 325     if ($opts{error_to_string}) {
 326         local $/ = undef;
 327         ${$opts{error_to_string}} = readline($error_to_string_pipe);
 328     }
 329     if ($opts{wait_child}) {
 330         my $cmdline = "@prog";
 331         if ($opts{env}) {
 332             foreach (keys %{$opts{env}}) {
 333                 $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline";
 334             }
 335         }
 336         wait_child($pid, nocheck => $opts{nocheck},
 337                    timeout => $opts{timeout}, cmdline => $cmdline);
 338         return 1;
 339     }
 340
 341     return $pid;
 342 }
 343
 344
 345 =item wait_child($pid, %opts)
 346
 347 Takes as first argument the pid of the process to wait for.
 348 Remaining arguments are taken as a hash of options. Returns
 349 nothing. Fails if the child has been ended by a signal or
 350 if it exited non-zero.
 351
 352 Options:
 353
 354 =over 4
 355
 356 =item cmdline
 357
 358 String to identify the child process in error messages.
 359 Defaults to "child process".
 360
 361 =item nocheck
 362
 363 If true do not check the return status of the child (and thus
 364 do not fail it has been killed or if it exited with a
 365 non-zero return code).
 366
 367 =item timeout
 368
 369 Set a maximum time to wait for the process, after that kill the process and
 370 fail with an error message.
 371
 372 =back
 373
 374 =cut
 375
 376 sub wait_child {
 377     my ($pid, %opts) = @_;
 378     $opts{cmdline} //= g_('child process');
 379     croak 'no PID set, cannot wait end of process' unless $pid;
 380     eval {
 381         local $SIG{ALRM} = sub { die "alarm\n" };
 382         alarm($opts{timeout}) if defined($opts{timeout});
 383         $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline});
 384         alarm(0) if defined($opts{timeout});
 385     };
 386     if ($@) {
 387         die $@ unless $@ eq "alarm\n";
 388         kill 'TERM', $pid;
 389         error(P_("%s didn't complete in %d second",
 390                  "%s didn't complete in %d seconds",
 391                  $opts{timeout}),
 392               $opts{cmdline}, $opts{timeout});
 393     }
 394     unless ($opts{nocheck}) {
 395         subprocerr($opts{cmdline}) if $?;
 396     }
 397 }
 398
 399 1;
 400
 401 =back
 402
 403 =head1 CHANGES
 404
 405 =head2 Version 1.02 (dpkg 1.18.0)
 406
 407 Change options: wait_child() now kills the process when reaching the 'timeout'.
 408
 409 =head2 Version 1.01 (dpkg 1.17.11)
 410
 411 New options: spawn() now accepts 'sig' and 'delete_sig'.
 412
 413 =head2 Version 1.00 (dpkg 1.15.6)
 414
 415 Mark the module as public.
 416
 417 =head1 SEE ALSO
 418
 419 L<Dpkg>, L<Dpkg::ErrorHandling>.