File Coverage

blib/lib/Net/Server/PreForkSimple.pm

Criterion	Covered	Total	%
statement	114	201	56.7
branch	24	94	25.5
condition	5	18	27.7
subroutine	21	29	72.4
pod	5	14	35.7
total	169	356	47.4

# -*- perl -*-
#
#  Net::Server::PreForkSimple - 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::PreForkSimple;

use strict;
use base qw(Net::Server);
use File::Temp qw(tempfile);
use Net::Server::SIG qw(register_sig check_sigs);
use POSIX qw(WNOHANG EINTR);
use Fcntl ();

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_requests      max_dequeue
                                     check_for_dead  check_for_dequeue
                                     lock_file       serialize);
    $ref->{'sig_passthrough'} = $prop->{'sig_passthrough'} = [];
    return $ref;
}

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

    ### some default values to check for
    my $d = {
        max_servers       => 50,   # max num of servers to run
        max_requests      => 1000, # num of requests for each child to handle
        check_for_dead    => 30,   # how often to see if children are alive
    };
    foreach (keys %$d){
        $prop->{$_} = $d->{$_}
            unless defined($prop->{$_}) && $prop->{$_} =~ /^\d+$/;
    }

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


sub post_bind {
    my $self = shift;
    my $prop = $self->{'server'};
    $self->SUPER::post_bind;

    if ($prop->{'multi_port'} && $prop->{'serialize'} && $prop->{'serialize'} eq 'none') {
        $self->log(2, "Passed serialize value of none is incompatible with multiple ports - using default serialize");
        delete $prop->{'serialize'};
    }
    if (!$prop->{'serialize'}
        || $prop->{'serialize'} !~ /^(flock|semaphore|pipe|none)$/i) {
        $prop->{'serialize'} = ($^O eq 'MSWin32') ? 'pipe' : 'flock';
    }
    $prop->{'serialize'} =~ tr/A-Z/a-z/;

    if ($prop->{'serialize'} eq 'flock') {
        $self->log(3, "Setting up serialization via flock");
        if (defined $prop->{'lock_file'}) {
            $prop->{'lock_file_unlink'} = undef;
        } else {
            (my $fh, $prop->{'lock_file'}) = tempfile();
            # We don't need to keep the file handle open in the parent;
            # each child opens it separately to avoid sharing the lock
            close $fh or die "Cannot close lock file $prop->{'lock_file'}: $!";
            $prop->{'lock_file_unlink'} = 1;
        }

    } elsif ($prop->{'serialize'} eq 'semaphore') {
        $self->log(3, "Setting up serialization via semaphore");
        require IPC::SysV;
        require IPC::Semaphore;
        my $s = IPC::Semaphore->new(IPC::SysV::IPC_PRIVATE(), 1, IPC::SysV::S_IRWXU() | IPC::SysV::IPC_CREAT())
             or $self->fatal("Semaphore error [$!]");
        $s->setall(1) or $self->fatal("Semaphore create error [$!]");
        $prop->{'sem'} = $s;

    } elsif ($prop->{'serialize'} eq 'pipe') {
        $self->log(3, "Setting up serialization via pipe");
        pipe(my $waiting, my $ready);
        $ready->autoflush(1);
        $waiting->autoflush(1);
        $prop->{'_READY'}   = $ready;
        $prop->{'_WAITING'} = $waiting;
        print $ready "First\n";
    } elsif ($prop->{'serialize'} eq 'none') {
        $self->log(3, "Using no serialization");
    } else {
        $self->fatal("Unknown serialization type \"$prop->{'serialize'}\"");
    }

}

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;
    }

    $self->log(3, "Beginning prefork ($prop->{'max_servers'} processes)");

    $self->run_n_children($prop->{'max_servers'});

    $self->run_parent;

}

sub run_n_children {
    my ($self, $n) = @_;
    return if $n <= 0;
    my $prop = $self->{'server'};

    $self->run_n_children_hook;

    $self->log(3, "Starting \"$n\" children");

    for (1 .. $n) {
        $self->pre_fork_hook;
        local $!;
        my $pid = fork;
        $self->fatal("Bad fork [$!]") if ! defined $pid;

        if ($pid) {
            $prop->{'children'}->{$pid}->{'status'} = 'processing';
            $self->register_child($pid, 'preforksimple');
        } else {
            $self->run_child;
        }
    }
}

