view release on metacpan or  search on metacpan

lib/FCGI/EV.pm  view on Meta::CPAN

package FCGI::EV;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v2.0.1';

use Scalar::Util qw( weaken );
use IO::Stream;


use constant FCGI_HEADER_LEN        => 8;
use constant FCGI_VERSION_1         => 1;
use constant FCGI_BEGIN_REQUEST     => 1;
use constant FCGI_END_REQUEST       => 3;
use constant FCGI_PARAMS            => 4;
use constant FCGI_STDIN             => 5;
use constant FCGI_STDOUT            => 6;
use constant FCGI_RESPONDER         => 1;
use constant FCGI_REQUEST_COMPLETE  => 0;
use constant END_REQUEST_COMPLETE   =>
    pack 'N C CCC', 0, FCGI_REQUEST_COMPLETE, 0, 0, 0;
use constant MAX_CONTENT_LEN        => 0xFFFF;


sub new {
    my ($class, $sock, $handler_class) = @_;
    my $self = bless {
        io          => undef,
        req_id      => undef,
        params      => q{},
        stdin_eof   => undef,
        handler     => undef,
        handler_class=>$handler_class,
    }, $class;
    $self->{io} = IO::Stream->new({
        fh          => $sock,
        wait_for    => IN|EOF,
        cb          => $self,
        Wait_header => 1,
        Need_in     => FCGI_HEADER_LEN,
    });
    weaken($self->{io});
    # It MAY have sense to add timeout between read() calls and timeout for
    # overall time until EOF on STDIN will be received. First timeout
    # can be about 3 minutes for slow clients, second can be about 4 hours
    # for uploading huge files.
    return;
}

sub DESTROY {
    my ($self) = @_;
    $self->{handler} = undef;   # call handler's DESTROY while $self is alive
    return;
}

sub stdout {
    my ($self, $stdout, $is_eof) = @_;
    my $io = $self->{io};
    if (length $stdout) {
        $io->{out_buf} .= _pack_pkt(FCGI_STDOUT, $self->{req_id}, $stdout);
    }
    if ($is_eof) {
        $io->{out_buf} .= _pack_pkt(FCGI_STDOUT, $self->{req_id}, q{});
        $io->{out_buf} .= _pack_pkt(FCGI_END_REQUEST, $self->{req_id}, END_REQUEST_COMPLETE);
        $io->{wait_for} |= SENT;
    }
    $io->write();
    return;
}

sub IO {
    my ($self, $io, $e, $err) = @_;
    if ($err) {
        warn "FCGI::EV: IO: $err\n";
        return $io->close();
    }
    if ($e & EOF) {
        return $io->close();
    }
    if ($e & SENT) {
        return $io->close();
    }
    while (length $io->{in_buf} >= $io->{Need_in}) {
        if ($io->{Wait_header}) {
            $io->{Wait_header}  = 0;
            my ($content_len, $padding_len) = unpack 'x4 n C', $io->{in_buf};
            $io->{Need_in} += $content_len + $padding_len;
        }
        else {
            my $pkt = substr $io->{in_buf}, 0, $io->{Need_in}, q{};
            $io->{Wait_header}  = 1;
            $io->{Need_in}      = FCGI_HEADER_LEN;
            my $error = $self->_process($pkt);
            if ($error) {
                warn "FCGI::EV: $error\n";
                return $io->close();
            }
        }
    }
    return;
}

sub _process {
    my ($self, $pkt) = @_;
    my ($ver, $type, $req_id, $content_len) = unpack 'C C n n', $pkt;
    my $content = substr $pkt, FCGI_HEADER_LEN, $content_len;
    if ($ver != FCGI_VERSION_1) {
        return "unsupported version: $ver";
    }
    if (defined $self->{req_id} && $self->{req_id} != $req_id) {
        return "unknown request id: $req_id";
    }