line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyrights 2011 by Mark Overmeer. |
2
|
|
|
|
|
|
|
# For other contributors see ChangeLog. |
3
|
|
|
|
|
|
|
# See the manual pages for details on the licensing terms. |
4
|
|
|
|
|
|
|
# Pod stripped from pm file by OODoc 1.07. |
5
|
1
|
|
|
1
|
|
618
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
30
|
|
6
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
35
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
package IOMux::HTTP; |
9
|
1
|
|
|
1
|
|
14
|
use vars '$VERSION'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
49
|
|
10
|
|
|
|
|
|
|
$VERSION = '0.11'; |
11
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
5
|
use base 'IOMux::Net::TCP'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
787
|
|
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
145935
|
use Log::Report 'iomux-http'; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
13
|
|
15
|
1
|
|
|
1
|
|
359
|
use Time::HiRes qw(time); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
10
|
|
16
|
|
|
|
|
|
|
|
17
|
1
|
|
|
1
|
|
1179
|
use HTTP::Request (); |
|
1
|
|
|
|
|
26204
|
|
|
1
|
|
|
|
|
32
|
|
18
|
1
|
|
|
1
|
|
1093
|
use HTTP::Response (); |
|
1
|
|
|
|
|
6468
|
|
|
1
|
|
|
|
|
33
|
|
19
|
1
|
|
|
1
|
|
10
|
use HTTP::Status; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
400
|
|
20
|
1
|
|
|
1
|
|
1146
|
use HTTP::Date qw(time2str); |
|
1
|
|
|
|
|
4233
|
|
|
1
|
|
|
|
|
67
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
use constant |
23
|
1
|
|
|
|
|
1609
|
{ HTTP_0_9 => 'HTTP/0.9' |
24
|
|
|
|
|
|
|
, HTTP_1_0 => 'HTTP/1.0' |
25
|
|
|
|
|
|
|
, HTTP_1_1 => 'HTTP/1.1' |
26
|
1
|
|
|
1
|
|
8
|
}; |
|
1
|
|
|
|
|
1
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# oops, dirty hack |
29
|
0
|
|
|
0
|
0
|
|
sub HTTP::Message::id() { shift->{IMH_id} } |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
my $conn_id = 'C0000000'; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub init($) |
35
|
0
|
|
|
0
|
0
|
|
{ my ($self, $args) = @_; |
36
|
0
|
|
0
|
|
|
|
$args->{name} ||= ++$conn_id; |
37
|
|
|
|
|
|
|
|
38
|
0
|
|
|
|
|
|
$self->SUPER::init($args); |
39
|
0
|
|
0
|
|
|
|
$self->{IMH_headers} = $args->{add_headers} || []; |
40
|
|
|
|
|
|
|
|
41
|
0
|
|
|
|
|
|
$self->{IMH_requests} = []; |
42
|
0
|
|
|
|
|
|
$self->{IMH_starttime} = time; |
43
|
0
|
|
|
|
|
|
$self->{IMH_msgcount} = 0; # something unique for logging |
44
|
0
|
|
|
|
|
|
$self; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
0
|
|
|
0
|
1
|
|
sub startTime() {shift->{IMH_starttime}} |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub mux_input($) |
51
|
0
|
|
|
0
|
1
|
|
{ my ($self, $refdata) = @_; |
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
|
while($$refdata) # possibly more than one message in one TCP package |
54
|
|
|
|
|
|
|
{ |
55
|
|
|
|
|
|
|
# Read header |
56
|
0
|
|
|
|
|
|
my $msg = $self->{IMH_incoming}; |
57
|
0
|
0
|
|
|
|
|
unless($msg) |
58
|
0
|
0
|
|
|
|
|
{ if($self->{IMH_no_more}) |
59
|
|
|
|
|
|
|
{ # ignore input for closing, connection can still be writing |
60
|
0
|
|
|
|
|
|
$$refdata = ''; |
61
|
0
|
|
|
|
|
|
return; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
0
|
|
|
|
|
|
$$refdata =~ s/^\s+//s; # strip leading blanks, sloppy remote |
65
|
0
|
0
|
|
|
|
|
$$refdata =~ s/(.*?)\r?\n\r?\n//s |
66
|
|
|
|
|
|
|
or return; # not whole header yet, wait for more |
67
|
|
|
|
|
|
|
|
68
|
0
|
|
|
|
|
|
$msg = $self->{IMH_incoming} = $self->headerArrived($1); |
69
|
|
|
|
|
|
|
#trace "new header ".$msg->uri if $msg->isa('HTTP::Request'); |
70
|
|
|
|
|
|
|
|
71
|
0
|
|
|
|
|
|
my $msgid = sprintf 'in-%s-%02d' |
72
|
|
|
|
|
|
|
, $self->name, $self->{IMH_msgcount}++; |
73
|
0
|
|
|
|
|
|
$msg->id($msgid); |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
0
|
|
|
|
|
|
my $headers = $msg->headers; |
77
|
0
|
|
|
|
|
|
my $proto = $msg->protocol; |
78
|
|
|
|
|
|
|
|
79
|
0
|
0
|
|
|
|
|
$msg->protocol($proto = HTTP_0_9) |
80
|
|
|
|
|
|
|
unless $proto; |
81
|
|
|
|
|
|
|
|
82
|
0
|
0
|
0
|
|
|
|
$self->{IMH_no_more}++ |
|
|
|
0
|
|
|
|
|
83
|
|
|
|
|
|
|
if $msg->protocol lt HTTP_1_1 |
84
|
|
|
|
|
|
|
|| lc($headers->header('Connection') || '') ne 'keep-alive'; |
85
|
|
|
|
|
|
|
|
86
|
0
|
0
|
|
|
|
|
$self->{IMH_take_all}++ |
87
|
|
|
|
|
|
|
if $proto lt HTTP_1_0; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
return # simply wait until EOF |
90
|
0
|
0
|
|
|
|
|
if $self->{IMH_take_all}; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# Read body |
93
|
|
|
|
|
|
|
|
94
|
0
|
0
|
|
|
|
|
my $result = $self->bodyComponentArrived($msg, $refdata) |
95
|
|
|
|
|
|
|
or return; # message not ready yet |
96
|
|
|
|
|
|
|
|
97
|
0
|
0
|
|
|
|
|
my $resp = $result->isa('HTTP::Response') ? $result : undef; |
98
|
|
|
|
|
|
|
|
99
|
0
|
0
|
|
|
|
|
$self->shutdown(0) |
100
|
|
|
|
|
|
|
if $self->{IMH_no_more}; |
101
|
|
|
|
|
|
|
|
102
|
0
|
|
|
|
|
|
delete $self->{IMH_incoming}; |
103
|
0
|
|
|
|
|
|
$self->messageArrived($msg, $resp); |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub mux_outputbuffer_empty() |
108
|
0
|
0
|
|
0
|
0
|
|
{ my $more = shift->{IMH_more_output} or return; |
109
|
0
|
|
|
|
|
|
$more->(); |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub mux_eof($) |
113
|
0
|
|
|
0
|
1
|
|
{ my ($self, $refdata) = @_; |
114
|
|
|
|
|
|
|
|
115
|
0
|
|
|
|
|
|
my $msg = delete $self->{IMH_incoming}; # headers only |
116
|
|
|
|
|
|
|
|
117
|
0
|
0
|
0
|
|
|
|
if($msg && length($$refdata) && $self->{IMH_take_all}) |
|
|
|
0
|
|
|
|
|
118
|
0
|
|
|
|
|
|
{ $msg->content_ref($refdata); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
else |
121
|
0
|
0
|
|
|
|
|
{ trace "trailing ".length($$refdata)." bytes ignored" |
122
|
|
|
|
|
|
|
if $$refdata =~ m/\S/; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
0
|
0
|
|
|
|
|
$self->messageArrived($msg) |
126
|
|
|
|
|
|
|
if $msg; |
127
|
|
|
|
|
|
|
|
128
|
0
|
|
|
|
|
|
$self->SUPER::mux_eof($refdata); |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub bodyComponentArrived($$) |
132
|
0
|
|
|
0
|
0
|
|
{ my ($self, $msg, $refdata) = @_; |
133
|
|
|
|
|
|
|
|
134
|
0
|
|
|
|
|
|
my $headers = $msg->headers; |
135
|
0
|
0
|
|
|
|
|
if(my $cl = $headers->header('Content-Length')) |
136
|
0
|
0
|
|
|
|
|
{ return if length($$refdata) < $cl; # wait for more |
137
|
0
|
|
|
|
|
|
$msg->content(substr $$refdata, 0, $cl, ''); |
138
|
0
|
|
|
|
|
|
return $msg; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# No Content-Length for multiparts? |
142
|
0
|
|
0
|
|
|
|
my $ct = $headers->header('Content-Type') || ''; |
143
|
0
|
0
|
|
|
|
|
if($ct =~ m/^multipart\/\w+\s*;.*boundary\s*=(["']?)\s*(\w+)\1/i) |
144
|
0
|
0
|
|
|
|
|
{ $$refdata =~ s/(.*?\r?\n--\Q$2\E--\r?\n)// |
145
|
|
|
|
|
|
|
or return; # multipart terminator not received yet |
146
|
0
|
|
|
|
|
|
$msg->content($1); |
147
|
0
|
|
|
|
|
|
return $msg; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# No Content-Length and not multipart, then no body. |
151
|
0
|
|
|
|
|
|
$msg; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
0
|
|
|
0
|
0
|
|
sub headerArrived($) {panic} |
155
|
0
|
|
|
0
|
0
|
|
sub messageArrived($) {panic} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
#-------------- |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub sendMessage($$) |
160
|
0
|
|
|
0
|
1
|
|
{ my ($self, $msg, $callback) = @_; |
161
|
|
|
|
|
|
|
|
162
|
0
|
0
|
0
|
|
|
|
if($self->mux_output_waiting || $self->{IMH_more_output}) |
163
|
|
|
|
|
|
|
{ # Arggg. Well, some message content still being written. |
164
|
|
|
|
|
|
|
# Do not flood the outbufs with stringified requests. |
165
|
|
|
|
|
|
|
# For instance, a number of large files to be sent back |
166
|
|
|
|
|
|
|
# or uploaded as chunked. |
167
|
0
|
|
|
|
|
|
push @{$self->{IMH_queued}}, [$msg, $callback]; |
|
0
|
|
|
|
|
|
|
168
|
0
|
|
|
|
|
|
return; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# Write the message now, and after that, but do not forget to |
172
|
|
|
|
|
|
|
# handle messages which arrived during this sending after it. |
173
|
0
|
|
|
|
|
|
my $queue_cb; |
174
|
|
|
|
|
|
|
$queue_cb = sub |
175
|
0
|
0
|
|
0
|
|
|
{ my $queued = shift @{$self->{IMH_queued}} or return; |
|
0
|
|
|
|
|
|
|
176
|
0
|
|
|
|
|
|
my ($next_msg, $user_cb) = @$queued; # the next msg |
177
|
0
|
|
|
|
|
|
$self->writeMessage($next_msg, sub {$queue_cb->(); $user_cb->()}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
178
|
0
|
|
|
|
|
|
}; |
179
|
|
|
|
|
|
|
|
180
|
0
|
|
|
|
|
|
$self->writeMessage($msg, $queue_cb); |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub writeMessage($$) |
184
|
0
|
|
|
0
|
0
|
|
{ my ($self, $msg, $callback) = @_; |
185
|
|
|
|
|
|
|
|
186
|
0
|
|
|
|
|
|
my $header = $msg->headers; |
187
|
0
|
|
|
|
|
|
$header->push_header |
188
|
|
|
|
|
|
|
( Date => time2str(time) |
189
|
|
|
|
|
|
|
, Connection => ($self->{IMH_no_more} ? 'close' : 'keep-alive') |
190
|
0
|
0
|
|
|
|
|
, @{$self->{IMH_headers}} |
191
|
|
|
|
|
|
|
); |
192
|
|
|
|
|
|
|
|
193
|
0
|
|
|
|
|
|
my $content = $msg->content; |
194
|
0
|
0
|
|
|
|
|
if(ref $content eq 'CODE') |
195
|
|
|
|
|
|
|
{ # create chunked |
196
|
0
|
|
|
|
|
|
$header->push_header(Transfer_Encoding => 'chunked'); |
197
|
0
|
|
|
|
|
|
my $size = 0; |
198
|
|
|
|
|
|
|
$self->{IMH_more_output} = sub |
199
|
0
|
|
|
0
|
|
|
{ my $chunk = $content->(); |
200
|
0
|
0
|
|
|
|
|
unless(defined $chunk) |
201
|
0
|
|
|
|
|
|
{ delete $self->{IMH_more_output}; |
202
|
0
|
|
|
|
|
|
$self->write("0\r\n\r\n"); # end chunks and no footer |
203
|
0
|
|
|
|
|
|
$size += 5; |
204
|
0
|
|
|
|
|
|
info "sent CHUNKED msg ".$msg->id.' '.$msg->status." ${size}b"; |
205
|
0
|
|
|
|
|
|
return $callback->(); |
206
|
|
|
|
|
|
|
} |
207
|
0
|
0
|
|
|
|
|
length $chunk or return; |
208
|
0
|
|
|
|
|
|
my $hexlen = sprintf "%x", length $chunk; |
209
|
0
|
|
|
|
|
|
$size += length($hexlen) + length($chunk) + 4; |
210
|
0
|
|
|
|
|
|
$self->write("$hexlen\r\n$chunk\r\n"); |
211
|
0
|
|
|
|
|
|
}; |
212
|
0
|
|
|
|
|
|
$self->write(\$header->as_string); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
else |
215
|
|
|
|
|
|
|
{ # write message in one go. |
216
|
0
|
|
|
|
|
|
$header->push_header(Content_Length => length $content); |
217
|
0
|
|
|
|
|
|
$msg->content_ref(\$content); |
218
|
0
|
|
|
|
|
|
my $text = $msg->as_string; |
219
|
0
|
|
|
|
|
|
$self->write(\$text); |
220
|
0
|
0
|
|
|
|
|
info "sent msg ".length($text)."b " |
221
|
|
|
|
|
|
|
.(ref $msg).' '.($msg->isa('HTTP::Request') ? $msg->uri : $msg->content); |
222
|
0
|
|
|
|
|
|
$callback->(); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
|
227
|
0
|
|
|
0
|
1
|
|
sub closeConnection() { shift->{IMH_no_more} = 1 } |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
1; |