view release on metacpan or  search on metacpan

lib/HTTP/Server/Daemon.pm  view on Meta::CPAN

            my @pipe_msg = split "\n", $pipe_msg;
            foreach (@pipe_msg)
            {
                next unless my ($pid, $sta) = /^(\d+)\s*(\w+)$/;
                if ($sta eq 'exit')
                {
                    delete $children{$pid};
                }
                else
                {
                    $children{$pid} = $sta;
                }
            }
        }

        my @idle_children = sort {$a <=> $b} grep {$children{$_} eq 'idle'} keys %children;

        if (@idle_children < $min_children)
        {
            perfork_child_pipe($server, $pipe_write, $child_func);
        }
        elsif(@idle_children > $max_children)
        {
            my @kill_pids = @idle_children[0..@idle_children - $max_children - 1];
            my $kill_pid = kill HUP => @kill_pids;
        }
    }
}

=head2 perfork_child_pipe($server_sock, $pipe_write, $child_func_ref, $dead_after_requests_num)

Fork a child listen the port. 
(Internal methods).

=cut
    
sub perfork_child_pipe
{
    my $server = shift;
    my $pipe_write = shift;
    my $child_func = shift;
    my $max_request = shift;
    $max_request = int(rand 99) + 9 unless $max_request;

    croak "function perfork_child_pipe() avg3 must be a function.\n" unless ref $child_func eq 'CODE';

    my $child = fork;
    if ($child == 0)
    {
        undef $pipe_status;
        undef $pipe_read;
        undef @idle_children;
        undef %children;
        undef $min_children;
        undef $max_children;
        undef $port;
        undef $quit;

        my $quit = 0;
        my $caller = $0;
        local $SIG{HUP} = sub {$0 = "$caller busy hup"; $quit++; exit 0;};
        while(!$quit and $max_request--)
        {
            my $sock;
            syswrite $pipe_write, "$$ idle\n";
            $0 = "$caller life=$max_request idle";

            next unless eval
            {
                local $SIG{HUP} = sub {$0 = "$caller idle hup"; $quit++; die;};
                accept($sock, $server);
            };

            syswrite $pipe_write, "$$ busy\n";
            $0 = "$caller life=$max_request busy";
            &$child_func($sock);

            close $sock;
        }
        close $server;
        syswrite $pipe_write, "$$ exit\n";
        close $pipe_write;
        exit 0;
    }
}

=head2 become_netserver($port)

Let the proccess listen on given port using protocol 'TCP'.

=cut

sub become_netserver
{
    my $port = shift;
    my $address = sockaddr_in($port, INADDR_ANY);
    my $server;
    socket($server, AF_INET, SOCK_STREAM, IPPROTO_TCP) || die "socket create: $!\n";
    setsockopt($server, SOL_SOCKET, SO_REUSEADDR, 1) || die "socket reuse: $!\n";
    bind($server, $address) || die "socket bind: $!\n";
    listen($server, SOMAXCONN) || die "socket listen: $!\n";
    return $server;
}

=head2 send_msg($sock)

Send msg to sock using protocol 'PON'(Perl Object Notation).

=cut

sub send_msg
{
    my $sock = shift;
    my $script = shift;
    my $data = shift;
    my %str;
    $str{'script'} = $script;
    $str{'data'} = \%{$data};
    $str = dump(%str);
    my $str_length = length($str);
    #print $str;
    my $binstr = pack('N', $str_length) . $str;
    syswrite($sock, $binstr);
    return $str_length;
}

=head2 get_msg($sock)

Receive msg from sock using protocol 'PON'(Perl Object Notation).

=cut

sub get_msg
{
    my $sock = shift;