File Coverage

blib/lib/POE/Filter/HTTPChunk.pm
Criterion Covered Total %
statement 100 100 100.0
branch 30 30 100.0
condition n/a
subroutine 13 13 100.0
pod 4 4 100.0
total 147 147 100.0


line stmt bran cond sub pod time code
1             package POE::Filter::HTTPChunk;
2             # vim: ts=2 sw=2 expandtab
3             $POE::Filter::HTTPChunk::VERSION = '0.949';
4 22     22   17459 use warnings;
  22         53  
  22         814  
5 22     22   127 use strict;
  22         47  
  22         770  
6              
7 22     22   121 use Carp;
  22         39  
  22         1465  
8 22     22   123 use bytes;
  22         48  
  22         172  
9 22     22   514 use base 'POE::Filter';
  22         42  
  22         2309  
10              
11 22     22   1378 use HTTP::Response;
  22         23314  
  22         937  
12              
13             use constant {
14 22         2399 FRAMING_BUFFER => 0,
15             CURRENT_STATE => 1,
16             CHUNK_SIZE => 2,
17             CHUNK_BUFFER => 3,
18             TRAILER_HEADERS => 4,
19 22     22   132 };
  22         37  
20              
21             use constant {
22 22         1491 STATE_SIZE => 0x01, # waiting for a status line
23             STATE_DATA => 0x02, # received status, looking for header or end
24             STATE_TRAILER => 0x04, # received status, looking for header or end
25 22     22   118 };
  22         56  
26              
27 22     22   115 use constant DEBUG => 0;
  22         36  
  22         51856  
