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