| … | |
… | |
| 244 | |
244 | |
| 245 | my $uport = $scheme eq "http" ? 80 |
245 | my $uport = $scheme eq "http" ? 80 |
| 246 | : $scheme eq "https" ? 443 |
246 | : $scheme eq "https" ? 443 |
| 247 | : 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 | |
248 | |
|
|
249 | $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic |
|
|
250 | |
| 249 | $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x |
251 | $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x |
| 250 | or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); |
252 | or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); |
| 251 | |
253 | |
| 252 | my $uhost = $1; |
254 | my $uhost = $1; |
| 253 | $uport = $2 if defined $2; |
255 | $uport = $2 if defined $2; |
| 254 | |
256 | |
| 255 | $uhost =~ s/^\[(.*)\]$/$1/; |
257 | $uhost =~ s/^\[(.*)\]$/$1/; |
| 256 | $upath .= "?$query" if length $query; |
258 | $upath .= "?$query" if length $query; |
| 257 | |
259 | |
| 258 | $upath =~ s%^/?%/%; |
260 | $upath =~ s%^/?%/%; |
| 259 | |
|
|
| 260 | $hdr{referer} ||= "$scheme://$authority$upath"; |
|
|
| 261 | |
261 | |
| 262 | # cookie processing |
262 | # cookie processing |
| 263 | if (my $jar = $arg{cookie_jar}) { |
263 | if (my $jar = $arg{cookie_jar}) { |
| 264 | %$jar = () if $jar->{version} < 1; |
264 | %$jar = () if $jar->{version} < 1; |
| 265 | |
265 | |
| … | |
… | |
| 400 | $arg{cookie_jar}{version} = 1; |
400 | $arg{cookie_jar}{version} = 1; |
| 401 | $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; |
401 | $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; |
| 402 | } |
402 | } |
| 403 | } |
403 | } |
| 404 | |
404 | |
| 405 | if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) { |
405 | if ($_[1]{Status} =~ /^30[12]$/ && $recurse) { |
| 406 | # 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, |
| 407 | # try to support a common form of broken Location header. |
407 | # try to support a common form of broken Location header. |
| 408 | $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%; |
408 | $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%; |
| 409 | |
409 | |
| 410 | http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
410 | http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
