bitjoe - Contrib - Contrib - ch15 - SOURCE CODE

package Daemon;
# file Daemon.pm
# Figure 14.7:  Daemon.pm module with support for restarting the server

# NOTE: this is the full-featured version of the Daemon module from the end
# of chapter 14.  See Daemon1.pm for the simpler version.

use strict;
use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION);

use POSIX qw(:signal_h setsid WNOHANG);
use Carp 'croak','cluck';
use Carp::Heavy;
use File::Basename;
use IO::File;
use Cwd;
use Sys::Syslog qw(:DEFAULT setlogsock);
require Exporter;

@EXPORT_OK = qw(init_server prepare_child kill_children 
                launch_child do_relaunch
                log_debug log_notice log_warn 
                log_die %CHILDREN);
@EXPORT = @EXPORT_OK;
@ISA = qw(Exporter);
$VERSION = '1.00';

use constant PIDPATH  => '/var/run';
use constant FACILITY => 'local0';
use vars qw(%CHILDREN);
my ($pid,$pidfile,$saved_dir,$CWD);

sub init_server {
  my ($user,$group);
  ($pidfile,$user,$group) = @_;
  $pidfile ||= getpidfilename();
  my $fh = open_pid_file($pidfile);
  become_daemon();
  print $fh $$;
  close $fh;
  init_log();
  change_privileges($user,$group) if defined $user && defined $group;
  return $pid = $$;
}

