NetServer-Generic
view release on metacpan or search on metacpan
exit 0;
}
$self->sock($main_sock);
$NetServer::Debug && print STDERR
"Created socket(port => ", $self->port(), "\n",
" " x 15, "hostname => ", $self->hostname(), ")\n";
my $scoreboard = {};
$self->scoreboard($scoreboard);
# set up named pipe -- children will write, parent will read
#my $fifo = $self->_new_fifo();
#$self->fifo($fifo);
# switch to using a pipe instead
pipe(READ_PIPE, WRITE_PIPE);
$self->{read_pipe} = *READ_PIPE;
$self->{write_pipe} = *WRITE_PIPE;
$self->root_pid($$); # set server root PID
# now create lots of spawn
for (my $i = 0; $i < $start_servers; $i++) {
my $pid = fork();
die "Cannot fork: $!\n" unless defined ($pid);
if ($pid == 0) {
# child
$self->_do_preforked_child();
$NetServer::Debug && print STDERR "$0:$$: end of transaction\n";
exit 0;
} else {
# parent
$scoreboard->{$pid} = "idle";
$NetServer::Debug && print STDERR "$0:$$: forked $pid\n";
}
}
# we have no forked $start_servers children that are
# in _do_preforked_child().
$self->scoreboard($scoreboard);
$self->_do_preforked_parent();
return;
}
sub reap_child {
do {} while waitpid(-1, WNOHANG) > 0;
}
sub _do_preforked_parent {
my $self = shift;
# we are a parent process to a bunch of raucous kiddies. We have an
# IO::Pipe called $self->reader() that we read status from and stick
# in a scoreboard. As processes die, we replace them. As the scoreboard
# fills up, we add extra servers. NB: when we fork, we replicate
# self->reader() and self->writer().
my $n = "_do_preforked_adult($$)"; # for reporting status
my $start_servers = ( $self->start_servers() or 5 );
my $spare_servers = ( $self->min_spare_servers() or 1 );
my $max_servers = ( $self->max_servers() or 10 );
my $scoreboard = ( $self->scoreboard() or {} );
$SIG{CHLD} = \&reap_child;
my @buffer = ();
my $buffer = "";
$NetServer::Debug && print STDERR "$n: About to loop on scoreboard file\n";
my $loopcnt = 0;
my $busycnt = 0;
my @busyvec = ();
#while(@buffer = $self->_read_fifo()) {
*READ_PIPE = $self->read_pipe();
while($buffer = <READ_PIPE>) {
$NetServer::Debug
&& print STDERR "busyvec: [", join("][", @busyvec), "]\n";
$loopcnt++;
$NetServer::Debug
&& print STDERR "$n: in pipe read loop $loopcnt\n";
$buffer =~ tr/ //;
chomp $buffer;
$NetServer::Debug
&& print STDERR "$n: buffer: $buffer\n";
my ($child_pid, $status) = split(/:/, $buffer);
# kids write $$:busy or $$:idle into the pipe whenever
# they change state.
if ($status eq "exit") {
# a child just exited on us
$NetServer::Debug
&& print STDERR "$n: child $child_pid just died\n";
delete($scoreboard->{$child_pid});
} elsif ($status eq "busy") {
$scoreboard->{$child_pid} = "busy";
push(@busyvec, $child_pid);
$busycnt++;
} elsif ($status eq "idle") {
$scoreboard->{$child_pid} = "idle";
@busyvec = grep(!/$child_pid/, @busyvec);
$busycnt--;
} elsif ($status eq "start") {
$scoreboard->{$child_pid} = "idle";
}
$NetServer::Debug && print STDERR "$n: $child_pid has status [",
$scoreboard->{$child_pid}, "]\n",
"$n: got ", scalar(@busyvec), " busy kids\n";
$busycnt = scalar(@busyvec);
my $all_kids = scalar keys %$scoreboard;
$NetServer::Debug &&
print STDERR "$n: $busycnt children busy of $all_kids total\n";
# busy_kids is number of kids currently busy; all_kids is number of kids
if ((($all_kids - $busycnt) < $spare_servers) and
($all_kids <= $max_servers)) {
my $kids_to_launch = ($spare_servers - ($all_kids - $busycnt)) +1;
$NetServer::Debug &&
print STDERR "spare servers: $spare_servers, ",
"all kids: $all_kids, ",
"busycnt: $busycnt\n",
"kids to launch = spares - (all - busy) +1 ",
" => $kids_to_launch\n";
# launch new children
for (my ($i) = 0; $i < $kids_to_launch; $i++) {
my $pid = fork();
if ($pid == 0) {
# new child
$NetServer::Debug &&
print STDERR "spawned child\n";
$self->_do_preforked_child();
exit 0;
} else {
# parent
$NetServer::Debug && print STDERR
"$n: spawned new child $pid\n";
$scoreboard->{$pid} = "idle";
}
}
} # end of child launch cycle
$NetServer::Debug
&& print STDERR "$n: scoreboard: \n", Dumper $scoreboard;
}
print STDERR "exited getline loop\n";
}
sub _do_preforked_child {
my $self = shift;
# we are a preforked child process. We have an IO::Pipe called
# $self->writer() that we write strange things to. Each "strange thing"
# consists of a line containing our PID, a colon, and one of three strings:
# busy, idle, or exit. We run like a run_select server, except that we
# write a busy line whenever we accept a connection, an idle line whenever
# we finish handling a connection, and an exit line when our age exceeds
# $self->server_lifespan() and we suicide.
#
my $n = "_do_preforked_child($$)"; # for reporting status
my $server_lifespan = ( $self->server_lifespan() or 1000 );
my $my_age = ( $self->my_age() or 0 );
my $main_sock = $self->sock();
my $LOCK_SH = 1;
my $LOCK_EX = 2;
my $LOCK_NB = 4;
my $LOCK_UN = 8;
my $rh = new IO::Select($main_sock);
$NetServer::Debug && print STDERR "$n: Created IO::Select()\n";
*WRITE_PIPE = $self->{write_pipe};
$NetServer::Debug
&& print WRITE_PIPE "$$:start\n";
my (@ready, @err) = ();
$NetServer::Debug
&& print STDERR "$n: about to call IO::Select->can_read()\n";
SELECT:
while (@ready = $rh->can_read() or @err = $rh->has_error(0)) {
if (scalar(@err) > 0) {
foreach my $s (@err) {
if ($NetServer::Debug > 0) {
print STDERR "Sock err: ", $s->error(), "\n";
}
if ($s->eof()) {
$rh->remove($s);
$s->close();
} else {
$s->clearerr();
}
}
@err = ();
next SELECT;
}
$NetServer::Debug && print STDERR "$n: got a connection\n";
foreach my $sock (@ready) {
$NetServer::Debug && print STDERR "$n: got a socket\n";
if ($sock == $main_sock) {
flock($sock, $LOCK_EX) or do {
print STDERR "+++ flock LOCK_EX failed on parent socket: ",
"$!\n";
};
my ($new_sock) = $sock->accept();
flock $sock, $LOCK_UN;
$new_sock->autoflush(1);
$rh->add($new_sock);
if (! $self->ok_to_serve($new_sock)) {
$rh->remove($sock);
close($sock);
}
} else {
if (! eof($sock)) {
$my_age++;
$NetServer::Debug
&& print STDERR "$n: print WRITE_PIPE ($$:busy)\n";
print WRITE_PIPE "$$:busy\n";
$NetServer::Debug
&& print STDERR "$n: serving connection\n";
$sock->autoflush(1);
my ($in_port, $in_addr) = sockaddr_in($sock->sockname());
$self->servername([$in_port, $in_addr]);
my ($code) = $self->callback();
$self->sock($sock);
*OLD_STDIN = *STDIN;
*OLD_STDOUT = *STDOUT;
*STDIN = $sock;
*STDOUT = $sock;
select STDIN; $| = 1;
select STDOUT; $| = 1;
&$code($self);
*STDIN = *OLD_STDIN;
*STDOUT = *OLD_STDOUT;
$NetServer::Debug && do {
print STDERR "$n: print WRITE_PIPE $$:idle\n",
"$n: served $my_age calls\n";
};
print WRITE_PIPE "$$:idle\n$$:idle\n";
$rh->remove($sock);
close $sock;
} else {
$rh->remove($sock);
close($sock);
}
}
}
$NetServer::Debug && print STDERR "$n: checking age $my_age ",
"against lifespan $server_lifespan\n";
if ($my_age >= $server_lifespan) {
$NetServer::Debug
&& print STDERR "$n: time to live exceeded\n",
"$n: print WRITE_PIPE $$:exit\n";
#$self->_write_fifo("$$:exit\n");
print WRITE_PIPE "$$:exit\n";
exit 0;
}
}
$NetServer::Debug
&& print STDERR "Warning! Should never reach this point:",
join("\n", caller()), "\n";
print WRITE_PIPE "$$:exit\n";
exit 0;
}
sub run_select {
my $self = shift;
my ($main_sock) =
new IO::Socket::INET( # LocalAddr => $self->hostname(),
LocalPort => $self->port(),
Listen => $self->listen(),
Proto => $self->proto(),
Reuse => 1
);
# die "$$:run_select(): could not create socket: $!\n" unless ($main_sock);
if (! $main_sock) {
print STDERR "$$:run_select(): could not create socket: $!\n";
( run in 2.041 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )