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 Dpkg::ErrorHandling functions.
  63
  64 Options:
  65
  66 =over 4
  67
  68 =item exec
  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 Mandatory Option.
  78
  79 =item from_file, to_file, error_to_file
  80
  81 Filename as scalar. Standard input/output/error of the
  82 child process will be redirected to the file specified.
  83
  84 =item from_handle, to_handle, error_to_handle
  85
  86 Filehandle. Standard input/output/error of the child process will be
  87 dup'ed from the handle.
  88
  89 =item from_pipe, to_pipe, error_to_pipe
  90
  91 Scalar reference or object based on IO::Handle. A pipe will be opened for
  92 each of the two options and either the reading (C<to_pipe> and
  93 C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in
  94 the referenced scalar. Standard input/output/error of the child process
  95 will be dup'ed to the other ends of the pipes.
  96
  97 =item from_string, to_string, error_to_string
  98
  99 Scalar reference. Standard input/output/error of the child
 100 process will be redirected to the string given as reference. Note
 101 that it wouldn't be strictly necessary to use a scalar reference
 102 for C<from_string>, as the string is not modified in any way. This was
 103 chosen only for reasons of symmetry with C<to_string> and
 104 C<error_to_string>. C<to_string> and C<error_to_string> imply the
 105 C<wait_child> option.
 106
 107 =item wait_child
 108
 109 Scalar. If containing a true value, wait_child() will be called before
 110 returning. The return value of spawn() will be a true value, not the pid.
 111
 112 =item nocheck
 113
 114 Scalar. Option of the wait_child() call.
 115
 116 =item timeout
 117
 118 Scalar. Option of the wait_child() call.
 119
 120 =item chdir
 121
 122 Scalar. The child process will chdir in the indicated directory before
 123 calling exec.
 124
 125 =item env
 126
 127 Hash reference. The child process will populate %ENV with the items of the
 128 hash before calling exec. This allows exporting environment variables.
 129
 130 =item delete_env
 131
 132 Array reference. The child process will remove all environment variables
 133 listed in the array before calling exec.
 134
 135 =item sig
 136
 137 Hash reference. The child process will populate %SIG with the items of the
 138 hash before calling exec. This allows setting signal dispositions.
 139
 140 =item delete_sig
 141
 142 Array reference. The child process will reset all signals listed in the
 143 array to their default dispositions before calling exec.
 144
 145 =back
 146
 147 =cut
 148
 149 sub _check_opts {
 150     my (%opts) = @_;
 151
 152     croak 'exec parameter is mandatory in spawn()'
 153         unless $opts{exec};
 154
 155     my $to = my $error_to = my $from = 0;
 156     foreach my $thing (qw(file handle string pipe)) {
 157         $to++ if $opts{"to_$thing"};
 158         $error_to++ if $opts{"error_to_$thing"};
 159         $from++ if $opts{"from_$thing"};
 160     }
 161     croak 'not more than one of to_* parameters is allowed'
 162         if $to > 1;
 163     croak 'not more than one of error_to_* parameters is allowed'
 164         if $error_to > 1;
 165     croak 'not more than one of from_* parameters is allowed'
 166         if $from > 1;
 167
 168     foreach my $param (qw(to_string error_to_string from_string)) {
 169         if (exists $opts{$param} and
 170             (not ref $opts{$param} or ref $opts{$param} ne 'SCALAR')) {
 171             croak "parameter $param must be a scalar reference";
 172         }
 173     }
 174
 175     foreach my $param (qw(to_pipe error_to_pipe from_pipe)) {
 176         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             croak "parameter $param must be a scalar reference or " .
 180                   'an IO::Handle object';
 181         }
 182     }
 183
 184     if (exists $opts{timeout} and defined($opts{timeout}) and
 185         $opts{timeout} !~ /^\d+$/) {
 186         croak 'parameter timeout must be an integer';
 187     }
 188
 189     if (exists $opts{env} and ref($opts{env}) ne 'HASH') {
 190         croak 'parameter env must be a hash reference';
 191     }
 192
 193     if (exists $opts{delete_env} and ref($opts{delete_env}) ne 'ARRAY') {
 194         croak 'parameter delete_env must be an array reference';
 195     }
 196
 197     if (exists $opts{sig} and ref($opts{sig}) ne 'HASH') {
 198         croak 'parameter sig must be a hash reference';
 199     }
 200
 201     if (exists $opts{delete_sig} and ref($opts{delete_sig}) ne 'ARRAY') {
 202         croak 'parameter delete_sig must be an array reference';
 203     }
 204
 205     return %opts;
 206 }
 207
 208 sub spawn {
 209     my (%opts) = @_;
 210     my @prog;
 211
 212     _check_opts(%opts);
 213     $opts{close_in_child} //= [];
 214     if (ref($opts{exec}) =~ /ARRAY/) {
 215         push @prog, @{$opts{exec}};
 216     } elsif (not ref($opts{exec})) {
 217         push @prog, $opts{exec};
 218     } else {
 219         croak 'invalid exec parameter in spawn()';
 220     }
 221     my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe);
 222     if ($opts{to_string}) {
 223         $opts{to_pipe} = \$to_string_pipe;
 224         $opts{wait_child} = 1;
 225     }
 226     if ($opts{error_to_string}) {
 227         $opts{error_to_pipe} = \$error_to_string_pipe;
 228         $opts{wait_child} = 1;
 229     }
 230     if ($opts{from_string}) {
 231         $opts{from_pipe} = \$from_string_pipe;
 232     }
 233     # Create pipes if needed
 234     my ($input_pipe, $output_pipe, $error_pipe);
 235     if ($opts{from_pipe}) {
 236         pipe($opts{from_handle}, $input_pipe)
 237             or syserr(g_('pipe for %s'), "@prog");
 238         ${$opts{from_pipe}} = $input_pipe;
 239         push @{$opts{close_in_child}}, $input_pipe;
 240     }
 241     if ($opts{to_pipe}) {
 242         pipe($output_pipe, $opts{to_handle})
 243             or syserr(g_('pipe for %s'), "@prog");
 244         ${$opts{to_pipe}} = $output_pipe;
 245         push @{$opts{close_in_child}}, $output_pipe;
 246     }
 247     if ($opts{error_to_pipe}) {
 248         pipe($error_pipe, $opts{error_to_handle})
 249             or syserr(g_('pipe for %s'), "@prog");
 250         ${$opts{error_to_pipe}} = $error_pipe;
 251         push @{$opts{close_in_child}}, $error_pipe;
 252     }
 253     # Fork and exec
 254     my $pid = fork();
 255     syserr(g_('cannot fork for %s'), "@prog") unless defined $pid;
 256     if (not $pid) {
 257         # Define environment variables
 258         if ($opts{env}) {
 259             foreach (keys %{$opts{env}}) {
 260                 $ENV{$_} = $opts{env}{$_};
 261             }
 262         }
 263         if ($opts{delete_env}) {
 264             delete $ENV{$_} foreach (@{$opts{delete_env}});
 265         }
 266         # Define signal dispositions.
 267         if ($opts{sig}) {
 268             foreach (keys %{$opts{sig}}) {
 269                 $SIG{$_} = $opts{sig}{$_};
 270             }
 271         }
 272         if ($opts{delete_sig}) {
 273             delete $SIG{$_} foreach (@{$opts{delete_sig}});
 274         }
 275         # Change the current directory
 276         if ($opts{chdir}) {
 277             chdir($opts{chdir}) or syserr(g_('chdir to %s'), $opts{chdir});
 278         }
 279         # Redirect STDIN if needed
 280         if ($opts{from_file}) {
 281             open(STDIN, '<', $opts{from_file})
 282                 or syserr(g_('cannot open %s'), $opts{from_file});
 283         } elsif ($opts{from_handle}) {
 284             open(STDIN, '<&', $opts{from_handle})
 285                 or syserr(g_('reopen stdin'));
 286             # has been duped, can be closed
 287             push @{$opts{close_in_child}}, $opts{from_handle};
 288         }
 289         # Redirect STDOUT if needed
 290         if ($opts{to_file}) {
 291             open(STDOUT, '>', $opts{to_file})
 292                 or syserr(g_('cannot write %s'), $opts{to_file});
 293         } elsif ($opts{to_handle}) {
 294             open(STDOUT, '>&', $opts{to_handle})
 295                 or syserr(g_('reopen stdout'));
 296             # has been duped, can be closed
 297             push @{$opts{close_in_child}}, $opts{to_handle};
 298         }
 299         # Redirect STDERR if needed
 300         if ($opts{error_to_file}) {
 301             open(STDERR, '>', $opts{error_to_file})
 302                 or syserr(g_('cannot write %s'), $opts{error_to_file});
 303         } elsif ($opts{error_to_handle}) {
 304             open(STDERR, '>&', $opts{error_to_handle})
 305                 or syserr(g_('reopen stdout'));
 306             # has been duped, can be closed
 307             push @{$opts{close_in_child}}, $opts{error_to_handle};
 308         }
 309         # Close some inherited filehandles
 310         close($_) foreach (@{$opts{close_in_child}});
 311         # Execute the program
 312         exec({ $prog[0] } @prog) or syserr(g_('unable to execute %s'), "@prog");
 313     }
 314     # Close handle that we can't use any more
 315     close($opts{from_handle}) if exists $opts{from_handle};
 316     close($opts{to_handle}) if exists $opts{to_handle};
 317     close($opts{error_to_handle}) if exists $opts{error_to_handle};
 318
 319     if ($opts{from_string}) {
 320         print { $from_string_pipe } ${$opts{from_string}};
 321         close($from_string_pipe);
 322     }
 323     if ($opts{to_string}) {
 324         local $/ = undef;
 325         ${$opts{to_string}} = readline($to_string_pipe);
 326     }
 327     if ($opts{error_to_string}) {
 328         local $/ = undef;
 329         ${$opts{error_to_string}} = readline($error_to_string_pipe);
 330     }
 331     if ($opts{wait_child}) {
 332         my $cmdline = "@prog";
 333         if ($opts{env}) {
 334             foreach (keys %{$opts{env}}) {
 335                 $cmdline = "$_=\"" . $opts{env}{$_} . "\" $cmdline";
 336             }
 337         }
 338         wait_child($pid, nocheck => $opts{nocheck},
 339                    timeout => $opts{timeout}, cmdline => $cmdline);
 340         return 1;
 341     }
 342
 343     return $pid;
 344 }
 345
 346
 347 =item wait_child($pid, %opts)
 348
 349 Takes as first argument the pid of the process to wait for.
 350 Remaining arguments are taken as a hash of options. Returns
 351 nothing. Fails if the child has been ended by a signal or
 352 if it exited non-zero.
 353
 354 Options:
 355
 356 =over 4
 357
 358 =item cmdline
 359
 360 String to identify the child process in error messages.
 361 Defaults to "child process".
 362
 363 =item nocheck
 364
 365 If true do not check the return status of the child (and thus
 366 do not fail it has been killed or if it exited with a
 367 non-zero return code).
 368
 369 =item timeout
 370
 371 Set a maximum time to wait for the process, after that kill the process and
 372 fail with an error message.
 373
 374 =back
 375
 376 =cut
 377
 378 sub wait_child {
 379     my ($pid, %opts) = @_;
 380     $opts{cmdline} //= g_('child process');
 381     croak 'no PID set, cannot wait end of process' unless $pid;
 382     eval {
 383         local $SIG{ALRM} = sub { die "alarm\n" };
 384         alarm($opts{timeout}) if defined($opts{timeout});
 385         $pid == waitpid($pid, 0) or syserr(g_('wait for %s'), $opts{cmdline});
 386         alarm(0) if defined($opts{timeout});
 387     };
 388     if ($@) {
 389         die $@ unless $@ eq "alarm\n";
 390         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               $opts{cmdline}, $opts{timeout});
 395     }
 396     unless ($opts{nocheck}) {
 397         subprocerr($opts{cmdline}) if $?;
 398     }
 399 }
 400
 401 1;
 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