package Net::Server::Fork;
use strict;
use vars qw($VERSION @ISA);
use Net::Server ();
use Net::Server::SIG qw(register_sig check_sigs);
use Socket qw(SO_TYPE SOL_SOCKET SOCK_DGRAM);
use POSIX qw(WNOHANG);
$VERSION = $Net::Server::VERSION;
@ISA = qw(Net::Server);
sub options {
my $self = shift;
my $prop = $self->{server};
my $ref = shift;
$self->SUPER::options($ref);
foreach ( qw(max_servers max_dequeue
check_for_dead check_for_dequeue) ){
$prop->{$_} = undef unless exists $prop->{$_};
$ref->{$_} = \$prop->{$_};
}
}
sub post_configure {
my $self = shift;
my $prop = $self->{server};
$self->SUPER::post_configure;
$prop->{max_servers} = 256
unless defined $prop->{max_servers};
$prop->{check_for_dead} = 60
unless defined $prop->{check_for_dead};
$prop->{ppid} = $$;
$prop->{multi_port} = 1;
}
sub loop {
my $self = shift;
my $prop = $self->{server};
$prop->{children} = {};
register_sig(PIPE => 'IGNORE',
INT => sub { $self->server_close() },
TERM => sub { $self->server_close() },
QUIT => sub { $self->server_close() },
HUP => sub { $self->sig_hup() },
CHLD => sub {
while ( defined(my $chld = waitpid(-1, WNOHANG)) ){
last unless $chld > 0;
$self->delete_child($chld);
}
},
);
my ($last_checked_for_dead, $last_checked_for_dequeue) = (time(), time());
while( 1 ){
my $n_children = grep { $_->{status} !~ /dequeue/ } (values %{ $prop->{children} });
while ($n_children > $prop->{max_servers}){
select(undef,undef,undef,5);
&check_sigs();
my $time = time();
if( $time - $last_checked_for_dead > $prop->{check_for_dead} ){
$last_checked_for_dead = $time;
$self->log(2,"Max number of children reached ($prop->{max_servers}) -- checking for alive.");
foreach (keys %{ $prop->{children} }){
kill(0,$_) or $self->delete_child($_);
}
}
$n_children = grep { $_->{status} !~ /dequeue/ } (values %{ $prop->{children} });
}
if( defined $prop->{check_for_dequeue} ){
my $time = time();
if( $time - $last_checked_for_dequeue
> $prop->{check_for_dequeue} ){
$last_checked_for_dequeue = $time;
if( defined($prop->{max_dequeue}) ){
my $n_dequeue = grep { $_->{status} =~ /dequeue/ } (values %{ $prop->{children} });
if( $n_dequeue < $prop->{max_dequeue} ){
$self->run_dequeue();
}
}
}
}
$self->pre_accept_hook;
if( ! $self->accept() ){
last if $prop->{_HUP};
next;
}
$self->post_accept_hook;
my $pid = fork;
if( not defined $pid ){
$self->log(1,"Bad fork [$!]");
sleep(5);
}elsif( $pid ){
close($prop->{client}) if ! $prop->{udp_true};
$prop->{children}->{$pid}->{status} = 'processing';
}else{
$self->run_client_connection;
exit;
}
}
}
sub pre_accept_hook {};
sub accept {
my $self = shift;
my $prop = $self->{server};
my(@socks) = $prop->{select}->can_read(10);
if( &check_sigs() ){
return undef if $prop->{_HUP};
return undef unless @socks; }
my $sock = $socks[rand @socks];
return undef unless defined $sock;
if( SOCK_DGRAM == $sock->getsockopt(SOL_SOCKET,SO_TYPE) ){
$prop->{udp_true} = 1;
$prop->{client} = $sock;
$prop->{udp_true} = 1;
$prop->{udp_peer} = $sock->recv($prop->{udp_data},
$sock->NS_recv_len,
$sock->NS_recv_flags);
}else{
delete $prop->{udp_true};
$prop->{client} = $sock->accept();
return undef unless defined $prop->{client};
}
}
sub run_client_connection {
my $self = shift;
$_ = undef foreach @{ $self->{server}->{sock} };
$SIG{HUP} = $SIG{CHLD} = $SIG{PIPE}
= $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = 'DEFAULT';
$self->SUPER::run_client_connection;
}
sub run_dequeue {
die "run_dequeue: virtual method not defined";
}
1;
__END__
=head1 NAME
Net::Server::Fork - Net::Server personality
=head1 SYNOPSIS
use Net::Server::Fork;
@ISA = qw(Net::Server::Fork);
sub process_request {
#...code...
}
__PACKAGE__->run();
=head1 DESCRIPTION
Please read the pod on Net::Server first. This module
is a personality, or extension, or sub class, of the
Net::Server module.
This personality binds to one or more ports and then waits
for a client connection. When a connection is received,
the server forks a child. The child handles the request
and then closes.
=head1 ARGUMENTS
=over 4
=item check_for_dead
Number of seconds to wait before looking for dead children.
This only takes place if the maximum number of child processes
(max_servers) has been reached. Default is 60 seconds.
=item max_servers
The maximum number of children to fork. The server will
not accept connections until there are free children. Default
is 256 children.
=item max_dequeue
The maximum number of dequeue processes to start. If a
value of zero or undef is given, no dequeue processes will
be started. The number of running dequeue processes will
be checked by the check_for_dead variable.
=item check_for_dequeue
Seconds to wait before forking off a dequeue process. It
is intended to use the dequeue process to take care of
items such as mail queues. If a value of undef is given,
no dequeue processes will be started.
=back
=head1 CONFIGURATION FILE
See L<Net::Server>.
=head1 PROCESS FLOW
Process flow follows Net::Server until the post_accept phase.
At this point a child is forked. The parent is immediately
able to wait for another request. The child handles the
request and then exits.
=head1 HOOKS
The Fork server has the following hooks in addition to
the hooks provided by the Net::Server base class.
See L<Net::Server>
=over 4
=item C<$self-E<gt>pre_accept_hook()>
This hook occurs just before the accept is called.
=item C<$self-E<gt>post_accept_hook()>
This hook occurs just after accept but before the fork.
=item C<$self-E<gt>run_dequeue()>
This hook only gets called in conjuction with the
check_for_dequeue setting.
=back
=head1 TO DO
See L<Net::Server>
=head1 AUTHOR
Paul T. Seamons paul@seamons.com
and maintained by Rob Brown bbb@cpan.org
=head1 SEE ALSO
Please see also
L<Net::Server::INET>,
L<Net::Server::PreFork>,
L<Net::Server::MultiType>,
L<Net::Server::SIG>
L<Net::Server::Single>
=cut