| … | |
… | |
| 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 | # extract cookies from jar |
| 369 | sub cookie_jar_extract($$$$) { |
370 | sub cookie_jar_extract($$$$) { |
| 370 | my ($jar, $uscheme, $uhost, $upath) = @_; |
371 | my ($jar, $uscheme, $uhost, $upath) = @_; |
| 371 | |
372 | |
| 372 | %$jar = () if $jar->{version} != 1; |
373 | %$jar = () if $jar->{version} != 1; |
| 373 | |
374 | |
| … | |
… | |
| 410 | } |
411 | } |
| 411 | |
412 | |
| 412 | \@cookies |
413 | \@cookies |
| 413 | } |
414 | } |
| 414 | |
415 | |
|
|
416 | # parse set_cookie header into jar |
|
|
417 | sub cookie_jar_set_cookie($$) { |
|
|
418 | my ($jar, $set_cookie) = @_; |
|
|
419 | |
|
|
420 | for ($set_cookie) { |
|
|
421 | # parse NAME=VALUE |
|
|
422 | my @kv; |
|
|
423 | |
|
|
424 | while ( |
|
|
425 | m{ |
|
|
426 | \G\s* |
|
|
427 | (?: |
|
|
428 | expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+) |
|
|
429 | | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) |
|
|
430 | ) |
|
|
431 | }gcxsi |
|
|
432 | ) { |
|
|
433 | my $name = $2; |
|
|
434 | my $value = $4; |
|
|
435 | |
|
|
436 | unless (defined $name) { |
|
|
437 | # expires |
|
|
438 | $name = "expires"; |
|
|
439 | $value = $1; |
|
|
440 | } elsif (!defined $value) { |
|
|
441 | # quoted |
|
|
442 | $value = $3; |
|
|
443 | $value =~ s/\\(.)/$1/gs; |
|
|
444 | } |
|
|
445 | |
|
|
446 | push @kv, lc $name, $value; |
|
|
447 | |
|
|
448 | last unless /\G\s*;/gc; |
|
|
449 | } |
|
|
450 | |
|
|
451 | last unless @kv; |
|
|
452 | |
|
|
453 | my $name = shift @kv; |
|
|
454 | my %kv = (value => shift @kv, @kv); |
|
|
455 | |
|
|
456 | $kv{expires} ||= format_date (AE::now + $kv{"max-age"}) |
|
|
457 | if exists $kv{"max-age"}; |
|
|
458 | |
|
|
459 | my $cdom; |
|
|
460 | my $cpath = (delete $kv{path}) || "/"; |
|
|
461 | |
|
|
462 | if (exists $kv{domain}) { |
|
|
463 | $cdom = delete $kv{domain}; |
|
|
464 | |
|
|
465 | $cdom =~ s/^\.?/./; # make sure it starts with a "." |
|
|
466 | |
|
|
467 | next if $cdom =~ /\.$/; |
|
|
468 | |
|
|
469 | # this is not rfc-like and not netscape-like. go figure. |
|
|
470 | my $ndots = $cdom =~ y/.//; |
|
|
471 | next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); |
|
|
472 | } else { |
|
|
473 | $cdom = $uhost; |
|
|
474 | } |
|
|
475 | |
|
|
476 | # store it |
|
|
477 | $arg{cookie_jar}{version} = 1; |
|
|
478 | $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; |
|
|
479 | |
|
|
480 | redo if /\G\s*,/gc; |
|
|
481 | } |
|
|
482 | } |
|
|
483 | } |
|
|
484 | |
| 415 | # continue to parse $_ for headers and place them into the arg |
485 | # continue to parse $_ for headers and place them into the arg |
| 416 | sub parse_hdr() { |
486 | sub parse_hdr() { |
| 417 | my %hdr; |
487 | my %hdr; |
| 418 | |
488 | |
| 419 | # things seen, not parsed: |
489 | # things seen, not parsed: |
| … | |
… | |
| 665 | $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; |
735 | $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; |
| 666 | } |
736 | } |
| 667 | |
737 | |
| 668 | # set-cookie processing |
738 | # set-cookie processing |
| 669 | if ($arg{cookie_jar}) { |
739 | if ($arg{cookie_jar}) { |
| 670 | for ($hdr{"set-cookie"}) { |
740 | cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}; |
| 671 | # parse NAME=VALUE |
|
|
| 672 | my @kv; |
|
|
| 673 | |
|
|
| 674 | while ( |
|
|
| 675 | m{ |
|
|
| 676 | \G\s* |
|
|
| 677 | (?: |
|
|
| 678 | expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+) |
|
|
| 679 | | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) |
|
|
| 680 | ) |
|
|
| 681 | }gcxsi |
|
|
| 682 | ) { |
|
|
| 683 | my $name = $2; |
|
|
| 684 | my $value = $4; |
|
|
| 685 | |
|
|
| 686 | unless (defined $name) { |
|
|
| 687 | # expires |
|
|
| 688 | $name = "expires"; |
|
|
| 689 | $value = $1; |
|
|
| 690 | } elsif (!defined $value) { |
|
|
| 691 | # quoted |
|
|
| 692 | $value = $3; |
|
|
| 693 | $value =~ s/\\(.)/$1/gs; |
|
|
| 694 | } |
|
|
| 695 | |
|
|
| 696 | push @kv, lc $name, $value; |
|
|
| 697 | |
|
|
| 698 | last unless /\G\s*;/gc; |
|
|
| 699 | } |
|
|
| 700 | |
|
|
| 701 | last unless @kv; |
|
|
| 702 | |
|
|
| 703 | my $name = shift @kv; |
|
|
| 704 | my %kv = (value => shift @kv, @kv); |
|
|
| 705 | |
|
|
| 706 | $kv{expires} ||= format_date (AE::now + $kv{"max-age"}) |
|
|
| 707 | if exists $kv{"max-age"}; |
|
|
| 708 | |
|
|
| 709 | my $cdom; |
|
|
| 710 | my $cpath = (delete $kv{path}) || "/"; |
|
|
| 711 | |
|
|
| 712 | if (exists $kv{domain}) { |
|
|
| 713 | $cdom = delete $kv{domain}; |
|
|
| 714 | |
|
|
| 715 | $cdom =~ s/^\.?/./; # make sure it starts with a "." |
|
|
| 716 | |
|
|
| 717 | next if $cdom =~ /\.$/; |
|
|
| 718 | |
|
|
| 719 | # this is not rfc-like and not netscape-like. go figure. |
|
|
| 720 | my $ndots = $cdom =~ y/.//; |
|
|
| 721 | next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); |
|
|
| 722 | } else { |
|
|
| 723 | $cdom = $uhost; |
|
|
| 724 | } |
|
|
| 725 | |
|
|
| 726 | # store it |
|
|
| 727 | $arg{cookie_jar}{version} = 1; |
|
|
| 728 | $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; |
|
|
| 729 | |
|
|
| 730 | redo if /\G\s*,/gc; |
|
|
| 731 | } |
|
|
| 732 | } |
|
|
| 733 | |
741 | |
| 734 | if ($redirect && exists $hdr{location}) { |
742 | if ($redirect && exists $hdr{location}) { |
| 735 | # we ignore any errors, as it is very common to receive |
743 | # we ignore any errors, as it is very common to receive |
| 736 | # Content-Length != 0 but no actual body |
744 | # Content-Length != 0 but no actual body |
| 737 | # we also access %hdr, as $_[1] might be an erro |
745 | # we also access %hdr, as $_[1] might be an erro |
