File Coverage

blib/lib/HTTP/Entity/Parser.pm
Criterion Covered Total %
statement 76 86 88.3
branch 20 32 62.5
condition 4 6 66.6
subroutine 9 9 100.0
pod 3 3 100.0
total 112 136 82.3


line stmt bran cond sub pod time code
1             package HTTP::Entity::Parser;
2              
3 4     4   210520 use 5.008001;
  4         40  
4 4     4   21 use strict;
  4         9  
  4         82  
5 4     4   18 use warnings;
  4         8  
  4         141  
6 4     4   1837 use Stream::Buffered;
  4         55746  
  4         112  
7 4     4   2113 use Module::Load;
  4         4658  
  4         24  
8              
9             our $VERSION = "0.24";
10              
11             our $BUFFER_LENGTH = 65536;
12              
13             our %LOADED;
14             our @DEFAULT_PARSER = qw/
15             OctetStream
16             UrlEncoded
17             MultiPart
18             JSON
19             /;
20             for my $parser ( @DEFAULT_PARSER ) {
21             load "HTTP::Entity::Parser::".$parser;
22             $LOADED{"HTTP::Entity::Parser::".$parser} = 1;
23             }
24              
25             sub new {
26 27     27 1 93653 my $class = shift;
27 27         103 my %args = (
28             buffer_length => $BUFFER_LENGTH,
29             @_,
30             );
31 27         112 bless [ [], $args{buffer_length} ], $class;
32             }
33              
34             sub register {
35 24     24 1 119 my ($self,$content_type, $klass, $opts) = @_;
36 24 50       112 if ( !$LOADED{$klass} ) {
37 0         0 load $klass;
38 0         0 $LOADED{$klass} = 1;
39             }
40 24         39 push @{$self->[0]}, [$content_type, $klass, $opts];
  24         111  
41             }
42              
43             sub parse {
44 26     26 1 142 my ($self, $env) = @_;
45              
46 26         90 my $buffer_length = $self->[1];
47 26         46 my $ct = $env->{CONTENT_TYPE};
48 26 50       68 if (!$ct) {
49             # No Content-Type
50 0         0 return ([], []);
51             }
52              
53 26         41 my $parser;
54 26         40 for my $handler (@{$self->[0]}) {
  26         62  
55 24 100 100     137 if ( $ct eq $handler->[0] || index($ct, $handler->[0]) == 0) {
56 22         137 $parser = $handler->[1]->new($env, $handler->[2]);
57 22         50 last;
58             }
59             }
60              
61 26 100       71 if ( !$parser ) {
62 4         20 $parser = HTTP::Entity::Parser::OctetStream->new();
63             }
64              
65              
66 26         48 my $input = $env->{'psgi.input'};
67 26 100       56 if (!$input) {
68             # no input
69 2         15 return ([], []);
70             }
71              
72 24         39 my $buffer;
73 24 50       54 if ($env->{'psgix.input.buffered'}) {
74             # Just in case if input is read by middleware/apps beforehand
75 0         0 $input->seek(0, 0);
76             } else {
77 24         117 $buffer = Stream::Buffered->new();
78             }
79              
80 4     4   1587 my $chunked = do { no warnings; lc delete $env->{HTTP_TRANSFER_ENCODING} eq 'chunked' };
  4         18  
  4         1787  
  24         852  
  24         92  
81 24 100       73 if ( my $cl = $env->{CONTENT_LENGTH} ) {
    50          
82 21         34 my $spin = 0;
83 21         60 while ($cl > 0) {
84 21 50       118 $input->read(my $chunk, $cl < $buffer_length ? $cl : $buffer_length);
85 21         384 my $read = length $chunk;
86 21         41 $cl -= $read;
87 21         89 $parser->add($chunk);
88 21 50       446 $buffer->print($chunk) if $buffer;
89 21 50 33     474 if ($read == 0 && $spin++ > 2000) {
90 0         0 Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
91             }
92             }
93             }
94             elsif ($chunked) {
95 3         9 my $chunk_buffer = '';
96 3         6 my $length;
97 3         6 my $spin = 0;
98 3         7 DECHUNK: while(1) {
99 3         16 $input->read(my $chunk, $buffer_length);
100 3         83 my $read = length $chunk;
101 3 50       16 if ($read == 0 ) {
102 0 0       0 Carp::croak "Malformed chunked request" if $spin++ > 2000;
103 0         0 next;
104             }
105 3         12 $chunk_buffer .= $chunk;
106 3         40 while ( $chunk_buffer =~ s/^(([0-9a-fA-F]+).*\015\012)// ) {
107 21         50 my $trailer = $1;
108 21         46 my $chunk_len = hex $2;
109 21 100       65 if ($chunk_len == 0) {
    50          
110 3         10 last DECHUNK;
111             } elsif (length $chunk_buffer < $chunk_len + 2) {
112 0         0 $chunk_buffer = $trailer . $chunk_buffer;
113 0         0 last;
114             }
115 18         42 my $loaded = substr $chunk_buffer, 0, $chunk_len, '';
116 18         54 $parser->add($loaded);
117 18         135 $buffer->print($loaded);
118 18         278 $chunk_buffer =~ s/^\015\012//;
119 18         71 $length += $chunk_len;
120             }
121             }
122 3         11 $env->{CONTENT_LENGTH} = $length;
123             }
124              
125 24 50       62 if ($buffer) {
126 24         50 $env->{'psgix.input.buffered'} = 1;
127 24         65 $env->{'psgi.input'} = $buffer->rewind;
128             } else {
129 0         0 $input->seek(0, 0);
130             }
131              
132 24         3259 $parser->finalize();
133             }
134              
135             1;
136             __END__