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 use File::Spec ();
  27
  28 use base qw(Exporter);
  29 use vars qw(@EXPORT @EXPORT_OK $VERSION);
  30
  31 BEGIN {
  32         @EXPORT = qw(daemon);
  33         @EXPORT_OK = qw();
  34         *VERSION = \'1.0';
  35 }
  36
  37 sub new {
  38         my $class = shift || __PACKAGE__;
  39         $class = ref($class) if ref($class);
  40         my $program = shift;
  41         defined($program) or $program = $0;
  42         $program = $1 if $program =~ m|^(/.+)$|;
  43         my $argv0 = shift;
  44         $argv0 = $1 if defined($argv0) && $argv0 =~ /^(.+)$/;
  45         defined($argv0) or $argv0 = $program;
  46         my $self = {};
  47         %{$self->{ENV}} = %ENV;
  48         $self->{program} = $program;
  49         $self->{argv0} = $argv0;
  50         @{$self->{ARGV}} = ();
  51         m|^(.*)$|s && push(@{$self->{ARGV}}, $1) foreach @ARGV;
  52         $self->{cwd} = getcwd;
  53         -d $self->{cwd} or die __PACKAGE__ . "::new: fatal: unable to getcwd\n";
  54         $self->{cwd} = $1 if $self->{cwd} =~ m|^(/.*)$|;
  55         return bless $self, $class;
  56 }
  57
  58 # similar to exec except forks first and then _exit(0)'s on success
  59 # if first arg is CODE ref, call that after successful fork and exec
  60 # if first arg is HASH ref, cleanup member may be CODE ref, samepid boolean
  61 # means reexec in this pid with cleanup in other pid
  62 # cleanup routine receives 2 args, $oldpid, $newpid which will be same if
  63 # samepid option set
  64 # first arg is program second and following are argv[0], argv[1], ...
  65 sub _forkexec {
  66         my $opts = {};
  67         if (ref($_[0]) eq 'HASH') {
  68                 $opts = shift;
  69         } elsif (ref($_[0]) eq 'CODE') {
  70                 $opts = { cleanup => shift };
  71         }
  72         my $program = shift;
  73         my ($read, $write, $read2, $write2);
  74         my $oldpid = $$;
  75         my $needfork = !$opts->{samepid} || ref($opts->{cleanup}) eq 'CODE';
  76         pipe($read, $write) or return undef if $needfork;
  77         select((select($write),$|=1)[0]) if $needfork;
  78         my $oldsigchld = $SIG{'CHLD'};
  79         defined($oldsigchld) or $oldsigchld = sub {};
  80         if ($needfork && $opts->{samepid} && !pipe($read2, $write2)) {
  81                 local $!;
  82                 close $write;
  83                 close $read;
  84                 return undef;
  85         }
  86         select((select($write2),$|=1)[0]) if $needfork && $opts->{samepid};
  87         $SIG{'CHLD'} = sub {} if $needfork;
  88         my $retries = 3;
  89         my $child;
  90         while ($needfork && !defined($child) && $retries--) {
  91                 $child = fork;
  92                 sleep 1 unless defined($child) || !$retries;
  93         }
  94         if ($needfork && !defined($child)) {
  95                 local $!;
  96                 if ($needfork) {
  97                         close $write;
  98                         close $read;
  99                         if ($opts->{samepid}) {
 100                                 close $write2;
 101                                 close $read2;
 102                         }
 103                 }
 104                 $SIG{'CHLD'} = $oldsigchld;
 105                 return undef;
 106         }
 107         if ($needfork && $opts->{samepid}) {
 108                 # child must fork again and the parent get reaped by $$
 109                 if (!$child) {
 110                         close $read2;
 111                         my $retries2 = 3;
 112                         my $child2;
 113                         while (!defined($child2) && $retries2--) {
 114                                 $child2 = fork;
 115                                 sleep 1 unless defined($child2) || !$retries2;
 116                         }
 117                         if (!defined($child2)) {
 118                                 my $ec = 0 + $!;
 119                                 $ec = 255 unless $ec;
 120                                 print $write2 ":$ec";
 121                                 close $write2;
 122                                 _exit 127;
 123                         }
 124                         if ($child2) {
 125                                 # pass new child pid up to parent and exit
 126                                 print $write2 $child2;
 127                                 close $write2;
 128                                 _exit 0;
 129                         } else {
 130                                 # this is the grandchild
 131                                 close $write2;
 132                         }
 133                 } else {
 134                         close $write2;
 135                         my $result = <$read2>;
 136                         close $read2;
 137                         chomp $result if defined($result);
 138                         if (!defined($result) || $result !~ /^:?\d+$/) {
 139                                 # something's wrong with the child -- kill it
 140                                 kill(9, $child) && waitpid($child, 0);
 141                                 my $oldsigpipe = $SIG{'PIPE'};
 142                                 # make sure the grandchild, if any,
 143                                 # doesn't run the success proc
 144                                 $SIG{'PIPE'} = sub {};
 145                                 print $write 1;
 146                                 close $write;
 147                                 close $read;
 148                                 $SIG{'PIPE'} = defined($oldsigpipe) ?
 149                                         $oldsigpipe : 'DEFAULT';
 150                                 $! = 255;
 151                                 $SIG{'CHLD'} = $oldsigchld;
 152                                 return undef;
 153                         }
 154                         if ($result =~ /^:(\d+)$/) {
 155                                 # fork failed in child, there is no grandchild
 156                                 my $ec = $1;
 157                                 waitpid($child, 0);
 158                                 close $write;
 159                                 close $read;
 160                                 $! = $ec;
 161                                 $SIG{'CHLD'} = $oldsigchld;
 162                                 return undef;
 163                         }
 164                         # reap the child and set $child to grandchild's pid
 165                         waitpid($child, 0);
 166                         $child = $result;
 167                 }
 168         }
 169         if (!$opts->{samepid}) {
 170                 if (!$child) {
 171                         # child
 172                         close $read;
 173                         { exec({$program} @_) };
 174                         my $ec = 0 + $!;
 175                         $ec = 255 unless $ec;
 176                         print $write $ec;
 177                         close $write;
 178                         _exit 127;
 179                 }
 180                 close $write;
 181                 my $result = <$read>;
 182                 close $read;
 183                 chomp $result if defined($result);
 184                 waitpid($child, 0);
 185                 if (defined($result) && $result != 0) {
 186                         $! = $result;
 187                         $SIG{'CHLD'} = $oldsigchld;
 188                         return undef;
 189                 }
 190                 &{$opts->{cleanup}}($oldpid, $child)
 191                         if ref($opts->{cleanup}) eq 'CODE';
 192                 _exit 0;
 193         } else {
 194                 if ($needfork && !$child) {
 195                         # grandchild
 196                         close $write;
 197                         my $result = <$read>;
 198                         close $read;
 199                         chomp $result if defined($result);
 200                         _exit 127 if $result && $result != 0;
 201                         &{$opts->{cleanup}}($oldpid, $oldpid);
 202                         _exit 0;
 203                 }
 204                 close $read if $needfork;
 205                 my $result;
 206                 { $result = exec({$program} @_) };
 207                 my $ec = 0 + $!;
 208                 $ec = 255 unless $ec;
 209                 print $write $ec if $needfork;
 210                 close $write if $needfork;
 211                 $SIG{'CHLD'} = $oldsigchld;
 212                 return $result;
 213         }
 214 }
 215
 216 sub reexec {
 217         my $self = shift;
 218         my $opts = {};
 219         $opts->{cleanup} = shift if ref($_[0]) eq 'CODE';
 220         $opts->{samepid} = shift;
 221         ref($self->{ENV}) eq 'HASH' &&
 222         defined($self->{program}) &&
 223         defined($self->{argv0}) &&
 224         ref($self->{ARGV}) eq 'ARRAY' &&
 225         defined($self->{cwd}) or die __PACKAGE__ . "::reexec: fatal: invalid instance\n";
 226         my %envsave = %ENV;
 227         my $cwdsave = eval { no warnings; getcwd; };
 228         $cwdsave = $1 if defined($cwdsave) && $cwdsave =~ m|^(/.*)$|;
 229         my $result = chdir($self->{cwd});
 230         return $result unless $result;
 231         %ENV = %{$self->{ENV}};
 232         $result = _forkexec($opts, $self->{program}, $self->{argv0}, @{$self->{ARGV}});
 233         %ENV = %envsave;
 234         chdir($cwdsave) if defined($cwdsave);
 235         return $result;
 236 }
 237
 238 sub getenv {
 239         my $self = shift;
 240         my $result = undef;
 241         if (exists($self->{ENV}->{$_[0]})) {
 242                 $result = $self->{ENV}->{$_[0]};
 243                 defined($result) or $result = "";
 244         }
 245         $result;
 246 }
 247
 248 sub setenv {
 249         my $self = shift;
 250         my ($k, $v) = @_;
 251         if (defined($v)) {
 252                 $self->{ENV}->{$k} = $v;
 253         } else {
 254                 delete $self->{ENV}->{$k};
 255         }
 256 }
 257
 258 sub delenv {
 259         my $self = shift;
 260         $self->setenv($_[0], undef);
 261 }
 262
 263 sub daemon {
 264         use POSIX qw(_exit setpgid setsid dup2 :fcntl_h);
 265         my ($nochdir, $noclose) = @_;
 266         my $devnull = File::Spec->devnull unless $noclose;
 267         my $oldsigchld = $SIG{'CHLD'};
 268         defined($oldsigchld) or $oldsigchld = sub {};
 269         my ($read, $write, $read2, $write2);
 270         pipe($read, $write) or return 0;
 271         select((select($write),$|=1)[0]);
 272         if (!pipe($read2, $write2)) {
 273                 local $!;
 274                 close $write;
 275                 close $read;
 276                 return 0;
 277         }
 278         select((select($write2),$|=1)[0]);
 279         $SIG{'CHLD'} = sub {};
 280         my $retries = 3;
 281         my $child;
 282         while (!defined($child) && $retries--) {
 283                 $child = fork;
 284                 sleep 1 unless defined($child) || !$retries;
 285         }
 286         if (!defined($child)) {
 287                 local $!;
 288                 close $write2;
 289                 close $read2;
 290                 close $write;
 291                 close $read;
 292                 $SIG{'CHLD'} = $oldsigchld;
 293                 return 0;
 294         }
 295         # double fork the child
 296         if (!$child) {
 297                 close $read2;
 298                 my $retries2 = 3;
 299                 my $child2;
 300                 while (!defined($child2) && $retries2--) {
 301                         $child2 = fork;
 302                         sleep 1 unless defined($child2) || !$retries2;
 303                 }
 304                 if (!defined($child2)) {
 305                         my $ec = 0 + $!;
 306                         $ec = 255 unless $ec;
 307                         print $write2 ":$ec";
 308                         close $write2;
 309                         _exit 127;
 310                 }
 311                 if ($child2) {
 312                         # pass new child pid up to parent and exit
 313                         print $write2 $child2;
 314                         close $write2;
 315                         _exit 0;
 316                 } else {
 317                         # this is the grandchild
 318                         close $write2;
 319                 }
 320         } else {
 321                 close $write2;
 322                 my $result = <$read2>;
 323                 close $read2;
 324                 chomp $result if defined($result);
 325                 if (!defined($result) || $result !~ /^:?\d+$/) {
 326                         # something's wrong with the child -- kill it
 327                         kill(9, $child) && waitpid($child, 0);
 328                         $! = 255;
 329                         $SIG{'CHLD'} = $oldsigchld;
 330                         return 0;
 331                 }
 332                 if ($result =~ /^:(\d+)$/) {
 333                         # fork failed in child, there is no grandchild
 334                         my $ec = $1;
 335                         waitpid($child, 0);
 336                         close $write;
 337                         close $read;
 338                         $! = $ec;
 339                         $SIG{'CHLD'} = $oldsigchld;
 340                         return 0;
 341                 }
 342                 # reap the child and set $child to grandchild's pid
 343                 waitpid($child, 0);
 344                 $child = $result;
 345         }
 346         if (!$child) {
 347                 # grandchild that actually becomes the daemon
 348                 close $read;
 349                 my $exitfail = sub {
 350                         my $ec = 0 + $!;
 351                         print $write $ec;
 352                         close $write;
 353                         _exit 255;
 354                 };
 355                 &$exitfail unless ($nochdir || chdir("/"));
 356                 unless ($noclose) {
 357                         my ($ufd, $wrfd);
 358                         defined($ufd = POSIX::open($devnull, O_RDWR)) or &$exitfail;
 359                         defined(dup2($ufd, 0)) or &$exitfail unless $ufd == 0;
 360                         defined(dup2($ufd, 1)) or &$exitfail unless $ufd == 1;
 361                         defined(dup2($ufd, 2)) or &$exitfail unless $ufd == 2;
 362                         POSIX::close($ufd) or &$exitfail unless $ufd == 0 || $ufd == 1 || $ufd == 2;
 363                 }
 364                 &$exitfail unless POSIX::setsid || $$ == POSIX::getpgrp;
 365                 &$exitfail unless POSIX::setpgid(0, $$) || $$ == POSIX::getpgrp;
 366                 close $write;
 367                 $SIG{'CHLD'} = $oldsigchld;
 368                 return 1; # success we are now the daemon
 369         }
 370         close $write;
 371         my $result = <$read>;
 372         close $read;
 373         chomp $result if defined $result;
 374         $SIG{'CHLD'} = $oldsigchld;
 375         _exit(0) unless $result;
 376         $! = $result;
 377         return 0; # daemon attempt failed
 378 }
 379
 380 1;
 381
 382 __END__
 383
 384 =head1 NAME
 385
 386 Girocco::ExecUtil - Re-execution utility
 387
 388 =head1 SYNOPSIS
 389
 390     use Girocco::ExecUtil;
 391
 392     my $exec_state = Girocco::ExecUtil->new;
 393     daemon or die "daemon failed: $!";
 394     # do some stuff and run for a while
 395     $exec_state->reexec;
 396
 397 =head1 DESCRIPTION
 398
 399 This module provides a re-exec function for long-running processes that
 400 may want to re-start themselves at a later point in time if they have been
 401 updated.  As a convenience, it also includes a daemon function to assist with
 402 running processes in the background,
 403
 404 The C<Girocco::ExecUtil> instance records various information about the current
 405 state of the process when it's called (C<@ARGV>, C<%ENV>, current working directory,
 406 C<$0> process name) for subsequent use by the C<reexec> function.
 407
 408 When the C<reexec> function is called, it restores C<%ENV> and the current working
 409 directory to the previously saved state and then C<exec>'s the previously saved
 410 C<$0> using the previously saved C<@ARGV> in a new process and C<_exit>'s the
 411 old one.
 412
 413 The following functions are provided:
 414
 415 =over 4
 416
 417 =item daemon(I<nochdir>, I<noclose>)
 418
 419 Attempt to become a background daemon by double-forking, redirecting STDIN,
 420 STDOUT and STDERR to C</dev/null>, doing C<chdir> to C</> and then calling
 421 setsid and setpgid.  Returns true on success in which case the original process
 422 has been C<_exit(0)>'d.  Otherwise C<$!> contains the failure and STDIN,
 423 STDOUT, STDERR and the cwd are unchanged on return.
 424
 425 If I<nochdir> is true then the C<chdir> is skipped.  If I<noclose>
 426 is true then STDIN, STDOUT and STDERR are left unchanged.  Note that when
 427 STDIN, STDOUT and STDERR are redirected (i.e. I<noclose> is false), it is the
 428 underlying file handles 0, 1 and 2 that are modified -- if the Perl filehandles
 429 are pointing somewhere else (such as being C<tied>) they will be unaffected.
 430
 431 =item Girocco::ExecUtil->new
 432
 433 =item Girocco::ExecUtil->new(I<program>)
 434
 435 =item Girocco::ExecUtil->new(I<program>, I<argv0>)
 436
 437 Create and return a new instance recording the current environment (C<%ENV>),
 438 program (C<$0>), arguments (C<@ARGV>) and working directory (C<getcwd>) for
 439 later use by the reexec function.  If I<program> is passed it is used in place
 440 of C<$0> for both the program to execute and C<argv[0]>.  If I<program> and
 441 I<argv0> are passed then I<program> will be executed but passed I<argv0> as its
 442 C<argv[0]>.
 443
 444 =item $instance->reexec(I<samepid>)
 445
 446 =item $instance->reexec(I<coderef>, I<samepid>)
 447
 448 Restore the saved environment and current working directory recorded in
 449 the instance and then fork and exec the program and arguments recorded in the
 450 instance and if successful call I<coderef>, if provided, and then _exit(0).
 451
 452 Only returns if the chdir, fork or exec call fails (in which case I<coderef> is
 453 NOT called and the current working directory may have been restored to its
 454 saved value).
 455
 456 Note that I<coderef>, if provided, is called B<after> the successful fork and
 457 exec so the newly exec'd process may already be running by then (I<coderef> is
 458 B<never> called if the C<reexec> fails).  I<coderef> receives two arguments,
 459 the first is the old pid (the one calling C<reexec>) and the second is the
 460 new pid (the one the C<exec> call runs in).
 461
 462 If the I<samepid> argument is omitted or is false (recommended) all behaves as
 463 described above.   However, if I<samepid> is true then the C<exec> call runs
 464 from the current pid and I<coderef>, if present, is called (with both arguments
 465 the same) from a double C<fork>'d process to avoid a spurious C<SIGCHLD> (but
 466 still I<only> if the C<reexec> succeeds) otherwise (I<samepid> is true but no
 467 I<coderef> is present) no fork occurs at all, just the C<exec>.  Re-exec'ing
 468 oneself (i.e. keeping the same pid) may result in difficult to diagnose
 469 failures on systems where some kinds of initialization can only be performed
 470 once for any given pid during its lifetime which is why setting I<samepid> to
 471 true is not recommended.
 472
 473 =item $instance->getenv(I<name>)
 474
 475 Return the value of environment variable I<name> saved in the instance or
 476 C<undef> if it's not part of the saved environment.  If the environment
 477 variable I<name> is present in the saved environment then C<undef> will
 478 B<never> be returned.
 479
 480 =item $instance->setenv(I<name>, I<value>)
 481
 482 =item $instance->setenv(I<name>, undef)
 483
 484 =item $instance->delenv(I<name>)
 485
 486 Set the value of environment variable I<name> saved in the instance.  If
 487 I<value> is C<undef> or omitted or C<delenv> used then remove the environment
 488 variable named I<name> from the environment saved in the instance -- it is
 489 no error to remove an environment variable that is not present in the instance.
 490
 491 =back
 492
 493 =head1 COPYRIGHT
 494
 495 Copyright (C) 2016 Kyle J. McKay.  All rights reserved.
 496
 497 License GPLv2+: GNU General Public License version 2 or later.
 498 See comments at top of source file for details.
 499
 500 L<http://www.gnu.org/licenses/gpl-2.0.html>
 501
 502 This is free software: you are free to change and redistribute it.
 503 There is NO WARRANTY, to the extent permitted by law.
 504
 505 =cut