2 package Proc::Prefork::Interp;
4 our @ISA = qw(Exporter);
5 our @EXPORT = qw(initialisation_complete);
6 our @EXPORT_OK = qw(@autoreload_extra_files);
11 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
13 use POSIX qw(_exit setsid :sys_wait_h :errno_h :signal_h);
14 use Sys::Syslog qw(openlog syslog LOG_INFO LOG_ERR LOG_WARNING);
19 our $env_name = 'PREFORK_INTERP';
26 our @autoreload_extra_files = ();
31 syslog(LOG_ERR, "$0: prefork: error: $m");
33 carp "$0: prefork: initialisation error: $m";
40 syslog(LOG_INFO, "$0 prefork: $m, quitting");
44 # Returns in the executor process
45 sub become_monitor () {
50 # Make a process group for this call
51 setpgrp or fail_log("setpgrp failed: $!");
53 eval { protocol_exchange(); 1; }
54 or fail_log("protocol exchange failed: $@");
56 pipe EXECTERM, EXECTERMW or fail_log("pipe: $!");
58 my $child = fork // fail_log("fork executor: $!");
61 open ::STDIN , "<& $call_fds[0]" or fail_log("dup for fd0");
62 open ::STDOUT, ">& $call_fds[1]" or fail_log("dup for fd1");
63 open ::STDERR, ">& $call_fds[2]" or fail_log("dup for fd2");
71 #---- monitor [2] ----
75 vec($rbits, fileno(CALL), 1) = 1;
76 vec($rbits, fileno(EXECTERM), 1) = 1;
78 my $nfound = select($rbits, '', $ebits, undef);
81 fail_log("monitor select() failed: $!");
84 # Either the child has just died, or the caller has gone away
87 kill 'INT', 0 or fail_log("kill executor [$child]: $!");
89 my $got = waitpid $child, 0;
90 $got >= 0 // fail_log("wait for executor [$child] (2): $!");
91 $got == $child or fail_log("wait for esecutor [$child] gave [$got]");
93 protocol_write(pack "N", $?);
97 sub close_call_fds () {
104 sub protocol_write ($) {
106 return if (print CALL $d and flush CALL);
107 _exit(0) if $!==EPIPE || $!==ECONNRESET;
108 fail_log("protocol write: $!");
111 sub eintr_retry ($) {
115 return $r if defined $r;
121 sub protocol_read_fail ($) {
123 _exit(0) if $!==ECONNRESET;
124 die("recv $what: $!");
127 sub protocol_exchange () {
128 my $greeting = "PFI\n\0\0\0\0";
129 protocol_write($greeting);
134 $r = sysread CALL, $ibyte, 1;
136 $!==EINTR or protocol_read_fail("signalling byte");
140 $ibyte and die(sprintf "signalling byte is 0x%02x, not zero", $ibyte);
146 $r = IO::FDPass::recv(fileno(CALL));
149 protocol_read_fail("fd $_");
155 $r = read(CALL, $len, 4) // protocol_read_fail("message length");
158 $len = unpack "N", $len;
160 $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
161 $r == $len or _exit(0);
163 @ARGV = split /\0/, $data, -1;
164 @ARGV >= 2 or die("message data has too few strings (".(scalar @ARGV).")");
165 length(pop(@ARGV)) and die("message data missing trailing nul");
167 while (my $s = shift @ARGV) {
169 $s =~ m/=/ or die("message data env var missing equals");
174 sub autoreload_check ($) {
176 my @s = Time::HiRes::stat($f);
178 $!==ENOENT or fail_log("autoreload check: stat failed: $f: $!");
181 if ($s[9] > $startup_mtime) {
182 syslog(LOG_INFO, "$0 prefork: reloading; due to $f");
187 sub initialisation_complete {
190 # if env var not set, we're not running under prefork-interp
191 my @env_data = split / /, ($ENV{$env_name} // return);
192 croak "$env_name has too few words" unless @env_data >= 2;
193 my (@vsns) = split /,/, $env_data[0];
194 croak "$env_name doesn't specify v1" unless @vsns >= 2 && $vsns[0] eq 'v1';
195 $startup_mtime = $vsns[1];
196 my @env_fds = split /,/, $env_data[1];
197 croak "$env_name has too few fds" unless @env_fds >= 4;;
200 my $num_servers = $opts{max_servers} // 4;
202 #---- setup (pm) [1] ----
205 $_ eq ($_+0) or croak "$env_name contains $_, not a number";
207 open LISTEN, "+>&=$env_fds[0]" or croak "listen fd: $!";
208 open CALL, "+>&=$env_fds[1]" or croak "call fd: $!";
209 open WATCHI, "+>&=$env_fds[2]" or croak "call fd: $!";
210 open WATCHE, "+>&=$env_fds[3]" or croak "watch stderr fd: $!";
212 if (!$opts{no_openlog}) {
213 openlog("prefork-interp $0", 'ndelay,nofatal,pid',
214 $opts{log_facility} // 'log_user');
217 open NULL, "+>/dev/null" or croak "open /dev/null: $!";
219 #---- fork for server ----
221 my $child = fork // croak "first fork failed: $!";
223 #---- setup (pm) [2], exits ----
226 setsid() > 0 or fail_log("setsid: $!");
227 # The server will be a session leader, but it won't open ttys,
230 #---- server(pm) [1] ----
232 $child = fork // croak "second fork failed: $!";
234 # we are the child, i.e. the one fa-monitor
235 local $0 = "$0 [monitor(init)]";
236 return become_monitor();
241 $children{$child} = 1;
243 # --- server(pm) [2] ----
245 local $0 = "$0 [server]";
248 open STDIN, "<&NULL" or fail_log("dup null onto stdin: $!");
249 open STDOUT, ">&NULL" or fail_log("dup null onto stdout: $!");
250 open STDERR, ">&NULL" or fail_log("dup null onto stderr: $!");
258 my $full = %children >= $num_servers;
259 my $got = waitpid -1, ($full ? 0 : WNOHANG);
260 $got >= 0 or fail_log("failed to wait for monitor(s): $!");
262 if ($? && $? != SIGPIPE) {
264 "$0 prefork: monitor process [$got] failed with wait status $?");
266 if (!exists $children{$got}) {
268 "$0 prefork: monitor process [$got] wasn't one of ours?!");
270 delete $children{$got};
275 # select for accepting or housekeeping timeout
277 vec($rbits, fileno(LISTEN), 1) = 1;
278 vec($rbits, fileno(WATCHE), 1) = 1;
280 my $nfound = select($rbits, '', $ebits, ($opts{idle_timeout} // 1000000));
283 last if $nfound == 0;
286 fail_log("select failed: $!");
289 # Has the watcher told us to shut down, or died with a message ?
291 my $r = sysread WATCHE, $msgbuf, 2048;
294 fail_log("watcher: $msgbuf");
295 } elsif (defined $r) {
297 "$0 prefork: lost socket (fresh start or cleanup?), quitting");
299 } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
301 fail_log("watcher stderr read: $!");
304 if (%opts{autoreload_inc} // 1) {
305 foreach my $f (values %INC) {
306 autoreload_check($f);
309 foreach my $f (@autoreload_extra_files) {
310 autoreload_check($f);
312 foreach my $f (@{ %opts{autoreload_extra} // [] }) {
313 autoreload_check($f);
316 # Anything to accept ?
317 if (accept(CALL, LISTEN)) {
318 $child = fork // fail_log("fork for accepted call failed: $!");
320 #---- monitor [1] ----
321 $0 =~ s{ \[server\]$}{ [monitor]};
322 return become_monitor();
326 $children{$child} = 1;
327 } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
329 syslog(LOG_WARNING, "$0 prefork: accept failed: $!");
330 if ($errcount > ($opts{max_errors} // 100)) {
331 fail_log("too many accept failures, quitting");