ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.70 by root, Fri Dec 31 20:31:47 2010 UTC vs.
Revision 1.75 by root, Sat Jan 1 00:08:51 2011 UTC

… …
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
370sub cookie_jar_extract($$$$) {
371 my ($jar, $uscheme, $uhost, $upath) = @_;
372
373 %$jar = () if $jar->{version} != 1;
374
375 my @cookies;
376
377 while (my ($chost, $paths) = each %$jar) {
378 next unless ref $paths;
379
380 if ($chost =~ /^\./) {
381 next unless $chost eq substr $uhost, -length $chost;
382 } elsif ($chost =~ /\./) {
383 next unless $chost eq $uhost;
384 } else {
385 next;
386 }
387
388 while (my ($cpath, $cookies) = each %$paths) {
389 next unless $cpath eq substr $upath, 0, length $cpath;
390
391 while (my ($cookie, $kv) = each %$cookies) {
392 next if $uscheme ne "https" && exists $kv->{secure};
393
394 if (exists $kv->{expires}) {
395 if (AE::now > parse_date ($kv->{expires})) {
396 delete $cookies->{$cookie};
397 next;
398 }
399 }
400
401 my $value = $kv->{value};
402
403 if ($value =~ /[=;,[:space:]]/) {
404 $value =~ s/([\\"])/\\$1/g;
405 $value = "\"$value\"";
406 }
407
408 push @cookies, "$cookie=$value";
409 }
410 }
411 }
412
413 \@cookies
414}
415
416# parse set_cookie header into jar
417sub cookie_jar_set_cookie($$$) {
418 my ($jar, $set_cookie, $uhost) = @_;
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 $jar->{version} = 1;
478 $jar->{$cdom}{$cpath}{$name} = \%kv;
479
480 redo if /\G\s*,/gc;
481 }
482}
483
369# continue to parse $_ for headers and place them into the arg 484# continue to parse $_ for headers and place them into the arg
370sub parse_hdr() { 485sub parse_hdr() {
371 my %hdr; 486 my %hdr;
372 487
373 # things seen, not parsed: 488 # things seen, not parsed:
… …
448 563
449 $upath =~ s%^/?%/%; 564 $upath =~ s%^/?%/%;
450 565
451 # cookie processing 566 # cookie processing
452 if (my $jar = $arg{cookie_jar}) { 567 if (my $jar = $arg{cookie_jar}) {
453 %$jar = () if $jar->{version} != 1; 568 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 569
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 570 $hdr{cookie} = join "; ", @$cookies
487 if @cookie; 571 if @$cookies;
488 } 572 }
489 573
490 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 574 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
491 575
492 if ($proxy) { 576 if ($proxy) {
… …
523 or do { 607 or do {
524 my $err = "$!"; 608 my $err = "$!";
525 %state = (); 609 %state = ();
526 return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); 610 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
527 }; 611 };
528
529 pop; # free memory, save a tree
530 612
531 return unless delete $state{connect_guard}; 613 return unless delete $state{connect_guard};
532 614
533 # get handle 615 # get handle
534 $state{handle} = new AnyEvent::Handle 616 $state{handle} = new AnyEvent::Handle
… …
638 $redirect = 1; 720 $redirect = 1;
639 } 721 }
640 } 722 }
641 723
642 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 724 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
643 my $keepalive = pop; 725 my $may_keep_alive = $_[3];
644 726
645 $state{handle}->destroy if $state{handle}; 727 $state{handle}->destroy if $state{handle};
646 %state = (); 728 %state = ();
647 729
648 if (defined $_[1]) { 730 if (defined $_[1]) {
… …
650 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; 732 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
651 } 733 }
652 734
653 # set-cookie processing 735 # set-cookie processing
654 if ($arg{cookie_jar}) { 736 if ($arg{cookie_jar}) {
655 for ($hdr{"set-cookie"}) { 737 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
656 # parse NAME=VALUE
657 my @kv;
658
659 while (
660 m{
661 \G\s*
662 (?:
663 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
664 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
665 )
666 }gcxsi
667 ) {
668 my $name = $2;
669 my $value = $4;
670
671 unless (defined $name) {
672 # expires
673 $name = "expires";
674 $value = $1;
675 } elsif (!defined $value) {
676 # quoted
677 $value = $3;
678 $value =~ s/\\(.)/$1/gs;
679 }
680
681 push @kv, lc $name, $value;
682
683 last unless /\G\s*;/gc;
684 }
685
686 last unless @kv;
687
688 my $name = shift @kv;
689 my %kv = (value => shift @kv, @kv);
690
691 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
692 if exists $kv{"max-age"};
693
694 my $cdom;
695 my $cpath = (delete $kv{path}) || "/";
696
697 if (exists $kv{domain}) {
698 $cdom = delete $kv{domain};
699
700 $cdom =~ s/^\.?/./; # make sure it starts with a "."
701
702 next if $cdom =~ /\.$/;
703
704 # this is not rfc-like and not netscape-like. go figure.
705 my $ndots = $cdom =~ y/.//;
706 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
707 } else {
708 $cdom = $uhost;
709 }
710
711 # store it
712 $arg{cookie_jar}{version} = 1;
713 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
714
715 redo if /\G\s*,/gc;
716 }
717 } 738 }
718 739
719 if ($redirect && exists $hdr{location}) { 740 if ($redirect && exists $hdr{location}) {
720 # we ignore any errors, as it is very common to receive 741 # we ignore any errors, as it is very common to receive
721 # Content-Length != 0 but no actual body 742 # Content-Length != 0 but no actual body

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines