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