Girocco/ExecUtil.pm

   1 # Girocco::ExecUtil.pm -- utility to assist with re-exec'ing oneself
   2 # Copyright (C) 2016 Kyle J. McKay.  All rights reserved.
   3
   4 # This program is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU General Public License
   6 # as published by the Free Software Foundation; either version 2
   7 # of the License, or (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, download a copy from
  16 # http://www.gnu.org/licenses/gpl-2.0.html
  17 # or write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  19
  20 package Girocco::ExecUtil;
  21
  22 use strict;
  23 use warnings;
  24 use Cwd;
  25 use POSIX qw(_exit);
  26
  27 use base qw(Exporter);
  28 use vars qw(@EXPORT @EXPORT_OK $VERSION);
  29
  30 BEGIN {
  31         @EXPORT = ();
  32         @EXPORT_OK = qw();
  33         *VERSION = \'1.0';
  34 }
  35
  36 sub new {
  37         my $class = shift || __PACKAGE__;
  38         $class = ref($class) if ref($class);
  39         my $program = shift;
  40         defined($program) or $program = $0;
  41         my $argv0 = shift;
  42         defined($argv0) or $argv0 = $program;
  43         my $self = {};
  44         %{$self->{ENV}} = %ENV;
  45         $self->{program} = $program;
  46         $self->{argv0} = $argv0;
  47         @{$self->{ARGV}} = @ARGV;
  48         $self->{cwd} = getcwd;
  49         -d $self->{cwd} or die __PACKAGE__ . "::new: fatal: unable to getcwd\n";
  50         return bless $self, $class;
  51 }
  52
  53 # similar to exec except forks first and then _exit(0)'s on success
  54 # if first arg is CODE ref, call that after successful fork and exec
  55 # if first arg is HASH ref, cleanup member may be CODE ref, samepid boolean
  56 # means reexec in this pid with cleanup in other pid
  57 # cleanup routine receives 2 args, $oldpid, $newpid which will be same if
  58 # samepid option set
  59 # first arg is program second and following are argv[0], argv[1], ...
  60 sub _forkexec {
  61         my $opts = {};
  62         if (ref($_[0]) eq 'HASH') {
  63                 $opts = shift;
  64         } elsif (ref($_[0]) eq 'CODE') {
  65                 $opts = { cleanup => shift };
  66         }
  67         my $program = shift;
  68         my ($read, $write, $read2, $write2);
  69         my $oldpid = $$;
  70         my $needfork = !$opts->{samepid} || ref($opts->{cleanup}) eq 'CODE';
  71         pipe($read, $write) or return undef if $needfork;
  72         select((select($write),$|=1)[0]) if $needfork;
  73         my $oldsigchld = $SIG{'CHLD'};
  74         defined($oldsigchld) or $oldsigchld = sub {};
  75         if ($needfork && $opts->{samepid} && !pipe($read2, $write2)) {
  76                 local $!;
  77                 close $write;
  78                 close $read;
  79                 return undef;
  80         }
  81         select((select($write2),$|=1)[0]) if $needfork && $opts->{samepid};
  82         $SIG{'CHLD'} = sub {} if $needfork;
  83         my $retries = 3;
  84         my $child;
  85         while ($needfork && !defined($child) && $retries--) {
  86                 $child = fork;
  87                 sleep 1 unless defined($child) || !$retries;
  88         }
  89         if ($needfork && !defined($child)) {
  90                 local $!;
  91                 if ($needfork) {
  92                         close $write;
  93                         close $read;
  94                         if ($opts->{samepid}) {
  95                                 close $write2;
  96                                 close $read2;
  97                         }
  98                 }
  99                 $SIG{'CHLD'} = $oldsigchld;
 100                 return undef;
 101         }
 102         if ($needfork && $opts->{samepid}) {
 103                 # child must fork again and the parent get reaped by $$
 104                 if (!$child) {
 105                         close $read2;
 106                         my $retries2 = 3;
 107                         my $child2;
 108                         while (!defined($child2) && $retries2--) {
 109                                 $child2 = fork;
 110                                 sleep 1 unless defined($child2) || !$retries2;
 111                         }
 112                         if (!defined($child2)) {
 113                                 my $ec = 0 + $!;
 114                                 $ec = 255 unless $ec;
 115                                 print $write2 ":$ec";
 116                                 close $write2;
 117                                 _exit 127;
 118                         }
 119                         if ($child2) {
 120                                 # pass new child pid up to parent and exit
 121                                 print $write2 $child2;
 122                                 close $write2;
 123                                 _exit 0;
 124                         } else {
 125                                 # this is the grandchild
 126                                 close $write2;
 127                         }
 128                 } else {
 129                         close $write2;
 130                         my $result = <$read2>;
 131                         close $read2;
 132                         chomp $result if defined($result);
 133                         if (!defined($result) || $result !~ /^:?\d+$/) {
 134                                 # something's wrong with the child -- kill it
 135                                 kill(9, $child) && waitpid($child, 0);
 136                                 my $oldsigpipe = $SIG{'PIPE'};
 137                                 # make sure the grandchild, if any,
 138                                 # doesn't run the success proc
 139                                 $SIG{'PIPE'} = sub {};
 140                                 print $write 1;
 141                                 close $write;
 142                                 close $read;
 143                                 $SIG{'PIPE'} = defined($oldsigpipe) ?
 144                                         $oldsigpipe : 'DEFAULT';
 145                                 $! = 255;
 146                                 $SIG{'CHLD'} = $oldsigchld;
 147                                 return undef;
 148                         }
 149                         if ($result =~ /^:(\d+)$/) {
 150                                 # fork failed in child, there is no grandchild
 151                                 my $ec = $1;
 152                                 waitpid($child, 0);
 153                                 close $write;
 154                                 close $read;
 155                                 $! = $ec;
 156                                 $SIG{'CHLD'} = $oldsigchld;
 157                                 return undef;
 158                         }
 159                         # reap the child and set $child to grandchild's pid
 160                         waitpid($child, 0);
 161                         $child = $result;
 162                 }
 163         }
 164         if (!$opts->{samepid}) {
 165                 if (!$child) {
 166                         # child
 167                         close $read;
 168                         { exec({$program} @_) };
 169                         my $ec = 0 + $!;
 170                         $ec = 255 unless $ec;
 171                         print $write $ec;
 172                         close $write;
 173                         _exit 127;
 174                 }
 175                 close $write;
 176                 my $result = <$read>;
 177                 close $read;
 178                 chomp $result if defined($result);
 179                 waitpid($child, 0);
 180                 if (defined($result) && $result != 0) {
 181                         $! = $result;
 182                         $SIG{'CHLD'} = $oldsigchld;
 183                         return undef;
 184                 }
 185                 &{$opts->{cleanup}}($oldpid, $child)
 186                         if ref($opts->{cleanup}) eq 'CODE';
 187                 _exit 0;
 188         } else {
 189                 if ($needfork && !$child) {
 190                         # grandchild
 191                         close $write;
 192                         my $result = <$read>;
 193                         close $read;
 194                         chomp $result if defined($result);
 195                         _exit 127 if $result && $result != 0;
 196                         &{$opts->{cleanup}}($oldpid, $oldpid);
 197                         _exit 0;
 198                 }
 199                 close $read if $needfork;
 200                 my $result;
 201                 { $result = exec({$program} @_) };
 202                 my $ec = 0 + $!;
 203                 $ec = 255 unless $ec;
 204                 print $write $ec if $needfork;
 205                 close $write if $needfork;
 206                 $SIG{'CHLD'} = $oldsigchld;
 207                 return $result;
 208         }
 209 }
 210
 211 sub reexec {
 212         my $self = shift;
 213         my $opts = {};
 214         $opts->{cleanup} = shift if ref($_[0]) eq 'CODE';
 215         $opts->{samepid} = shift;
 216         ref($self->{ENV}) eq 'HASH' &&
 217         defined($self->{program}) &&
 218         defined($self->{argv0}) &&
 219         ref($self->{ARGV}) eq 'ARRAY' &&
 220         defined($self->{cwd}) or die __PACKAGE__ . "::reexec: fatal: invalid instance\n";
 221         my %envsave = %ENV;
 222         my $cwdsave = eval { no warnings; getcwd; };
 223         my $result = chdir($self->{cwd});
 224         return $result unless $result;
 225         %ENV = %{$self->{ENV}};
 226         $result = _forkexec($opts, $self->{program}, $self->{argv0}, @{$self->{ARGV}});
 227         %ENV = %envsave;
 228         chdir($cwdsave) if defined($cwdsave);
 229         return $result;
 230 }
 231
 232 sub getenv {
 233         my $self = shift;
 234         my $result = undef;
 235         if (exists($self->{ENV}->{$_[0]})) {
 236                 $result = $self->{ENV}->{$_[0]};
 237                 defined($result) or $result = "";
 238         }
 239         $result;
 240 }
 241
 242 sub setenv {
 243         my $self = shift;
 244         my ($k, $v) = @_;
 245         if (defined($v)) {
 246                 $self->{ENV}->{$k} = $v;
 247         } else {
 248                 delete $self->{ENV}->{$k};
 249         }
 250 }
 251
 252 sub delenv {
 253         my $self = shift;
 254         $self->setenv($_[0], undef);
 255 }
 256
 257 1;
 258
 259 __END__
 260
 261 =head1 NAME
 262
 263 Girocco::ExecUtil - Re-execution utility
 264
 265 =head1 SYNOPSIS
 266
 267     use Girocco::ExecUtil;
 268
 269     my $exec_state = Girocco::ExecUtil->new;
 270     # do some stuff and run for a while
 271     $exec_state->reexec;
 272
 273 =head1 DESCRIPTION
 274
 275 This module provides a re-exec function for long-running processes that
 276 may want to re-start themselves at a later point in time if they have been
 277 updated.
 278
 279 The C<Girocco::ExecUtil> instance records various information about the current
 280 state of the process when it's called (C<@ARGV>, C<%ENV>, current working directory,
 281 C<$0> process name) for subsequent use by the C<reexec> function.
 282
 283 When the C<reexec> function is called, it restores C<%ENV> and the current working
 284 directory to the previously saved state and then C<exec>'s the previously saved
 285 C<$0> using the previously saved C<@ARGV> in a new process and C<_exit>'s the
 286 old one.
 287
 288 The following functions are provided:
 289
 290 =over 4
 291
 292 =item Girocco::ExecUtil->new
 293
 294 =item Girocco::ExecUtil->new(I<program>)
 295
 296 =item Girocco::ExecUtil->new(I<program>, I<argv0>)
 297
 298 Create and return a new instance recording the current environment (C<%ENV>),
 299 program (C<$0>), arguments (C<@ARGV>) and working directory (C<getcwd>) for
 300 later use by the reexec function.  If I<program> is passed it is used in place
 301 of C<$0> for both the program to execute and C<argv[0]>.  If I<program> and
 302 I<argv0> are passed then I<program> will be executed but passed I<argv0> as its
 303 C<argv[0]>.
 304
 305 =item $instance->reexec(I<samepid>)
 306
 307 =item $instance->reexec(I<coderef>, I<samepid>)
 308
 309 Restore the saved environment and current working directory recorded in
 310 the instance and then fork and exec the program and arguments recorded in the
 311 instance and if successful call I<coderef>, if provided, and then _exit(0).
 312
 313 Only returns if the chdir, fork or exec call fails (in which case I<coderef> is
 314 NOT called and the current working directory may have been restored to its
 315 saved value).
 316
 317 Note that I<coderef>, if provided, is called B<after> the successful fork and
 318 exec so the newly exec'd process may already be running by then (I<coderef> is
 319 B<never> called if the C<reexec> fails).  I<coderef> receives two arguments,
 320 the first is the old pid (the one calling C<reexec>) and the second is the
 321 new pid (the one the C<exec> call runs in).
 322
 323 If the I<samepid> argument is omitted or is false (recommended) all behaves as
 324 described above.   However, if I<samepid> is true then the C<exec> call runs
 325 from the current pid and I<coderef>, if present, is called (with both arguments
 326 the same) from a double C<fork>'d process to avoid a spurious C<SIGCHLD> (but
 327 still I<only> if the C<reexec> succeeds) otherwise (I<samepid> is true but no
 328 I<coderef> is present) no fork occurs at all, just the C<exec>.  Re-exec'ing
 329 oneself (i.e. keeping the same pid) may result in difficult to diagnose
 330 failures on systems where some kinds of initialization can only be performed
 331 once for any given pid during its lifetime which is why setting I<samepid> to
 332 true is not recommended.
 333
 334 =item $instance->getenv(I<name>)
 335
 336 Return the value of environment variable I<name> saved in the instance or
 337 C<undef> if it's not part of the saved environment.  If the environment
 338 variable I<name> is present in the saved environment then C<undef> will
 339 B<never> be returned.
 340
 341 =item $instance->setenv(I<name>, I<value>)
 342
 343 =item $instance->setenv(I<name>, undef)
 344
 345 =item $instance->delenv(I<name>)
 346
 347 Set the value of environment variable I<name> saved in the instance.  If
 348 I<value> is C<undef> or omitted or C<delenv> used then remove the environment
 349 variable named I<name> from the environment saved in the instance -- it is
 350 no error to remove an environment variable that is not present in the instance.
 351
 352 =back
 353
 354 =head1 COPYRIGHT
 355
 356 Copyright (C) 2016 Kyle J. McKay.  All rights reserved.
 357
 358 License GPLv2+: GNU General Public License version 2 or later.
 359 See comments at top of source file for details.
 360
 361 L<http://www.gnu.org/licenses/gpl-2.0.html>
 362
 363 This is free software: you are free to change and redistribute it.
 364 There is NO WARRANTY, to the extent permitted by law.
 365
 366 =cut