ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC vs.
Revision 1.13 by root, Thu Jun 5 16:43:45 2008 UTC

… …
121Whether to recurse requests or not, e.g. on redirects, authentication 121Whether to recurse requests or not, e.g. on redirects, authentication
122retries and so on, and how often to do so. 122retries and so on, and how often to do so.
123 123
124=item headers => hashref 124=item headers => hashref
125 125
126The request headers to use. 126The request headers to use. Currently, C<http_request> may provide its
127own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
128and will provide defaults for C<User-Agent:> and C<Referer:>.
127 129
128=item timeout => $seconds 130=item timeout => $seconds
129 131
130The time-out to use for various stages - each connect attempt will reset 132The time-out to use for various stages - each connect attempt will reset
131the timeout, as will read or write activity. Default timeout is 5 minutes. 133the timeout, as will read or write activity. Default timeout is 5 minutes.
… …
181 } 183 }
182 ; 184 ;
183 185
184=cut 186=cut
185 187
188sub _slot_schedule;
186sub _slot_schedule($) { 189sub _slot_schedule($) {
187 my $host = shift; 190 my $host = shift;
188 191
189 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) { 192 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
190 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) { 193 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
191 # somebody wnats that slot 194 # somebody wants that slot
192 ++$CO_SLOT{$host}[0]; 195 ++$CO_SLOT{$host}[0];
193 196
194 $cb->(AnyEvent::Util::guard { 197 $cb->(AnyEvent::Util::guard {
195 --$CO_SLOT{$host}[0]; 198 --$CO_SLOT{$host}[0];
196 _slot_schedule $host; 199 _slot_schedule $host;
197 }); 200 });
198 } else { 201 } else {
199 # nobody wants the slot, maybe we can forget about it 202 # nobody wants the slot, maybe we can forget about it
200 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0]; 203 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
201 warn "$host deleted" unless $CO_SLOT{$host}[0];#d#
202 last; 204 last;
203 } 205 }
204 } 206 }
205} 207}
206 208
… …
241 $scheme = lc $scheme; 243 $scheme = lc $scheme;
242 244
243 my $uport = $scheme eq "http" ? 80 245 my $uport = $scheme eq "http" ? 80
244 : $scheme eq "https" ? 443 246 : $scheme eq "https" ? 443
245 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" }); 247 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" });
248
249 $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
246 250
247 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 251 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
248 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 252 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" });
249 253
250 my $uhost = $1; 254 my $uhost = $1;
… …
396 $arg{cookie_jar}{version} = 1; 400 $arg{cookie_jar}{version} = 1;
397 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 401 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
398 } 402 }
399 } 403 }
400 404
401 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) { 405 if ($_[1]{Status} =~ /^30[12]$/ && $recurse) {
402 # microsoft and other assholes don't give a shit for following standards, 406 # microsoft and other assholes don't give a shit for following standards,
403 # try to support a common form of broken Location header. 407 # try to support a common form of broken Location header.
404 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%; 408 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
405 409
406 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 410 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines