/code/sloop_server.pm
Perl | 262 lines | 151 code | 58 blank | 53 comment | 23 complexity | 3e6e0c5c8956761d0e43eca172a0d7ce MD5 | raw file
- package sloop_server;
- use strict;
- use file;
- use signal;
- use sloop_client;
- use sloop_config;
- use sloop_io;
- use sloop_status;
- use sloop_top;
- use POSIX "sys_wait_h"; # for the WNOHANG constant
- use Socket;
- # LATER 0331 do we get a catchable signal when shutting down this machine?
- # I noticed that the pid file wasn't getting cleared.
- =pod
- =head1 NAME
- sloop_listen - Listen for inbound connections and fork handler process
- The main server loop. Listen for incoming connections and handle them.
- Continue doing this until the process sees a TERM or INT interrupt signal.
- =head1 REFERENCES
- =item http://www.unix.org.ua/orelly/perl/prog/ch06_02.htm#PERL2-CH-6-SECT-2.4.1
- =item http://www.unix.com.ua/orelly/perl/cookbook/ch16_20.htm
- =item http://www.unix.org.ua/orelly/perl/cookbook/ch17_03.htm
- =cut
- sub sloop_listen
- {
- my $host_port = sloop_config::get("host_port");
- my $host_ip = sloop_config::get("host_ip");
- my $max_children = sloop_config::get("max_children");
- # Create the server listener socket.
- my $server_socket;
- my $proto = getprotobyname('tcp');
- socket($server_socket, PF_INET, SOCK_STREAM, $proto)
- or die "Could not create the listener socket: $!";
- # Set flags so we can restart our server quickly (reuse the bind addr).
- setsockopt($server_socket, SOL_SOCKET, SO_REUSEADDR, 1);
- # Build socket address and bind server to it.
- my $host_addr = $host_ip eq "*" ? INADDR_ANY : inet_aton($host_ip);
- my $server_addr = sockaddr_in($host_port,$host_addr);
- bind($server_socket, $server_addr)
- or die "Could not bind to port $host_port : $!\n";
- # Establish a queue for incoming connections.
- listen($server_socket, SOMAXCONN)
- or die "Could not listen on port $host_port : $!\n";
- # Accept and process connections.
- while (1)
- {
- if (signal::get_child())
- {
- # CHLD signal: At least one child process exited. Wait for all
- # children to exit to avoid zombies.
- while (1)
- {
- my $child = waitpid(-1, &WNOHANG);
- last if $child <= 0;
- if (WIFEXITED($?))
- {
- # The $child process actually exited.
- # my $exit_code = ($? >> 8); # if you're interested
- sloop_status::child_exits($child);
- }
- else
- {
- # The $child process temporarily stopped due to some other
- # condition (suspension, SIGSTOP). I've tested SIGSTOP
- # and SIGCONT and haven't made this condition happen, but
- # the Perl Cookbook says we should check WIFEXITED so
- # that's what I did.
- }
- }
- signal::put_child(0);
- }
- my $client_socket;
- my $remote_addr = accept($client_socket, $server_socket);
- last if signal::get_interrupt();
- # INT or TERM signal: Exit immediately.
- if (!$remote_addr)
- {
- print STDERR "error in accept : $!\n" if !signal::get_child();
- next;
- }
- # Received new inbound connection. Fork a handler process if we
- # have the capacity.
- if (sloop_status::num_children() >= $max_children)
- {
- close($client_socket);
- next;
- }
- my $child = fork;
- if (!defined $child)
- {
- # Too many processes.
- print STDERR "fork error: $!\n";
- close($client_socket);
- }
- elsif ($child != 0)
- {
- # This is the parent process.
- sloop_status::child_enters($child);
- close($client_socket);
- }
- else
- {
- # This is the child process.
- close($server_socket);
- sloop_io::init($client_socket);
- sloop_client::respond();
- close($client_socket);
- exit;
- }
- }
- close($server_socket);
- # Now send a TERM signal to all the children to terminate them.
- kill 'TERM', sloop_status::children();
- return;
- }
- # Stop the currently running server process, making sure it is actually gone
- # from the "ps" listing before returning. That's the only way to guarantee
- # that the listening socket is fully released, allowing us to restart the
- # server immediately without getting a "bind: Address already in use" error.
- # Return false if the process fails to exit after waiting 2 minutes.
- sub sloop_stop
- {
- my ($curr_pid) = sloop_status::info();
- return 1 if $curr_pid eq "";
- system("kill $curr_pid");
- my $beg_time = time;
- my $warn_time = $beg_time;
- while (1)
- {
- my $found_process = 0;
- my $fh;
- open($fh, "ps -p $curr_pid|") or die "error: $!";
- while (<$fh>)
- {
- chomp;
- my $line = $_;
- $line =~ s/^\s+//;
- $line =~ s/\s+$//;
- my ($pid,$dev,$time,$name) = split(/\s+/, $line);
- next if $pid ne $curr_pid;
- $found_process = 1;
- last;
- }
- close($fh);
- last if !$found_process; # process is gone
- my $time = time;
- my $elapse = $time - $beg_time;
- if ($elapse >= 120)
- {
- print STDERR "Gave up after $elapse seconds, sorry.\n";
- return 0;
- }
- if ($time - $warn_time >= 10)
- {
- $warn_time = $time;
- print STDERR "Still waiting for old process $curr_pid "
- ."to exit after $elapse seconds ...\n";
- }
- sleep(1);
- }
- return 1;
- }
- # Start the server running in the background and loop until terminated.
- sub sloop_start
- {
- my $child = fork;
- if (!defined $child)
- {
- # The fork failed, probably because too many processes are running.
- print STDERR "The server failed to start because of this error: $!\n";
- exit(1);
- }
- elsif ($child != 0)
- {
- # The parent process does nothing.
- exit(0);
- }
- # This is the child process, which runs in the background and implements
- # the server.
- sloop_status::start();
- sloop_listen();
- sloop_status::stop();
- return;
- }
- # Run the listener loop. The listener accepts inbound connections and forks a
- # child process to handle them.
- sub respond
- {
- my $do_start = shift;
- signal::init();
- sloop_status::init();
- return if !sloop_stop(); # Stop the server if already running.
- sloop_start() if $do_start;
- return;
- }
- return 1;