use strict;
$SIG{'PIPE'} = 'IGNORE';
use HTTP::Daemon;
use POSIX;
# Number of child processes to keep going
my $totalChildren = 5;
# Number of requests each child handles before dying
my $childLifetime = 100;
my $logFile = "C:\\rrships\\daemon.log";
my %children;
my $children = 0;

&daemonize;

# Create an HTTP daemon
my $d = HTTP::Daemon->new( LocalPort => 80, LocalAddr => 'localhost', 
+Reuse => 1, Timeout => 180, Proto => 'tcp' ) 
   || die "Cannot create socket: $!\n";

# Log the URL used to access our daemon
logMessage ("master is ", $d->url);
&spawnChildren;
&keepTicking;



sub daemonize {   my $pid = fork;   defined ($pid) or die "Cannot star
+t daemon: $!";
  # If we're the shell-called process,
  # let the user know the daemon is now running.
  print "Parent daemon running.\n" if $pid;
  # If we're the shell-called process, exit back.
  exit if $pid;

  # Now we're a daemonized parent process!

  # Detach from the shell entirely by setting our own
  # session and making our own process group
  # as well as closing any standard open filehandles.
  # POSIX::setsid();
  system('setsid ' . $pid);
  print '1';
  #close (STDOUT); close (STDIN); close (STDERR);
  print '2';
  # Set up signals we want to catch. Let's log
  # warnings, fatal errors, and catch hangups 
  # and dying children

  $SIG{__WARN__} = sub {
    &logMessage ("NOTE! " . join(" ", @_));
  };
  print '3';
  $SIG{__DIE__} = sub { 
    &logMessage ("FATAL! " . join(" ", @_));
    exit;
  };
  print '4';
  $SIG{HUP} = $SIG{INT} = $SIG{TERM} = sub {
    # Any sort of death trigger results in death of all
    my $sig = shift;
    $SIG{$sig} = 'IGNORE';
    kill 'INT' => keys %children;
    die "killed by $sig\n";
    exit;
  };
  print '5';
  # We'll handle our child reaper in a separate sub
  $SIG{CHLD} = \&REAPER;
}

sub REAPER {
  my $stiff;
  while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
    warn ("child $stiff terminated -- status $?");
    $children--;
    delete $children{$stiff};
  }

  $SIG{CHLD} = \&REAPER;
}

sub spawnChildren {
  for (1..$totalChildren) {
    &newChild();
  }
}

sub keepTicking {
  while ( 1 ) {
    sleep;
    for (my $i = $children; $i < $totalChildren; $i++ ) {
      &newChild();
    }
  };
}


sub newChild {
  # Daemonize away from the parent process.
  my $pid;
  my $sigset = POSIX::SigSet->new(); # Dies here
  sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork:
+ $!";
  die "Cannot fork child: $!\n" unless defined ($pid = fork);
  if ($pid) {
    $children{$pid} = 1;
    $children++;
    warn "forked new child, we now have $children children";
    return;
  }

  # Loop for a certain number of times
  my $i = 0;
  while ($i < $childLifetime) {
    $i++;
    # Accept a connection from HTTP::Daemon
    my $c = $d->accept or last;
    $c->autoflush(1);
    logMessage ("connect:". $c->peerhost . "\n");

    # Get the request
    my $r = $c->get_request(1) or last;

    # Process the request..
    # you can do whatever you like here..
    # we blindly respond to anything for now..
    if (($r->method eq 'GET') && ($r->url->path =~ m/\.(html|cgi|htm|p
+l)/)) {
        my $response = HTTP::Response->new(200);
        $response->content(&Hello_World($r->url->path, $r->url->query)
+);
          $response->header("Content-Type" => "text/html");
          $c->send_response($response);
    }
    elsif (($r->method eq 'GET') && ($r->url->path =~ m/\.(gif|jpg|bmp
+|png)/)) {
        open (IMAGE, 'C:\\rrships' . $r->url->path) or warn 'Couldn\'t
+ open image: ' . $r->url->path;
        my $response = HTTP::Response->new(200);
        $response->push_header('Content-Type','image/' . $1);
        my $content = '';
        while (<IMAGE>) { $content .= $_; }
          close IMAGE;
          $response->content($content);
          $c->send_response($response);
    }
    elsif (($r->method eq 'GET') && ($r->url->path eq '/')) {
        my $response = HTTP::Response->new(200);
        $response->content(&Hello_World($r->url->path, $r->url->query)
+);
          $response->header("Content-Type" => "text/html");
          $c->send_response($response);
    }
    else {
        $c->send_error('RC_FORBIDDEN');
    }
    logMessage ($c->peerhost . " " . $d->url . $r->url . "\n");
  }

  warn "child terminated after $i requests";
  exit;
}

sub logMessage {
   my $message = shift;
   print $message . "\n";
}
[download]