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