28              
29             my $HEX = qr/[\dA-Fa-f]/o;
30              
31              
32             sub new {
33 14     14 1 2627 my ($class) = @_;
34              
35 14         62 my $self = bless [
36             [], # FRAMING_BUFFER
37             STATE_SIZE, # CURRENT_STATE
38             0, # CHUNK_SIZE
39             '', # CHUNK_BUFFER
40             undef, # TRAILER_HEADERS
41             ], $class;
42              
43 14         127 return $self;
44             }
45              
46              
47             =for later
48              
49             my $TEXT = qr/[^[:cntrl:]]/o;
50             my $qdtext = qr/[^[:cntrl:]\"]/o; #>
51             my $quoted_pair = qr/\\[[:ascii:]]/o;
52             my $quoted_string = qr/\"(?:$qdtext|$quoted_pair)\"/o;
53             my $separators = "[^()<>@,;:\\"\/\[\]\?={} \t";
54             my $notoken = qr/(?:[[:cntrl:]$separators]/o;
55              
56             my $chunk_ext_name = $token;
57             my $chunk_ext_val = qr/(?:$token|$quoted_string)/o;
58              
59             my $chunk_extension = qr/(?:;$chunk_ext_name(?:$chunk_ext_val)?)/o;
60              
61             =cut
62              
63              
64             sub get_one_start {
65 125     125 1 24002 my ($self, $chunks) = @_;
66              
67             #warn "GOT MORE DATA";
68 125         126 push (@{$self->[FRAMING_BUFFER]}, @$chunks);
  125         333  
69             #warn "NUMBER OF CHUNKS is now ", scalar @{$self->[FRAMING_BUFFER]};
70             }
71              
72              
73             sub get_one {
74 147     147 1 10298 my $self = shift;
75              
76 147         194 my $retval = [];
77 147         152 while (defined (my $chunk = shift (@{$self->[FRAMING_BUFFER]}))) {
  281         674  
78             #warn "CHUNK IS SIZE ", length($chunk);
79             #warn join(
80             # ",", map {sprintf("%02X", ord($_))} split (//, substr ($chunk, 0, 10))
81             #);
82             #warn "NUMBER OF CHUNKS is ", scalar @{$self->[FRAMING_BUFFER]};
83 168         144 DEBUG and warn "STATE is ", $self->[CURRENT_STATE];
84              
85             # if we're not in STATE_DATA, we need to have a newline sequence
86             # in our hunk of content to find out how far we are.
87 168 100       315 unless ($self->[CURRENT_STATE] & STATE_DATA) {
88 63 100       194 if ($chunk !~ /.\015?\012/s) {
89             #warn "SPECIAL CASE";
90 22 100       28 if (@{$self->[FRAMING_BUFFER]} == 0) {
  22         55  
91             #warn "pushing $chunk back";
92 18         21 unshift (@{$self->[FRAMING_BUFFER]}, $chunk);
  18         40  
93 18         56 return $retval;
94             }
95             else {
96 4         5 $chunk .= shift (@{$self->[FRAMING_BUFFER]});
  4         8  
97             #warn "added to $chunk";
98             }
99             }
100             }
101              
102 150 100       258 if ($self->[CURRENT_STATE] & STATE_SIZE) {
103 43         44 DEBUG and warn "Finding chunk length marker";
104 43 100       651 if (
105             $chunk =~ s/^($HEX+)[^\S\015\012]*(?:;.*?)?[^\S\015\012]*\015?\012//s
106             ) {
107 39         83 my $length = hex($1);
108 39         36 DEBUG and warn "Chunk should be $length bytes";
109 39         43 $self->[CHUNK_SIZE] = $length;
110 39 100       65 if ($length == 0) {
111 12         51 $self->[TRAILER_HEADERS] = HTTP::Headers->new;
112 12         95 $self->[CURRENT_STATE] = STATE_TRAILER;
113             }
114             else {
115 27         47 $self->[CURRENT_STATE] = STATE_DATA;
116             }
117             }
118             else {
119             # ok, this is a hack. skip to the next line if we
120             # don't find the chunk length, it might just be an extra
121             # line or something, and the chunk length always is on
122             # a line of it's own, so this seems the only way to recover
123             # somewhat.
124             #TODO: after discussing on IRC, the concensus was to return
125             #an error Response here, and have the client shut down the
126             #connection.
127 4         4 DEBUG and warn "DIDN'T FIND CHUNK LENGTH $chunk";
128 4         13 my $replaceN = $chunk =~ s/.*?\015?\012//s;
129 4 100       9 unshift (@{$self->[FRAMING_BUFFER]}, $chunk) if ($replaceN == 1);
  3         6  
130 4         12 return $retval;
131             }
132             }
133              
134 146 100       288 if ($self->[CURRENT_STATE] & STATE_DATA) {
135 132         185 my $len = $self->[CHUNK_SIZE] - length ($self->[CHUNK_BUFFER]);
136 132         108 DEBUG and
137             warn "going for length ", $self->[CHUNK_SIZE], " (need $len more)";
138 132         187 my $newchunk = $self->[CHUNK_BUFFER];
139 132         163 $self->[CHUNK_BUFFER] = "";
140 132         270 $newchunk .= substr ($chunk, 0, $len, '');
141             #warn "got " . length($newchunk) . " bytes of data";
142 132 100       264 if (length $newchunk != $self->[CHUNK_SIZE]) {
143             #smaller, so wait
144 105         253 $self->[CHUNK_BUFFER] = $newchunk;
145 105         181 next;
146             }
147 27         38 $self->[CURRENT_STATE] = STATE_SIZE;
148             #warn "BACK TO FINDING CHUNK SIZE $chunk";
149 27 100       55 if (length ($chunk) > 0) {
150 26         28 DEBUG and warn "we still have a bit $chunk ", length($chunk);
151             #warn "'", substr ($chunk, 0, 10), "'";
152 26         109 $chunk =~ s/^\015?\012//s;
153             #warn "'", substr ($chunk, 0, 10), "'";
154 26         31 unshift (@{$self->[FRAMING_BUFFER]}, $chunk);
  26         476  
155             }
156 27         70 push @$retval, $newchunk;
157             #return [$newchunk];
158             }
159              
160 41 100       103 if ($self->[CURRENT_STATE] & STATE_TRAILER) {
161 14         51 while ($chunk =~ s/^([-\w]+):\s*(.*?)\015?\012//s) {
162 2         3 DEBUG and warn "add trailer header $1";
163 2         10 $self->[TRAILER_HEADERS]->push_header ($1, $2);
164             }
165             #warn "leftover: ", $chunk;
166             #warn join (
167             # ",",
168             # map {sprintf("%02X", ord($_))} split (//, substr ($chunk, 0, 10))
169             #), "\n";
170 14 100       87 if ($chunk =~ s/^\015?\012//s) {
171 2         5 my $headers = delete $self->[TRAILER_HEADERS];
172              
173 2         3 push (@$retval, $headers);
174 2         2 DEBUG and warn "returning ", scalar @$retval, "responses";
175 2 100       6 unshift (@{$self->[FRAMING_BUFFER]}, $chunk) if (length $chunk);
  1         2  
176 2         7 return $retval;
177             }
178 12 100       13 if (@{$self->[FRAMING_BUFFER]}) {
  12         27  
179 2         6 $self->[FRAMING_BUFFER]->[0] = $chunk . $self->[FRAMING_BUFFER]->[0];
180             } else {
181 10         12 unshift (@{$self->[FRAMING_BUFFER]}, $chunk);
  10         17  
182 10         30 return $retval;
183             }
184             }
185             }
186 113         229 return $retval;
187             }
188              
189              
190             =for future
191              
192             sub put {
193             die "not implemented yet";
194             }
195              
196             =cut
197              
198              
199             sub get_pending {
200 5     5 1 577 my $self = shift;
201 5 100       6 return $self->[FRAMING_BUFFER] if @{$self->[FRAMING_BUFFER]};
  5         24  
202 1         4 return undef;
203             }
204              
205              
206             __END__