perl/Prefork.pm

   1
   2 package Proc::Prefork;
   3
   4 use Carp;
   5 use POSIX;
   6 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
   7
   8 our $logger;
   9
  10 our $env_name = 'PREFORK_INTERP';
  11
  12 our @call_fds;
  13 our $socket_path;
  14
  15 sub server_quit ($) {
  16   my ($m) = @_;
  17   syslog(LOG_INFO, "$0 prefork [$$]: $m, quitting");
  18   _exit(0);
  19 }
  20
  21 sub become_monitor () {
  22
  23 }
  24
  25 sub initialisation_complete {
  26   my %opts = @_;
  27
  28   # if env var not set, we're not running under prefork-interp
  29   my @env_params = split /,/, ($ENV{$env_name} // return), 5;
  30   croak "$env_name has too few entries" unless @env_params == 5;
  31
  32   $num_servers = $opts{max_servers} // 4;
  33
  34   #---- setup (pm) [1] ----
  35
  36   $socket_path = pop @env_params;
  37   foreach (@env_params) {
  38     $_ eq ($_+0) or croak "$env_name contains $_, not a number";
  39   }
  40   open LISTEN, "<>&=$env_params[0]" or croak "listen fd: $!";
  41   open CALL,   "<>&=$env_params[1]" or croak "listen fd: $!";
  42   @call_fds = ($env_params[2], $env_params[3], 2);
  43
  44   if (!$opts{no_openlog}) {
  45     openlog("prefork-interp $0", 'ndelay,nofatal,pid',
  46             $opts{log_facility} // 'log_user');
  47   }
  48
  49   open NULL, "<>/dev/null" or croak "open /dev/null: $!";
  50
  51   #---- fork for server ----
  52
  53   my $child = fork // croak "first fork failed: $!";
  54   if ($child) {
  55     #---- setup (pm) [2], exits ----
  56     _exit(0);
  57   }
  58
  59   #---- server(pm) [1] ----
  60
  61   $child = fork // croak "second fork failed: $!";
  62   if (!$child) {
  63     # we are the child, i.e. the one fa-monitor
  64     become_monitor();
  65   }
  66
  67   our %children;
  68   $children{$child} = 1;
  69
  70   # --- server(pm) [2] ----
  71
  72   setsid() > 0 or fail("setsid: $!");
  73   open STDIN, "<&NULL" or fail("dup null onto stdin: $!");
  74   open STDOUT, ">&NULL" or fail("dup null onto stdout: $!");
  75   open STDERR, ">&NULL" or fail("dup null onto stderr: $!");
  76   close NULL;
  77
  78   POSIX::close($_) foreach @call_fds;
  79   close CALL;
  80
  81   my $flags = fcntl(LISTEN, F_GETFL, 0) or fail("F_GETFL listen socket: $!");
  82   $flags |= O_NONBLOCK;
  83   fcntl(LISTEN, F_SETFL, $flags) or fail("F_SETFL listen socket: $!");
  84
  85   my $errcount = 0;
  86
  87   for (;;) {
  88     # reap children
  89     if (%children) {
  90       my $full = %children >= $num_servers;
  91       my $got = waitpid -1, ($full ? 0 : WNOHANG);
  92       if ($?) {
  93         syslog(LOG_WARNING,
  94  "$0 prefork [$$]: monitor process [$got] failed with wait status $?");
  95       }
  96       if (!exists $children{$got}) {
  97         syslog(LOG_WARNING,
  98  "$0 prefork [$$]: monitor process [$got] wasn't one of ours?!");
  99       }
 100       delete $children{$got};
 101       next;
 102     }
 103
 104     # select for accepting or housekeeping timeout
 105     my $rbits = '';
 106     vec($rbits, fileno(LISTEN), 1) = 1;
 107     my $ebits = $rbits;
 108     my $nfound = select($rbits, '', $ebits, ($opts{check_interval} // 300));
 109
 110     if ($nfound) {
 111       if (accept(CALL, LISTEN)) {
 112         $child = fork // fail("fork for accepted call failed: $!");
 113         if (!$child) {
 114           become_monitor();
 115         }
 116         close(CALL);
 117         $errcount = 0;
 118         $children{$child} = 1;
 119       } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
 120       } else {
 121         syslog(LOG_WARNING, "$0 prefork [$$]: accept failed: $!");
 122         if ($errcount > ($opts{max_errors} // 100)) {
 123           syslog(LOG_ERR,
 124                  "$0 prefork [$$]: too many accept failures, quitting");
 125           _exit(16);
 126         }
 127       }
 128       next;
 129     }
 130
 131     # are we still live?
 132     my @st_listen = stat(LISTEN) // fail("fstat listening socket: $!");
 133     my @st_socket = stat($socket_path) // do {
 134       if ($! == ENOENT) { server_quit("socket $socket is ENOENT"); }
 135       fail("stat socket $socket: $!");
 136     };
 137     if ("@st_listen[0..2]" ne "@st_socket[0..2]") {
 138       server_quit("socket $socket is no longer ours");
 139     }
 140   }
 141 }
 142
 143 1;
 144
 145 __END__