package Proc::Prefork;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(initialisation_complete);
use Carp;
-use POSIX;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
+use IO::FDPass;
+use POSIX qw(_exit setsid);
+use Sys::Syslog;
our $logger;
our @call_fds;
our $socket_path;
+our $fail_log = 0;
+
+sub fail_log ($) {
+ my ($m) = @_;
+ if ($fail_log) {
+ syslog(LOG_ERR, "$0: prefork [$$]: error: $m");
+ } else {
+ croak "$0: prefork: initialisation error: $m";
+ }
+ _exit 127;
+}
sub server_quit ($) {
my ($m) = @_;
_exit(0);
}
+# Returns in the executor process
sub become_monitor () {
-
+ close LISTEN;
+ eval { protocol_exchange(); 1; }
+ or fail_log("protocol exchange failed: $@");
+
+ my $child = fork // fail_log("fork executor: $!");
+ if (!$child) {
+ #---- executor ----
+ open ::STDIN , "<& $call_fds[0]" or fail_log("dup for fd0");
+ open ::STDOUT, ">& $call_fds[1]" or fail_log("dup for fd1");
+ open ::STDERR, ">& $call_fds[2]" or fail_log("dup for fd2");
+ close_call_fds();
+ $! = 0;
+ return;
+ }
+
+ #---- monitor [2] ----
+ my $got = waitpid $child, 0 // fail_log("wait for executor: $!");
+ $got == $child or fail_log("wait for esecutor gave $got, expected $child");
+
+ protocol_write(pack "L", $?);
+ _exit(0);
+}
+
+sub close_call_fds () {
+ foreach (@call_fds) {
+ POSIX::close($_);
+ }
+ close CALL;
+}
+
+sub protocol_write ($) {
+ my ($d) = @_;
+ return if (print CALL $d and flush CALL);
+ _exit(0) if $!==EPIPE || $!==ECONNRESET;
+ fail_log("protocol write: $!");
+}
+
+sub eintr_retry ($) {
+ my ($f) = @_;
+ for (;;) {
+ my $r = $f->();
+ return $r if defined $r;
+ next if $!==EINTR;
+ return $r;
+ }
+}
+
+sub protocol_read_fail ($) {
+ my ($what) = @_;
+ _exit(0) if $!==ECONNRESET;
+ die("recv $what: $!");
+}
+
+sub protocol_exchange () {
+ my $greeting = "PFI\n\0\0\0\0";
+ protocol_write($greeting);
+
+ @call_fds = map {
+ my $r;
+ for (;;) {
+ $! = 0;
+ $r = IO::FDPass::recv(fileno(CALL));
+ last if $r >= 0;
+ _exit(0) if $!==0;
+ protocol_read_fail("fd $_");
+ }
+ $r;
+ } 0..2;
+
+ my $len;
+ $r = read(CALL, $len, 4) // protocol_read_fail("message length");
+ $r == 4 or _exit(0);
+
+ $len = unpack "L", $len;
+ my $data;
+ $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
+ $r == $len or _exit(0);
+
+ @ARGV = split /\0/, $data;
+ @ARGV >= 2 or die("message data has too few strings");
+ length(pop(@ARGV)) and die("message data missing trailing nul");
+ %ENV = ();
+ while (my $s = shift @ARGV) {
+ last if !length $s;
+ $s =~ m/=/ or die("message data env var missing equals");
+ $ENV{$`} = $';
+ }
}
sub initialisation_complete {
my %opts = @_;
# if env var not set, we're not running under prefork-interp
- my @env_params = split /,/, ($ENV{$env_name} // return), 5;
- croak "$env_name has too few entries" unless @env_params == 5;
+ my @env_data = split / /, ($ENV{$env_name} // return), 3;
+ croak "$env_name has the wrong number of words" unless @env_data == 3;
+ my (@vsns) = split /,/, $env_data[0];
+ croak "$env_name doesn't offer protocol v1" unless grep { $_ eq 'v1' } @vsns;
+ my @env_fds = split /,/, $env_data[1];
+ croak "$env_name has too few fds" unless @env_fds >= 3;;
+ $#env_fds = 1;
+ $socket_path = $env_data[2];
$num_servers = $opts{max_servers} // 4;
#---- setup (pm) [1] ----
- $socket_path = pop @env_params;
- foreach (@env_params) {
+ foreach (@env_fds) {
$_ eq ($_+0) or croak "$env_name contains $_, not a number";
}
- open LISTEN, "<>&=$env_params[0]" or croak "listen fd: $!";
- open CALL, "<>&=$env_params[1]" or croak "listen fd: $!";
- @call_fds = ($env_params[2], $env_params[3], 2);
+ open LISTEN, "+>&=$env_fds[0]" or croak "listen fd: $!";
+ open CALL, "+>&=$env_fds[1]" or croak "listen fd: $!";
if (!$opts{no_openlog}) {
openlog("prefork-interp $0", 'ndelay,nofatal,pid',
$opts{log_facility} // 'log_user');
}
- open NULL, "<>/dev/null" or croak "open /dev/null: $!";
+ open NULL, "+>/dev/null" or croak "open /dev/null: $!";
#---- fork for server ----
$child = fork // croak "second fork failed: $!";
if (!$child) {
# we are the child, i.e. the one fa-monitor
- become_monitor();
+ return become_monitor();
}
our %children;
# --- server(pm) [2] ----
- setsid() > 0 or fail("setsid: $!");
- open STDIN, "<&NULL" or fail("dup null onto stdin: $!");
- open STDOUT, ">&NULL" or fail("dup null onto stdout: $!");
- open STDERR, ">&NULL" or fail("dup null onto stderr: $!");
+ $fail_log = 1;
+ setsid() > 0 or fail_log("setsid: $!");
+ open STDIN, "<&NULL" or fail_log("dup null onto stdin: $!");
+ open STDOUT, ">&NULL" or fail_log("dup null onto stdout: $!");
+ open STDERR, ">&NULL" or fail_log("dup null onto stderr: $!");
close NULL;
- POSIX::close($_) foreach @call_fds;
- close CALL;
+ close_call_fds();
- my $flags = fcntl(LISTEN, F_GETFL, 0) or fail("F_GETFL listen socket: $!");
+ my $flags = fcntl(LISTEN, F_GETFL, 0)
+ or fail_log("F_GETFL listen socket: $!");
$flags |= O_NONBLOCK;
- fcntl(LISTEN, F_SETFL, $flags) or fail("F_SETFL listen socket: $!");
+ fcntl(LISTEN, F_SETFL, $flags)
+ or fail_log("F_SETFL listen socket: $!");
my $errcount = 0;
my $rbits = '';
vec($rbits, fileno(LISTEN), 1) = 1;
my $ebits = $rbits;
- my $nfound = select($rbits, '', $ebits, ($opts{check_interval} // 300));
+ my $nfound = select($rbits, '', $ebits, ($opts{check_interval} // 86400));
if ($nfound) {
if (accept(CALL, LISTEN)) {
- $child = fork // fail("fork for accepted call failed: $!");
+ $child = fork // fail_log("fork for accepted call failed: $!");
if (!$child) {
+ #---- monitor [1] ----
become_monitor();
}
close(CALL);
}
# are we still live?
- my @st_listen = stat(LISTEN) // fail("fstat listening socket: $!");
+ my @st_listen = stat(LISTEN) // fail_log("fstat listening socket: $!");
my @st_socket = stat($socket_path) // do {
if ($! == ENOENT) { server_quit("socket $socket is ENOENT"); }
- fail("stat socket $socket: $!");
+ fail_log("stat socket $socket: $!");
};
if ("@st_listen[0..2]" ne "@st_socket[0..2]") {
server_quit("socket $socket is no longer ours");
~ian / chiark-utils.git / blobdiff