File Coverage

blib/lib/Net/Server/Fork.pm

Criterion	Covered	Total	%
statement	67	128	52.3
branch	12	46	26.0
condition	1	2	50.0
subroutine	13	20	65.0
pod	4	8	50.0
total	97	204	47.5

# -*- perl -*-
#
#  Net::Server::Fork - Net::Server personality
#
#  Copyright (C) 2001-2022
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server::Fork;

use strict;
use base qw(Net::Server);
use Net::Server::SIG qw(register_sig check_sigs);
use Socket qw(SO_TYPE SOL_SOCKET SOCK_DGRAM);
use POSIX qw(WNOHANG);

sub net_server_type { __PACKAGE__ }

sub options {
    my $self = shift;
    my $ref  = $self->SUPER::options(@_);
    my $prop = $self->{'server'};
    $ref->{$_} = \$prop->{$_} for qw(max_servers max_dequeue check_for_dead check_for_dequeue);
    $ref->{'sig_passthrough'} = $prop->{'sig_passthrough'} = [];
    return $ref;
}

sub post_configure {
    my $self = shift;
    my $prop = $self->{'server'};
    $self->SUPER::post_configure(@_);

    $prop->{'max_servers'}    = 256 if ! defined $prop->{'max_servers'};
    $prop->{'check_for_dead'} = 60  if ! defined $prop->{'check_for_dead'};

    $prop->{'ppid'} = $$;
    $prop->{'multi_port'} = 1;
}

sub loop {
    my $self = shift;
    my $prop = $self->{'server'};

    $prop->{'children'} = {};
    if ($ENV{'HUP_CHILDREN'}) {
        my %children = map {/^(\w+)$/; $1} split(/\s+/, $ENV{'HUP_CHILDREN'});
        $children{$_} = {status => $children{$_}, hup => 1} foreach keys %children;
        $prop->{'children'} = \%children;
    }

    # register some of the signals for safe handling
    register_sig(
        PIPE => 'IGNORE',
        INT  => sub { $self->server_close() },
        TERM => sub { $self->server_close() },
        HUP  => sub { $self->sig_hup() },
        CHLD => sub {
            while (defined(my $chld = waitpid(-1, WNOHANG))) {
                last if $chld <= 0;
                $self->delete_child($chld);
            }
        },
        QUIT => sub { $self->{'server'}->{'kind_quit'} = 1; $self->server_close() },
        TTIN => sub { $self->{'server'}->{'max_servers'}++; $self->log(3, "Increasing max server count ($self->{'server'}->{'max_servers'})") },
        TTOU => sub { $self->{'server'}->{'max_servers'}--; $self->log(3, "Decreasing max server count ($self->{'server'}->{'max_servers'})") },
        );

    $self->register_sig_pass;

    if ($ENV{'HUP_CHILDREN'}) {
        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) {

        ### make sure we don't use too many processes
        my $n_children = grep { $_->{'status'} !~ /dequeue/ } values %{ $prop->{'children'} };
        while ($n_children > $prop->{'max_servers'}){

            select(undef, undef, undef, 5); # block for a moment (don't look too often)
            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 ($prop->{'check_for_dequeue'}) {
            my $time = time();
            if ($time - $last_checked_for_dequeue > $prop->{'check_for_dequeue'}) {
                $last_checked_for_dequeue = $time;
                if ($prop->{'max_dequeue'}) {
                    my $n_dequeue = grep { $_->{'status'} =~ /dequeue/ } values %{ $prop->{'children'} };
                    $self->run_dequeue() if $n_dequeue < $prop->{'max_dequeue'};
                }
            }
        }

        $self->pre_accept_hook;

        if (! $self->accept()) {
            last if $prop->{'_HUP'};
            last if $prop->{'done'};
            next;
        }

        $self->pre_fork_hook;

        ### fork a child so the parent can go back to listening
        local $!;
        my $pid = fork;
        if (! defined $pid) {
            $self->log(1, "Bad fork [$!]");
            sleep 5;
            next;
        }

        # child
        if (! $pid) {
            $self->run_client_connection;
            exit;
        }

        # parent
        close($prop->{'client'}) if !$prop->{'udp_true'};
        $prop->{'children'}->{$pid}->{'status'} = 'processing';
        $self->register_child($pid, 'fork');
    }
}

sub pre_accept_hook {};

sub accept {
    my ($self, $class) = @_;
    my $prop = $self->{'server'};

    # block on trying to get a handle (select created because we specified multi_port)
    my @socks = $prop->{'select'}->can_read(2);
    if (check_sigs()) {
        return undef if $prop->{'_HUP'};
        return undef if ! @socks; # don't continue unless we have a connection
    }

    my $sock = $socks[rand @socks];
    return undef if ! defined $sock;

    # check if this is UDP
    if (SOCK_DGRAM == $sock->getsockopt(SOL_SOCKET, SO_TYPE)) {
        $prop->{'udp_true'} = 1;
        $prop->{'client'}   = $sock;
        $prop->{'udp_peer'} = $sock->recv($prop->{'udp_data'}, $sock->NS_recv_len, $sock->NS_recv_flags);

    # Receive a SOCK_STREAM (TCP or UNIX) packet
    } else {
        delete $prop->{'udp_true'};
        $prop->{'client'} = $sock->accept($class) || return;
    }
}

sub run_client_connection {
    my $self = shift;

    ### close the main sock, we still have
    ### the client handle, this will allow us
    ### to HUP the parent at any time
    $_ = undef foreach @{ $self->{'server'}->{'sock'} };

    ### restore sigs (for the child)
    $SIG{'HUP'} = $SIG{'CHLD'} = $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = 'DEFAULT';
    $SIG{'PIPE'} = 'IGNORE';

    delete $self->{'server'}->{'children'};

    $self->child_init_hook;

    $self->SUPER::run_client_connection;

    $self->child_finish_hook;
}

sub close_children {
    my $self = shift;
    $self->SUPER::close_children(@_);

    check_sigs(); # since we have captured signals - make sure we handle them

    register_sig(PIPE => 'DEFAULT',
                 INT  => 'DEFAULT',
                 TERM => 'DEFAULT',
                 QUIT => 'DEFAULT',
                 HUP  => 'DEFAULT',
                 CHLD => 'DEFAULT',
                 TTIN => 'DEFAULT',
                 TTOU => 'DEFAULT',
                 );
}

1;

__END__