prefork-interp: fixes and tests

[chiark-utils.git] / perl / Prefork.pm

diff --git a/perl/Prefork.pm b/perl/Prefork.pm
index 162d5e471f5161571bd992e27e25daca2f3833df..8de4aaf314d266b2583005d7ddcb4e7114a07d13 100644 (file)
--- a/perl/Prefork.pm
+++ b/perl/Prefork.pm
@@ -1,9 +1,13 @@
 
 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 POSIX;
+use Sys::Syslog;
 
 our $logger;
 
@@ -18,8 +22,83 @@ sub server_quit ($) {
   _exit(0);
 }
 
+# Returns in the executor process
 sub become_monitor () {
-  
+  my $child = fork // fail("fork executor: $!");
+  if (!$child) {
+    #---- executor ----
+    open ::STDIN , "<& $call_fds[0]" or fail("dup for fd0");
+    open ::STDOUT, ">& $call_fds[1]" or fail("dup for fd1");
+    open ::STDERR, ">& $call_fds[2]" or fail("dup for fd2");
+    POSIX::close($_) foreach @call_fds;
+    close CALL;
+    return;
+  }
+
+  #---- monitor [2] ----
+  my $got = waitpid $child, 0 // fail("wait for executor: $!");
+  $got == $child or fail("wait for esecutor gave $got, expected $child");
+
+  protocol_write(pack "L", $?);
+  _exit(0);
+}
+
+sub protocol_write ($) {
+  my ($d) = @_;
+  return if (print CALL $d and flush CALL);
+  _exit(0) if $!==EPIPE || $!==ECONNRESET;
+  fail("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;
+  fail("recv $what: $!");
+}
+
+sub protocol_exchange () {
+  protocol_write('\n');
+
+  @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 fail("message data has too few strings");
+  length(pop(@ARGV)) and fail("message data missing trailing nul");
+  %ENV = ();
+  while (my $s = shift @ARGV) {
+    last if !length $s;
+    $s =~ m/=/ or fail("message data env var missing equals");
+    $ENV{$`} = $';
+  }
 }
 
 sub initialisation_complete {
@@ -37,8 +116,8 @@ sub initialisation_complete {
   foreach (@env_params) {
     $_ 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: $!";
+  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);
 
   if (!$opts{no_openlog}) {
@@ -46,7 +125,7 @@ sub initialisation_complete {
            $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 ----
 
@@ -61,7 +140,7 @@ sub initialisation_complete {
   $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;
@@ -111,7 +190,10 @@ sub initialisation_complete {
       if (accept(CALL, LISTEN)) {
        $child = fork // fail("fork for accepted call failed: $!");
        if (!$child) {
-         become_monitor();
+         #---- monitor [1] ----
+         close LISTEN;
+         protocol_exchange();
+         return become_monitor();
        }
        close(CALL);
        $errcount = 0;