prefork-interp: fixes

Signed-off-by: Ian Jackson <ijackson@chiark.greenend.org.uk>

diff --git a/perl/Prefork.pm b/perl/Prefork.pm
index b671ef1d6dbfca33587d00aa6bb8e72d3ff50e63..6792b9a4a1fc8713042bc6575247c59c437fe82f 100644 (file)
--- a/perl/Prefork.pm
+++ b/perl/Prefork.pm
@@ -4,11 +4,13 @@ require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT = qw(initialisation_complete);
 
+use strict;
+
 use Carp;
 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
 use IO::FDPass;
-use POSIX qw(_exit setsid);
-use Sys::Syslog;
+use POSIX qw(_exit setsid :sys_wait_h :errno_h);
+use Sys::Syslog qw(openlog syslog LOG_INFO LOG_ERR LOG_WARNING);
 
 our $logger;
 
@@ -37,25 +39,46 @@ sub server_quit ($) {
 # Returns in the executor process
 sub become_monitor () {
   close LISTEN;
+
+  # Make a process group for this call
+  setpgrp or fail_log("setpgrp failed: $!");
+
   eval { protocol_exchange(); 1; }
     or fail_log("protocol exchange failed: $@");
 
+  pipe EXECTERM, EXECTERMW or fail_log("pipe: $!");
+
   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 EXECTERM;
     close_call_fds();
     $! = 0;
     return;
   }
+  close EXECTERMW;
 
   #---- 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", $?);
+  my $rbits = '';
+  vec($rbits, fileno(CALL), 1) = 1;
+  vec($rbits, fileno(EXECTERM), 1) = 1;
+  my $ebits = $rbits;
+  my $nfound = select($rbits, '', $ebits, undef);
+
+  # Either the child has just died, or the caller has gone away
+
+  $SIG{INT} = 'IGN';
+  kill 'INT', 0 or fail_log("kill executor [$child]: $!");
+
+  my $got = waitpid $child, 0;
+  $got >= 0 // fail_log("wait for executor [$child] (2): $!");
+  $got == $child or fail_log("wait for esecutor [$child] gave [$got]");
+
+  protocol_write(pack "N", $?);
   _exit(0);
 }
 
@@ -106,7 +129,7 @@ sub protocol_exchange () {
   } 0..2;
 
   my $len;
-  $r = read(CALL, $len, 4) // protocol_read_fail("message length");
+  my $r = read(CALL, $len, 4) // protocol_read_fail("message length");
   $r == 4 or _exit(0);
 
   $len = unpack "N", $len;
@@ -137,7 +160,7 @@ sub initialisation_complete {
   croak "$env_name has too few fds" unless @env_fds >= 4;;
   $#env_fds = 1;
 
-  $num_servers = $opts{max_servers} // 4;
+  my $num_servers = $opts{max_servers} // 4;
 
   #---- setup (pm) [1] ----
 
@@ -203,6 +226,8 @@ sub initialisation_complete {
     if (%children) {
       my $full = %children >= $num_servers;
       my $got = waitpid -1, ($full ? 0 : WNOHANG);
+      $got >= 0 or fail_log("failed to wait for monitor(s)");
+      last if $got == 0;
       if ($?) {
        syslog(LOG_WARNING,
  "$0 prefork [$$]: monitor process [$got] failed with wait status $?");
@@ -220,7 +245,10 @@ sub initialisation_complete {
     vec($rbits, fileno(LISTEN), 1) = 1;
     vec($rbits, fileno(WATCHE), 1) = 1;
     my $ebits = $rbits;
-    my $nfound = select($rbits, '', $ebits, ($opts{check_interval} // 86400));
+    my $nfound = select($rbits, '', $ebits, ($opts{idle_timeout} // 1000000));
+
+    # Idle timeout?
+    if (!$nfound) { _exit(0); }
 
     # Has the watcher told us to shut down, or died with a message ?
     my $msgbuf = '';