view release on metacpan or  search on metacpan

README  view on Meta::CPAN

                    $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
                    $self->reason("Very long header");
                    return;
                }
            }
            else {
                last READ_HEADER;  # HTTP/0.9 client
            }
        }
        elsif (length($buf) > 16*1024) {
            $self->send_error(414); # REQUEST_URI_TOO_LARGE
            $self->reason("Very long first line");
            return;
        }
        print STDERR "Need more data for complete header\n" if $DEBUG;
        return unless $self->_need_more($buf, $timeout, $fdset);
    }
    if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
        ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
        $self->send_error(400);  # BAD_REQUEST
        $self->reason("Bad request line: $buf");
        return;
    }
    my $method = $1;
    my $uri = $2;
    my $proto = $3 || "HTTP/0.9";
    $uri = "http://$uri" if $method eq "CONNECT";
    $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
    my $r = HTTP::Request->new($method, $uri);
    $r->protocol($proto);
    ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);

    if ($proto >= $HTTP_1_0) {

        # we expect to find some headers
        my($key, $val);
        HEADER:
        while ($buf =~ s/^([^\012]*)\012//) {
            $_ = $1;
            s/\015$//;
            if (/^([^:\s]+)\s*:\s*(.*)/) {
                $r->push_header($key, $val) if $key;
                ($key, $val) = ($1, $2);
            }
            elsif (/^\s+(.*)/) {
                $val .= " $1";
            }
            else {
                last HEADER;
            }
        }
        $r->push_header($key, $val) if $key;
    }

    my $conn = $r->header('Connection');
    if ($proto >= $HTTP_1_1) {
        ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
    }
    else {
        ${*$self}{'httpd_nomore'}++ unless $conn &&
          lc($conn) =~ /\bkeep-alive\b/;
    }

    if ($only_headers) {
        ${*$self}{'httpd_rbuf'} = $buf;
        return $r;
    }

    # Find out how much content to read
    my $te  = $r->header('Transfer-Encoding');
    my $ct  = $r->header('Content-Type');
    my $len = $r->header('Content-Length');

    if ($te && lc($te) eq 'chunked') {

        # Handle chunked transfer encoding
        my $body = "";
        CHUNK:
        while (1) {
            print STDERR "Chunked\n" if $DEBUG;
            if ($buf =~ s/^([^\012]*)\012//) {
                my $chunk_head = $1;
                unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
                    $self->send_error(400);
                    $self->reason("Bad chunk header $chunk_head");
                    return;
                }
                my $size = hex($1);
                last CHUNK if $size == 0;

                my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end

                # must read until we have a complete chunk
                while ($missing > 0) {
                    print STDERR "Need $missing more bytes\n" if $DEBUG;
                    my $n = $self->_need_more($buf, $timeout, $fdset);
                    return unless $n;
                    $missing -= $n;
                }
                $body .= substr($buf, 0, $size);
                substr($buf, 0, $size+2) = '';

            }
            else {

                # need more data in order to have a complete chunk header
                return unless $self->_need_more($buf, $timeout, $fdset);
            }
        }
        $r->content($body);

        # pretend it was a normal entity body
        $r->remove_header('Transfer-Encoding');
        $r->header('Content-Length', length($body));

        my($key, $val);
        FOOTER:
        while (1) {
            if ($buf !~ /\012/) {

                # need at least one line to look at