| … | |
… | |
| 290 | %$jar = () if $jar->{version} < 1; |
290 | %$jar = () if $jar->{version} < 1; |
| 291 | |
291 | |
| 292 | my @cookie; |
292 | my @cookie; |
| 293 | |
293 | |
| 294 | while (my ($chost, $v) = each %$jar) { |
294 | while (my ($chost, $v) = each %$jar) { |
|
|
295 | if ($chost =~ /^\./) { |
| 295 | next unless $chost eq substr $uhost, -length $chost; |
296 | next unless $chost eq substr $uhost, -length $chost; |
| 296 | next unless $chost =~ /^\./; |
297 | } elsif ($chost =~ /\./) { |
|
|
298 | next unless $chost eq $uhost; |
|
|
299 | } else { |
|
|
300 | next; |
|
|
301 | } |
| 297 | |
302 | |
| 298 | while (my ($cpath, $v) = each %$v) { |
303 | while (my ($cpath, $v) = each %$v) { |
| 299 | next unless $cpath eq substr $upath, 0, length $cpath; |
304 | next unless $cpath eq substr $upath, 0, length $cpath; |
| 300 | |
305 | |
| 301 | while (my ($k, $v) = each %$v) { |
306 | while (my ($k, $v) = each %$v) { |
| … | |
… | |
| 385 | |
390 | |
| 386 | # headers, could be optimized a bit |
391 | # headers, could be optimized a bit |
| 387 | $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { |
392 | $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { |
| 388 | for ("$_[1]\012") { |
393 | for ("$_[1]\012") { |
| 389 | # we support spaces in field names, as lotus domino |
394 | # we support spaces in field names, as lotus domino |
| 390 | # creates them. |
395 | # creates them (actually spaces around seperators |
|
|
396 | # are strictly allowed in http, they are a security issue). |
| 391 | $hdr{lc $1} .= "\x00$2" |
397 | $hdr{lc $1} .= "\x00$2" |
| 392 | while /\G |
398 | while /\G |
| 393 | ([^:\000-\037]+): |
399 | ([^:\000-\037]+): |
| 394 | [\011\040]* |
400 | [\011\040]* |
| 395 | ((?: [^\015\012]+ | \015?\012[\011\040] )*) |
401 | ((?: [^\015\012]+ | \015?\012[\011\040] )*) |
| … | |
… | |
| 402 | |
408 | |
| 403 | substr $_, 0, 1, "" |
409 | substr $_, 0, 1, "" |
| 404 | for values %hdr; |
410 | for values %hdr; |
| 405 | |
411 | |
| 406 | my $finish = sub { |
412 | my $finish = sub { |
|
|
413 | # TODO: use destroy method, when/if available |
|
|
414 | #$state{handle}->destroy; |
|
|
415 | $state{handle}->on_eof (undef); |
|
|
416 | $state{handle}->on_error (undef); |
| 407 | %state = (); |
417 | %state = (); |
| 408 | |
418 | |
| 409 | # set-cookie processing |
419 | # set-cookie processing |
| 410 | if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) { |
420 | if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) { |
| 411 | for (split /\x00/, $hdr{"set-cookie"}) { |
421 | for (split /\x00/, $hdr{"set-cookie"}) { |
| 412 | my ($cookie, @arg) = split /;\s*/; |
422 | my ($cookie, @arg) = split /;\s*/; |
| 413 | my ($name, $value) = split /=/, $cookie, 2; |
423 | my ($name, $value) = split /=/, $cookie, 2; |
| 414 | my %kv = (value => $value, map { split /=/, $_, 2 } @arg); |
424 | my %kv = (value => $value, map { split /=/, $_, 2 } @arg); |
| 415 | |
425 | |
| 416 | my $cdom = (delete $kv{domain}) || $uhost; |
426 | my $cdom; |
| 417 | my $cpath = (delete $kv{path}) || "/"; |
427 | my $cpath = (delete $kv{path}) || "/"; |
|
|
428 | |
|
|
429 | if (exists $kv{domain}) { |
|
|
430 | $cdom = delete $kv{domain}; |
| 418 | |
431 | |
| 419 | $cdom =~ s/^\.?/./; # make sure it starts with a "." |
432 | $cdom =~ s/^\.?/./; # make sure it starts with a "." |
| 420 | |
433 | |
| 421 | next if $cdom =~ /\.$/; |
434 | next if $cdom =~ /\.$/; |
| 422 | |
435 | |
| 423 | # this is not rfc-like and not netscape-like. go figure. |
436 | # this is not rfc-like and not netscape-like. go figure. |
| 424 | my $ndots = $cdom =~ y/.//; |
437 | my $ndots = $cdom =~ y/.//; |
| 425 | next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); |
438 | next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); |
|
|
439 | } else { |
|
|
440 | $cdom = $uhost; |
|
|
441 | } |
| 426 | |
442 | |
| 427 | # store it |
443 | # store it |
| 428 | $arg{cookie_jar}{version} = 1; |
444 | $arg{cookie_jar}{version} = 1; |
| 429 | $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; |
445 | $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; |
| 430 | } |
446 | } |
| … | |
… | |
| 448 | if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") { |
464 | if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") { |
| 449 | # apparently, mozilla et al. just change POST to GET here |
465 | # apparently, mozilla et al. just change POST to GET here |
| 450 | # more research is needed before we do the same |
466 | # more research is needed before we do the same |
| 451 | http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
467 | http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
| 452 | } elsif ($_[1]{Status} == 303 && $recurse) { |
468 | } elsif ($_[1]{Status} == 303 && $recurse) { |
| 453 | # even http/1.1 is unlear on how to mutate the method |
469 | # even http/1.1 is unclear on how to mutate the method |
| 454 | $method = "GET" unless $method eq "HEAD"; |
470 | $method = "GET" unless $method eq "HEAD"; |
| 455 | http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
471 | http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
| 456 | } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) { |
472 | } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) { |
| 457 | http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
473 | http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb); |
| 458 | } else { |
474 | } else { |
