--- /dev/null
+
+package Proc::Prefork::Interp;
+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 :sys_wait_h :errno_h :signal_h);
+use Sys::Syslog qw(openlog syslog LOG_INFO LOG_ERR LOG_WARNING);
+use Time::HiRes qw();
+
+our $logger;
+
+our $env_name = 'PREFORK_INTERP';
+
+our @call_fds;
+our $socket_path;
+our $fail_log = 0;
+our $startup_mtime;
+
+sub fail_log ($) {
+ my ($m) = @_;
+ if ($fail_log) {
+ syslog(LOG_ERR, "$0: prefork: error: $m");
+ } else {
+ carp "$0: prefork: initialisation error: $m";
+ }
+ _exit 127;
+}
+
+sub server_quit ($) {
+ my ($m) = @_;
+ syslog(LOG_INFO, "$0 prefork: $m, quitting");
+ _exit(0);
+}
+
+# Returns in the executor process
+sub become_monitor () {
+ close LISTEN;
+ close WATCHI;
+ close WATCHE;
+
+ # 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] ----
+
+ for (;;) {
+ my $rbits = '';
+ vec($rbits, fileno(CALL), 1) = 1;
+ vec($rbits, fileno(EXECTERM), 1) = 1;
+ my $ebits = $rbits;
+ my $nfound = select($rbits, '', $ebits, undef);
+ last if $nfound > 0;
+ next if $! == EINTR;
+ fail_log("monitor select() failed: $!");
+ }
+
+ # 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);
+}
+
+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);
+
+ my $ibyte = 0;
+ my $r;
+ for (;;) {
+ $r = sysread CALL, $ibyte, 1;
+ last if $r > 0;
+ $!==EINTR or protocol_read_fail("signalling byte");
+ }
+ $r == 1 or _exit(0);
+ $ibyte = ord $ibyte;
+ $ibyte and die(sprintf "signalling byte is 0x%02x, not zero", $ibyte);
+
+ @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 "N", $len;
+ my $data;
+ $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
+ $r == $len or _exit(0);
+
+ @ARGV = split /\0/, $data, -1;
+ @ARGV >= 2 or die("message data has too few strings (".(scalar @ARGV).")");
+ 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 autoreload_check ($) {
+ my ($f) = @_;
+ my @s = Time::HiRes::stat($f);
+ if (!@s) {
+ $!==ENOENT or fail_log("autoreload check: stat failed: $f: $!");
+ return;
+ }
+ if ($s[9] > $startup_mtime) {
+ syslog(LOG_INFO, "$0 prefork: reloading; due to $f");
+ _exit(0);
+ }
+}
+
+sub initialisation_complete {
+ my %opts = @_;
+
+ # if env var not set, we're not running under prefork-interp
+ my @env_data = split / /, ($ENV{$env_name} // return);
+ croak "$env_name has too few words" unless @env_data >= 2;
+ my (@vsns) = split /,/, $env_data[0];
+ croak "$env_name doesn't specify v1" unless @vsns >= 2 && $vsns[0] eq 'v1';
+ $startup_mtime = $vsns[1];
+ my @env_fds = split /,/, $env_data[1];
+ croak "$env_name has too few fds" unless @env_fds >= 4;;
+ $#env_fds = 3;
+
+ my $num_servers = $opts{max_servers} // 4;
+
+ #---- setup (pm) [1] ----
+
+ foreach (@env_fds) {
+ $_ eq ($_+0) or croak "$env_name contains $_, not a number";
+ }
+ open LISTEN, "+>&=$env_fds[0]" or croak "listen fd: $!";
+ open CALL, "+>&=$env_fds[1]" or croak "call fd: $!";
+ open WATCHI, "+>&=$env_fds[2]" or croak "call fd: $!";
+ open WATCHE, "+>&=$env_fds[3]" or croak "watch stderr 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: $!";
+
+ #---- fork for server ----
+
+ my $child = fork // croak "first fork failed: $!";
+ if ($child) {
+ #---- setup (pm) [2], exits ----
+ _exit(0);
+ }
+ setsid() > 0 or fail_log("setsid: $!");
+ # The server will be a session leader, but it won't open ttys,
+ # so that is ok.
+
+ #---- server(pm) [1] ----
+
+ $child = fork // croak "second fork failed: $!";
+ if (!$child) {
+ # we are the child, i.e. the one fa-monitor
+ local $0 = "$0 [monitor(init)]";
+ return become_monitor();
+ }
+ close CALL;
+
+ our %children;
+ $children{$child} = 1;
+
+ # --- server(pm) [2] ----
+
+ local $0 = "$0 [server]";
+
+ $fail_log = 1;
+ 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;
+
+ my $errcount = 0;
+
+ for (;;) {
+ # reap children
+ 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): $!");
+ if ($got) {
+ if ($? && $? != SIGPIPE) {
+ syslog(LOG_WARNING,
+ "$0 prefork: monitor process [$got] failed with wait status $?");
+ }
+ if (!exists $children{$got}) {
+ syslog(LOG_WARNING,
+ "$0 prefork: monitor process [$got] wasn't one of ours?!");
+ }
+ delete $children{$got};
+ next;
+ }
+ }
+
+ # select for accepting or housekeeping timeout
+ my $rbits = '';
+ vec($rbits, fileno(LISTEN), 1) = 1;
+ vec($rbits, fileno(WATCHE), 1) = 1;
+ my $ebits = $rbits;
+ my $nfound = select($rbits, '', $ebits, ($opts{idle_timeout} // 1000000));
+
+ # Idle timeout?
+ last if $nfound == 0;
+ if ($nfound < 0) {
+ next if $! == EINTR;
+ fail_log("select failed: $!");
+ }
+
+ # Has the watcher told us to shut down, or died with a message ?
+ my $msgbuf = '';
+ my $r = sysread WATCHE, $msgbuf, 2048;
+ if ($r > 0) {
+ chomp $msgbuf;
+ fail_log("watcher: $msgbuf");
+ } elsif (defined $r) {
+ syslog(LOG_INFO,
+ "$0 prefork: lost socket (fresh start or cleanup?), quitting");
+ last;
+ } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
+ } else {
+ fail_log("watcher stderr read: $!");
+ }
+
+ if (%opts{autoreload_inc} // 1) {
+ foreach my $f (values %INC) {
+ autoreload_check($f);
+ }
+ }
+ foreach my $f (@{ %opts{autoreload_extra} // [] }) {
+ autoreload_check($f);
+ }
+
+ # Anything to accept ?
+ if (accept(CALL, LISTEN)) {
+ $child = fork // fail_log("fork for accepted call failed: $!");
+ if (!$child) {
+ #---- monitor [1] ----
+ $0 =~ s{ \[server\]$}{ [monitor]};
+ return become_monitor();
+ }
+ close(CALL);
+ $errcount = 0;
+ $children{$child} = 1;
+ } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
+ } else {
+ syslog(LOG_WARNING, "$0 prefork: accept failed: $!");
+ if ($errcount > ($opts{max_errors} // 100)) {
+ fail_log("too many accept failures, quitting");
+ }
+ }
+ }
+ _exit(0);
+}
+
+1;
+
+__END__
~ian / chiark-utils.git / blobdiff