view release on metacpan or  search on metacpan

lib/Starlet/Server.pm  view on Meta::CPAN

            # 1) tempfile retains the handle when UNLINK is set
            # 2) tempfile implicitely locks the file on OS X
            close $fh;
            $lock_path;
        };
    }

    $self->{server_ready}->($self);
}

sub accept_loop {
    # TODO handle $max_reqs_per_child
    my($self, $app, $max_reqs_per_child) = @_;
    my $proc_req_count = 0;
    my $is_keepalive = 0;

    local $SIG{TERM} = sub {
        $self->{term_received} = 1;
    };
    local $SIG{PIPE} = 'IGNORE';

    my $acceptor = $self->_get_acceptor;

    while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) {
        # accept (or exit on SIGTERM)
        if ($self->{term_received}) {
            $self->{child_exit}->($self, $app);
            exit 0;
        }
        my ($conn, $peer, $listen) = $acceptor->();
        next unless $conn;

        $self->{_is_deferred_accept} = $listen->{_using_defer_accept};
        defined($conn->blocking(0))
            or die "failed to set socket to nonblocking mode:$!";
        my ($peerport, $peerhost, $peeraddr) = (0, undef, undef);
        if ($listen->{_is_tcp}) {
            $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
                or die "setsockopt(TCP_NODELAY) failed:$!";
            ($peerport, $peerhost) = unpack_sockaddr_in $peer;
            $peeraddr = inet_ntoa($peerhost);
        }
        my $req_count = 0;
        my $pipelined_buf = '';

        while (1) {
            ++$req_count;
            ++$proc_req_count;
            my $env = {
                SERVER_PORT => $listen->{port} || 0,
                SERVER_NAME => $listen->{host} || 0,
                SCRIPT_NAME => '',
                REMOTE_ADDR => $peeraddr,
                REMOTE_PORT => $peerport,
                'psgi.version' => [ 1, 1 ],
                'psgi.errors'  => *STDERR,
                'psgi.url_scheme' => 'http',
                'psgi.run_once'     => Plack::Util::FALSE,
                'psgi.multithread'  => Plack::Util::FALSE,
                'psgi.multiprocess' => $self->{is_multiprocess},
                'psgi.streaming'    => Plack::Util::TRUE,
                'psgi.nonblocking'  => Plack::Util::FALSE,
                'psgix.input.buffered' => Plack::Util::TRUE,
                'psgix.io'          => $conn,
                'psgix.harakiri'    => 1,
                'psgix.informational' => sub {
                    $self->_informational($conn, @_);
                },
            };

            my $may_keepalive = $req_count < $self->{max_keepalive_reqs};
            if ($may_keepalive && $max_reqs_per_child && $proc_req_count >= $max_reqs_per_child) {
                $may_keepalive = undef;
            }
            $may_keepalive = 1 if length $pipelined_buf;
            my $keepalive;
            ($keepalive, $pipelined_buf) = $self->handle_connection($env, $conn, $app, 
                                                                    $may_keepalive, $req_count != 1, $pipelined_buf);

            if ($env->{'psgix.harakiri.commit'}) {
                $conn->close;
                return;
            }
            last unless $keepalive;
            # TODO add special cases for clients with broken keep-alive support, as well as disabling keep-alive for HTTP/1.0 proxies
        }
        $conn->close;
    }
}

sub _get_acceptor {
    my $self = shift;
    my @listens = grep {defined $_} @{$self->{listens}};

    if (scalar(@listens) == 1) {
        my $listen = $listens[0];
        return sub {
            if (my ($conn, $peer) = $listen->{sock}->accept) {
                return ($conn, $peer, $listen);
            }
            return +();
        };
    }
    else {
        # wait for multiple sockets with select(2)
        my @fds;
        my $rin = '';
        for my $listen (@listens) {
            defined($listen->{sock}->blocking(0))
	        or die "failed to set listening socket to non-blocking mode:$!";
            my $fd = fileno($listen->{sock});
            push @fds, $fd;
            vec($rin, $fd, 1) = 1;
        }

        open(my $lock_fh, '>', $self->{lock_path})
            or die "failed to open lock file:@{[$self->{lock_path}]}:$!";

        return sub {
            if (! flock($lock_fh, LOCK_EX)) {
                die "failed to lock file:@{[$self->{lock_path}]}:$!"