install.sh: verify correct install user
[girocco.git] / Girocco / ExecUtil.pm
blob590d238db78bdc4acef55921bc0fd2ae4bed01ba
1 # Girocco::ExecUtil.pm -- utility to assist with re-exec'ing oneself
2 # Copyright (C) 2016 Kyle J. McKay. All rights reserved.
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.
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.
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.
20 package Girocco::ExecUtil;
22 use strict;
23 use warnings;
24 use Cwd;
25 use POSIX qw(_exit);
26 use File::Spec ();
28 use base qw(Exporter);
29 use vars qw(@EXPORT @EXPORT_OK $VERSION);
31 BEGIN {
32 @EXPORT = qw(daemon);
33 @EXPORT_OK = qw();
34 *VERSION = \'1.0';
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;
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 };
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;
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;
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;
100 $SIG{'CHLD'} = $oldsigchld;
101 return undef;
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;
113 if (!defined($child2)) {
114 my $ec = 0 + $!;
115 $ec = 255 unless $ec;
116 print $write2 ":$ec";
117 close $write2;
118 _exit 127;
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;
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;
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;
160 # reap the child and set $child to grandchild's pid
161 waitpid($child, 0);
162 $child = $result;
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;
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;
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;
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;
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;
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 = "";
240 $result;
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};
253 sub delenv {
254 my $self = shift;
255 $self->setenv($_[0], undef);
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;
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;
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;
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;
299 if (!defined($child2)) {
300 my $ec = 0 + $!;
301 $ec = 255 unless $ec;
302 print $write2 ":$ec";
303 close $write2;
304 _exit 127;
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;
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;
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;
337 # reap the child and set $child to grandchild's pid
338 waitpid($child, 0);
339 $child = $result;
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;
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;
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
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
377 __END__
379 =head1 NAME
381 Girocco::ExecUtil - Re-execution utility
383 =head1 SYNOPSIS
385 use Girocco::ExecUtil;
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;
392 =head1 DESCRIPTION
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,
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.
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.
408 The following functions are provided:
410 =over 4
412 =item daemon(I<nochdir>, I<noclose>)
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.
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.
426 =item Girocco::ExecUtil->new
428 =item Girocco::ExecUtil->new(I<program>)
430 =item Girocco::ExecUtil->new(I<program>, I<argv0>)
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]>.
439 =item $instance->reexec(I<samepid>)
441 =item $instance->reexec(I<coderef>, I<samepid>)
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).
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).
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).
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.
468 =item $instance->getenv(I<name>)
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.
475 =item $instance->setenv(I<name>, I<value>)
477 =item $instance->setenv(I<name>, undef)
479 =item $instance->delenv(I<name>)
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.
486 =back
488 =head1 COPYRIGHT
490 Copyright (C) 2016 Kyle J. McKay. All rights reserved.
492 License GPLv2+: GNU General Public License version 2 or later.
493 See comments at top of source file for details.
495 L<http://www.gnu.org/licenses/gpl-2.0.html>
497 This is free software: you are free to change and redistribute it.
498 There is NO WARRANTY, to the extent permitted by law.
500 =cut