view release on metacpan or  search on metacpan

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

                    $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);
    ${*$self}{'httpd_head'}         = ($method eq "HEAD");

    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 $tr_enc  = $r->header('Transfer-Encoding');
    my $ct_type = $r->header('Content-Type');
    my $ct_len  = $r->header('Content-Length');

    # Act on the Expect header, if it's there
    for my $e ($r->header('Expect')) {
        if (lc($e) eq '100-continue') {
            $self->send_status_line(100);
            $self->send_crlf;
        }
        else {
            $self->send_error(417);
            $self->reason("Unsupported Expect header value");
            return;
        }
    }

    if ($tr_enc && lc($tr_enc) 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);