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