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__ |