| … | |
… | |
| 364 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
364 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
| 365 | |
365 | |
| 366 | _slot_schedule $_[0]; |
366 | _slot_schedule $_[0]; |
| 367 | } |
367 | } |
| 368 | |
368 | |
|
|
369 | sub cookie_jar_extract($$$$) { |
|
|
370 | my ($jar, $uscheme, $uhost, $upath) = @_; |
|
|
371 | |
|
|
372 | %$jar = () if $jar->{version} != 1; |
|
|
373 | |
|
|
374 | my @cookies; |
|
|
375 | |
|
|
376 | while (my ($chost, $paths) = each %$jar) { |
|
|
377 | next unless ref $paths; |
|
|
378 | |
|
|
379 | if ($chost =~ /^\./) { |
|
|
380 | next unless $chost eq substr $uhost, -length $chost; |
|
|
381 | } elsif ($chost =~ /\./) { |
|
|
382 | next unless $chost eq $uhost; |
|
|
383 | } else { |
|
|
384 | next; |
|
|
385 | } |
|
|
386 | |
|
|
387 | while (my ($cpath, $cookies) = each %$paths) { |
|
|
388 | next unless $cpath eq substr $upath, 0, length $cpath; |
|
|
389 | |
|
|
390 | while (my ($cookie, $kv) = each %$cookies) { |
|
|
391 | next if $uscheme ne "https" && exists $kv->{secure}; |
|
|
392 | |
|
|
393 | if (exists $kv->{expires}) { |
|
|
394 | if (AE::now > parse_date ($kv->{expires})) { |
|
|
395 | delete $cookies->{$cookie}; |
|
|
396 | next; |
|
|
397 | } |
|
|
398 | } |
|
|
399 | |
|
|
400 | my $value = $kv->{value}; |
|
|
401 | |
|
|
402 | if ($value =~ /[=;,[:space:]]/) { |
|
|
403 | $value =~ s/([\\"])/\\$1/g; |
|
|
404 | $value = "\"$value\""; |
|
|
405 | } |
|
|
406 | |
|
|
407 | push @cookies, "$cookie=$value"; |
|
|
408 | } |
|
|
409 | } |
|
|
410 | } |
|
|
411 | |
|
|
412 | \@cookies |
|
|
413 | } |
|
|
414 | |
| 369 | # continue to parse $_ for headers and place them into the arg |
415 | # continue to parse $_ for headers and place them into the arg |
| 370 | sub parse_hdr() { |
416 | sub parse_hdr() { |
| 371 | my %hdr; |
417 | my %hdr; |
| 372 | |
418 | |
| 373 | # things seen, not parsed: |
419 | # things seen, not parsed: |
| … | |
… | |
| 448 | |
494 | |
| 449 | $upath =~ s%^/?%/%; |
495 | $upath =~ s%^/?%/%; |
| 450 | |
496 | |
| 451 | # cookie processing |
497 | # cookie processing |
| 452 | if (my $jar = $arg{cookie_jar}) { |
498 | if (my $jar = $arg{cookie_jar}) { |
| 453 | %$jar = () if $jar->{version} != 1; |
499 | my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath; |
| 454 | |
|
|
| 455 | my @cookie; |
|
|
| 456 | |
|
|
| 457 | while (my ($chost, $paths) = each %$jar) { |
|
|
| 458 | if ($chost =~ /^\./) { |
|
|
| 459 | next unless $chost eq substr $uhost, -length $chost; |
|
|
| 460 | } elsif ($chost =~ /\./) { |
|
|
| 461 | next unless $chost eq $uhost; |
|
|
| 462 | } else { |
|
|
| 463 | next; |
|
|
| 464 | } |
|
|
| 465 | |
500 | |
| 466 | while (my ($cpath, $cookies) = each %$paths) { |
|
|
| 467 | next unless $cpath eq substr $upath, 0, length $cpath; |
|
|
| 468 | |
|
|
| 469 | while (my ($cookie, $kv) = each %$cookies) { |
|
|
| 470 | next if $uscheme ne "https" && exists $kv->{secure}; |
|
|
| 471 | |
|
|
| 472 | if (exists $kv->{expires}) { |
|
|
| 473 | if (AE::now > parse_date ($kv->{expires})) { |
|
|
| 474 | delete $cookies->{$cookie}; |
|
|
| 475 | next; |
|
|
| 476 | } |
|
|
| 477 | } |
|
|
| 478 | |
|
|
| 479 | my $value = $kv->{value}; |
|
|
| 480 | $value =~ s/([\\"])/\\$1/g; |
|
|
| 481 | push @cookie, "$cookie=\"$value\""; |
|
|
| 482 | } |
|
|
| 483 | } |
|
|
| 484 | } |
|
|
| 485 | |
|
|
| 486 | $hdr{cookie} = join "; ", @cookie |
501 | $hdr{cookie} = join "; ", @$cookies |
| 487 | if @cookie; |
502 | if @$cookies; |
| 488 | } |
503 | } |
| 489 | |
504 | |
| 490 | my ($rhost, $rport, $rscheme, $rpath); # request host, port, path |
505 | my ($rhost, $rport, $rscheme, $rpath); # request host, port, path |
| 491 | |
506 | |
| 492 | if ($proxy) { |
507 | if ($proxy) { |
