… | |
… | |
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 { |