sub run_n_children_hook {}

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

    $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub {
        $self->child_finish_hook;
        exit;
    };
    $SIG{'PIPE'} = 'IGNORE';
    $SIG{'CHLD'} = 'DEFAULT';
    $SIG{'HUP'}  = sub {
        if (! $prop->{'connected'}) {
            $self->child_finish_hook;
            exit;
        }
        $prop->{'SigHUPed'} = 1;
    };

    my $needs_lock = ($prop->{'serialize'} eq 'flock') ? 1 : 0;
    if ($needs_lock) {
        open($prop->{'lock_fh'}, ">", $prop->{'lock_file'})
            or $self->fatal("Couldn't open lock file \"$prop->{'lock_file'}\"[$!]");
    }

    $self->log(4, "Child Preforked ($$)");
    delete $prop->{'children'};

    $self->child_init_hook;

    while ($self->accept()) {
        $prop->{'connected'} = 1;
        $self->run_client_connection;
        $prop->{'connected'} = 0;
        last if $self->done;
    }

    $self->child_finish_hook;

    close($prop->{'lock_fh'}) if $needs_lock && $prop->{'lock_fh'};

    $self->log(4, "Child leaving ($prop->{'max_requests'})");
    exit;

}

sub is_prefork { 1 }

### We can only let one process do the selecting at a time
### this override makes sure that nobody else can do it
### while we are.  We do this either by opening a lock file
### and getting an exclusive lock (this will block all others
### until we release it) or by using semaphores to block
sub accept {
    my $self = shift;
    my $prop = $self->{'server'};

    if ($prop->{'serialize'} eq 'flock') {
        while (! flock $prop->{'lock_fh'}, Fcntl::LOCK_EX()) {
            next if $! == EINTR;
            $self->fatal("Couldn't get lock on file \"$prop->{'lock_file'}\" [$!]");
        }
        my $v = $self->SUPER::accept();
        flock $prop->{'lock_fh'}, Fcntl::LOCK_UN();
        return $v;
    } elsif ($prop->{'serialize'} eq 'semaphore') {
        $prop->{'sem'}->op(0, -1, IPC::SysV::SEM_UNDO()) or $self->fatal("Semaphore Error [$!]");
        my $v = $self->SUPER::accept();
        $prop->{'sem'}->op(0, 1, IPC::SysV::SEM_UNDO()) or $self->fatal("Semaphore Error [$!]");
        return $v;
    } elsif ($prop->{'serialize'} eq 'pipe') {
        my $waiting = $prop->{'_WAITING'};
        scalar <$waiting>; # read one line - kernel says who gets it
        my $v = $self->SUPER::accept();
        print { $prop->{'_READY'} } "Next!\n";
        return $v;
    } else {
        my $v = $self->SUPER::accept();
        return $v;
    }
}

sub done {
    my $self = shift;
    my $prop = $self->{'server'};
    $prop->{'done'} = shift if @_;
    return 1 if $prop->{'done'};
    return 1 if $prop->{'requests'} >= $prop->{'max_requests'};
    return 1 if $prop->{'SigHUPed'};
    if (! kill 0, $prop->{'ppid'}) {
        $self->log(3, "Parent process gone away. Shutting down");
        return 1;
    }
}

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

    $self->log(4, "Parent ready for children.");

    $prop->{'last_checked_for_dead'} = $prop->{'last_checked_for_dequeue'} = time();

    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 unless $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'})");
            if (defined(my $pid = each %{ $prop->{'children'} })) {
                $self->delete_child($pid) if ! kill('HUP', $pid);
            }
        },
        );

    $self->register_sig_pass;

    if ($ENV{'HUP_CHILDREN'}) {
        while (defined(my $chld = waitpid(-1, WNOHANG))) {
            last unless $chld > 0;
            $self->delete_child($chld);
        }
    }

    while (1) {
        select undef, undef, undef, 10;

        if (check_sigs()){
            last if $prop->{'_HUP'};
        }

        $self->idle_loop_hook();

        # periodically make sure children are alive
        my $time = time();
        if ($time - $prop->{'last_checked_for_dead'} > $prop->{'check_for_dead'}) {
            $prop->{'last_checked_for_dead'} = $time;
            foreach (keys %{ $prop->{'children'} }) {
                kill(0,$_) or $self->delete_child($_);
            }
        }

        # make sure we always have max_servers
        my $total_n = 0;
        my $total_d = 0;
        foreach (values %{ $prop->{'children'} }){
            if( $_->{'status'} eq 'dequeue' ){
                $total_d ++;
            }else{
                $total_n ++;
            }
        }

        if( $prop->{'max_servers'} > $total_n ){
            $self->run_n_children( $prop->{'max_servers'} - $total_n );
        }

        # periodically check to see if we should clear the queue
        if( defined $prop->{'check_for_dequeue'} ){
            if( $time - $prop->{'last_checked_for_dequeue'}
            > $prop->{'check_for_dequeue'} ){
                $prop->{'last_checked_for_dequeue'} = $time;
                if( defined($prop->{'max_dequeue'})
                && $total_d < $prop->{'max_dequeue'} ){
                    $self->run_dequeue();
                }
            }
        }

    }
}

sub idle_loop_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__