File Coverage

blib/lib/HTTP/Entity/Parser.pm

Criterion	Covered	Total	%
statement	75	84	89.2
branch	19	30	63.3
condition	5	8	62.5
subroutine	9	9	100.0
pod	3	3	100.0
total	111	134	82.8

package HTTP::Entity::Parser;

use 5.008001;
use strict;
use warnings;
use Stream::Buffered;
use Module::Load;

our $VERSION = "0.25";

our $BUFFER_LENGTH = 65536;

our %LOADED;
our @DEFAULT_PARSER = qw/
    OctetStream
    UrlEncoded
    MultiPart
    JSON
/;
for my $parser ( @DEFAULT_PARSER ) {
    load "HTTP::Entity::Parser::".$parser;
    $LOADED{"HTTP::Entity::Parser::".$parser} = 1;
}

sub new {
    my $class = shift;
    my %args = (
        buffer_length => $BUFFER_LENGTH,
        @_,
    );
    bless [ [], $args{buffer_length} ], $class;
}

sub register {
    my ($self,$content_type, $klass, $opts) = @_;
    if ( !$LOADED{$klass} ) {
        load $klass;
        $LOADED{$klass} = 1;
    }
    push @{$self->[0]}, [$content_type, $klass, $opts];
}

sub parse {
    my ($self, $env) = @_;

    my $buffer_length = $self->[1];
    my $ct = $env->{CONTENT_TYPE} || '';

    my $parser;
    for my $handler (@{$self->[0]}) {
        if ( $ct eq $handler->[0] || index($ct, $handler->[0]) == 0) {
            $parser = $handler->[1]->new($env, $handler->[2]);
            last;
        }
    }

    if ( !$parser ) {
        $parser = HTTP::Entity::Parser::OctetStream->new();
    }


    my $input = $env->{'psgi.input'};
    if (!$input) {
        # no input
        return ([], []);
    }

    my $buffer;
    if ($env->{'psgix.input.buffered'}) {
        # Just in case if input is read by middleware/apps beforehand
        $input->seek(0, 0);
    } else {
        $buffer = Stream::Buffered->new();
    }

    my $chunked = do { no warnings; lc delete $env->{HTTP_TRANSFER_ENCODING} eq 'chunked' };
    if ( my $cl = $env->{CONTENT_LENGTH} ) {
        my $spin = 0;
        while ($cl > 0) {
            $input->read(my $chunk, $cl < $buffer_length ? $cl : $buffer_length);
            my $read = length $chunk;
            $cl -= $read;
            $parser->add($chunk);
            $buffer->print($chunk) if $buffer;
            if ($read == 0 && $spin++ > 2000) {
                Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
            }
        }
    }
    elsif ($chunked) {
        my $chunk_buffer = '';
        my $length;
        my $spin = 0;
        DECHUNK: while(1) {
            $input->read(my $chunk, $buffer_length);
            my $read = length $chunk;
            if ($read == 0 ) {
                Carp::croak "Malformed chunked request" if $spin++ > 2000;
                next;
            }
            $chunk_buffer .= $chunk;
            while ( $chunk_buffer =~ s/^(([0-9a-fA-F]+).*\015\012)// ) {
                my $trailer   = $1;
                my $chunk_len = hex $2;
                if ($chunk_len == 0) {
                    last DECHUNK;
                } elsif (length $chunk_buffer < $chunk_len + 2) {
                    $chunk_buffer = $trailer . $chunk_buffer;
                    last;
                }
                my $loaded = substr $chunk_buffer, 0, $chunk_len, '';
                $parser->add($loaded);
                $buffer->print($loaded);
                $chunk_buffer =~ s/^\015\012//;
                $length += $chunk_len;
            }
        }
        $env->{CONTENT_LENGTH} = $length;
    }

    if ($buffer) {
        $env->{'psgix.input.buffered'} = 1;
        $env->{'psgi.input'} = $buffer->rewind;
    } else {
        $input->seek(0, 0);
    }

    $parser->finalize();
}

1;
__END__