… | |
… | |
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); |