sub become_daemon {
  croak "Can't fork" unless defined (my $child = fork);
  exit 0 if $child;    # parent dies;
  POSIX::setsid();     # become session leader
  open(STDIN,"</dev/null");

... [truncated, 117 more lines] ...

package Web;
# file: Web.pm
# Figure 15.1: Core Web Server Routines

# utility routines for a minimal web server.
# handle_connection() and docroot() are only exported functions

use strict;
use vars '@ISA','@EXPORT';
require Exporter;

@ISA = 'Exporter';
@EXPORT = qw(handle_connection docroot);

my $DOCUMENT_ROOT = '/home/www/htdocs';
my $CRLF = "\015\012";

sub handle_connection {
  my $c = shift;   # socket
  my ($fh,$type,$length,$url,$method);
  local $/ = "$CRLF$CRLF";   # set end-of-line character
  my $request = <$c>;        # read the request header

  return invalid_request($c) 
    unless ($method,$url) = $request =~ m!^(GET|HEAD) (/.*) HTTP/1\.[01]!;
  return not_found($c) unless ($fh,$type,$length) = lookup_file($url);
  return redirect($c,"$url/") if $type eq 'directory';

  # print the header
  print $c "HTTP/1.0 200 OK$CRLF";
  print $c "Content-length: $length$CRLF";
  print $c "Content-type: $type$CRLF";
  print $c $CRLF;

  return unless $method eq 'GET';

  # print the content
  my $buffer;
  while ( read($fh,$buffer,1024) ) {
    print $c $buffer;
  }
  close $fh;
}

sub lookup_file {
  my $url = shift;
  my $path = $DOCUMENT_ROOT . $url;               # turn into a path
  $path =~ s/\?.*$//;                             # get rid of query
  $path =~ s/\#.*$//;                             # get rid of fragment
  $path .= 'index.html' if $url=~m!/$!;           # get index.html if path ends in /

... [truncated, 66 more lines] ...

#!/usr/bin/perl -w
# prefork_pipe.pl
# Figure 14.7 Preforking server using a pipe for interprocess communication

use strict;
use IO::Socket;
use IO::File;
use IO::Select;
use Fcntl ':flock';
use Daemon;
use Web;

use constant PREFORK_CHILDREN  => 3;
use constant MAX_REQUEST       => 30;
use constant PIDFILE           => "/tmp/prefork.pid";
use constant HI_WATER_MARK     => 5;
use constant LO_WATER_MARK     => 2;
use constant DEBUG             => 1;

my $DONE        = 0;   # set flag to true when server done
my %STATUS      = ();

$SIG{INT}  = $SIG{TERM} = sub { $DONE++ };

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => SOMAXCONN,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";

# create a pipe for IPC
pipe(CHILD_READ,CHILD_WRITE) or die "Can't make pipe!\n";
my $IN = IO::Select->new(\*CHILD_READ);

# create PID file, initialize logging, and go into background
init_server(PIDFILE);

# prefork some children
make_new_child() for (1..PREFORK_CHILDREN);  

while (!$DONE) {

  if ($IN->can_read) { # got a message from one of the children
    my $message;
    next unless sysread(CHILD_READ,$message,4096);
    my @messages = split "\n",$message;
    foreach (@messages) {
      next unless my ($pid,$status) = /^(\d+) (.+)$/;
      if ($status ne 'done') {
        $STATUS{$pid} = $status;
      } else {

... [truncated, 66 more lines] ...

#!/usr/bin/perl -w
# prefork_shm.pl
# Figure 14.8: An adaptive preforking server using shared memory

use strict;
use IO::Socket;
use IO::File;
use Fcntl ':flock';
use IPC::Shareable;
use Daemon;
use Web;

use constant PREFORK_CHILDREN  => 3;
use constant MAX_REQUEST       => 30;
use constant PIDFILE           => "/tmp/prefork.pid";
use constant HI_WATER_MARK     => 5;
use constant LO_WATER_MARK     => 2;
use constant SHM_GLUE          => 'PREf';
use constant DEBUG             => 1;

my $DONE        = 0;   # set flag to true when server done
my %STATUS      = ();

$SIG{INT}  = $SIG{TERM} = sub { $DONE++ };
$SIG{ALRM} = sub {};   # receive alarm clock signals, but do nothing

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => SOMAXCONN,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";
# create PID file, initialize logging, and go into background
init_server(PIDFILE);

# create a shared memory segment for child status
tie(%STATUS,'IPC::Shareable',SHM_GLUE,{ create=>1,exclusive=>1,destroy=>1,mode => 0600})
  or die "Can't tie \%STATUS to shared memory: $!";

# prefork some children
make_new_child() for (1..PREFORK_CHILDREN);  # prefork children

while (!$DONE) {
  sleep;  # sleep until a signal arrives (alarm clock or CHLD)

  # get the list of idle children
  warn join(' ', map {"$_=>$STATUS{$_}"} keys %STATUS),"\n" if DEBUG;
  my @idle = sort {$a <=> $b} grep {$STATUS{$_} eq 'idle'} keys %STATUS;

  if (@idle < LO_WATER_MARK) {
    make_new_child() for (0..LO_WATER_MARK-@idle-1);  # bring the number up
  } elsif (@idle > HI_WATER_MARK) {

... [truncated, 57 more lines] ...

#!/usr/bin/perl -w
# file: web_fork.pl
# Figure 14.3: A forking web server

use strict;
use IO::Socket;
use IO::File;
use IO::Select;
use Daemon;
use Web;

use constant PIDFILE => '/tmp/web_fork.pid';

my $DONE = 0;
$SIG{INT}  = $SIG{TERM} = sub { $DONE++ };

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => SOMAXCONN,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";
my $IN = IO::Select->new($socket);

# create PID file, initialize logging, and go into the background
init_server(PIDFILE);

warn "Listening for connections on port $port\n";

# accept loop
while (!$DONE) {
  next unless $IN->can_read;
  next unless my $c = $socket->accept;
  my $child = launch_child();
  unless ($child) {
    close $socket;
    handle_connection($c);
    exit 0;
  }
  close $c;
}

warn "Normal termination\n";

#!/usr/bin/perl -w
# web_prefork1.pl
# Figure 14.4: Preforking web server, version 1

use IO::Socket;
use IO::File;
use Daemon;
use Web;

use constant PIDFILE          => "/tmp/prefork.pid";
use constant PREFORK_CHILDREN  => 5;

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => 100,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";

# create PID file, initialize logging, and go into background
init_server(PIDFILE);

make_new_child() for (1..PREFORK_CHILDREN);
exit 0;

sub make_new_child {
  my $child = launch_child();
  return if $child;
  do_child($socket);      # child handles incoming connections
  exit 0;
}

sub do_child {
  my $socket = shift;
  while (1) {
    next unless my $c = $socket->accept;
    handle_connection($c);
    close $c;
  }
  close $socket;
}

#!/usr/bin/perl -w
# web_prefork2.pl
# Figure 14.5: This preforking server serializes accept() and
#              relaunches new children to replace old ones

use strict;
use IO::Socket;
use IO::File;
use Fcntl ':flock';
use Daemon;
use Web;

use constant PREFORK_CHILDREN  => 5;
use constant MAX_REQUEST       => 30;
use constant PIDFILE           => "/tmp/prefork.pid";
use constant DEBUG             => 1;

my $CHILD_COUNT = 0;   # number of children
my $DONE        = 0;   # set flag to true when server done

$SIG{INT}  = $SIG{TERM} = sub { $DONE++ };

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => SOMAXCONN,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";

# create PID file, initialize logging, and go into background
init_server(PIDFILE);

while (!$DONE) {
  make_new_child() while $CHILD_COUNT < PREFORK_CHILDREN;
  sleep;         # wait for a signal
}

kill_children();
warn "normal termination\n" if DEBUG;
exit 0;

sub make_new_child {
  my $child = launch_child(\&cleanup_child);
  if ($child) {  # child > 0, so we're the parent
    warn "launching child $child\n" if DEBUG;
    $CHILD_COUNT++;
  } else {
    do_child($socket);      # child handles incoming connections
    exit 0;                 # child is done
  }
}


... [truncated, 21 more lines] ...

#!/usr/bin/perl -w
# web_prethread1.pl
# Figure 14.10: Prethreaded Web Server

use strict;
use IO::Socket;
use IO::File;
use IO::Select;
use Daemon;
use Web;
use Thread qw(cond_wait cond_broadcast);

use constant PIDFILE           => '/tmp/web_prethread.pid';
use constant PRETHREAD         => 5;
use constant MAX_REQUEST       => 30;
use constant HI_WATER_MARK     => 5;
use constant LO_WATER_MARK     => 2;
use constant DEBUG             => 1;

my $STATUS       = '';
my $ACCEPT_LOCK  = '';
my %STATUS       = ();
my $DONE         = 0;

$SIG{INT} = $SIG{TERM} = sub { $DONE++ };

my $port   = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => 100,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";
my $IN = IO::Select->new($socket);

init_server(PIDFILE);

launch_thread($socket) for (1..PRETHREAD);  # launch threads
while (!$DONE) {
  lock $STATUS;
  cond_wait $STATUS;

  warn join(' ', map {"$_=>$STATUS{$_}"} keys %STATUS),"\n" if DEBUG;

  my @idle = sort {$a <=> $b} grep {$STATUS{$_} eq 'idle'} keys %STATUS;

  if (@idle < LO_WATER_MARK) {
    launch_thread($socket) for (0..LO_WATER_MARK-@idle-1);     # bring the number up
  } 

  elsif (@idle > HI_WATER_MARK) {
    my @goners = @idle[0..@idle - HI_WATER_MARK - 1];   # kill the oldest ones
    status($_ => 'goner') foreach @goners;

... [truncated, 54 more lines] ...

#!/usr/bin/perl -w
# file: web_serial.pl
# Figure 14.2: The baseline server handles requests serially

use strict;
use IO::Socket;
use Web;

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
				    Listen    => SOMAXCONN,
				    Reuse     => 1 ) or die "Can't create listen socket: $!";
while (my $c = $socket->accept) {
  handle_connection($c);
  close $c;
}
close $socket;

#!/usr/bin/perl -w
# file: web_thread1.pl
# Figure 14.9: Threaded web server

use strict;
use IO::Socket;
use IO::Select;
use Thread;
use Daemon;
use Web;

use constant PIDFILE => '/tmp/web_thread.pid';

my $DONE = 0;
$SIG{INT}  = $SIG{TERM} = sub { $DONE++ };

my $port = shift || 8080;
my $socket = IO::Socket::INET->new( LocalPort => $port,
                                    Listen    => SOMAXCONN,
                                    Reuse     => 1 ) or die "Can't create listen socket: $!";
my $IN = IO::Select->new($socket);

# create PID file, initialize logging, and go into the background
init_server(PIDFILE);

warn "Listening for connections on port $port\n";

# accept loop
while (!$DONE) {
  next unless $IN->can_read;
  next unless my $c = $socket->accept;
  Thread->new(\&do_thread,$c);
}

warn "Normal termination\n";

sub do_thread {
  my $c = shift;
  Thread->self->detach;
  handle_connection($c);
  close $c;
}