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.71 by root, Fri Dec 31 20:50:58 2010 UTC vs.
Revision 1.80 by root, Sat Jan 1 21:51:22 2011 UTC

… …
122 122
123If the server sends a header multiple times, then their contents will be 123If the server sends a header multiple times, then their contents will be
124joined together with a comma (C<,>), as per the HTTP spec. 124joined together with a comma (C<,>), as per the HTTP spec.
125 125
126If an internal error occurs, such as not being able to resolve a hostname, 126If an internal error occurs, such as not being able to resolve a hostname,
127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x> 127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
128(usually C<599>) and the C<Reason> pseudo-header will contain an error 128C<590>-C<599> and the C<Reason> pseudo-header will contain an error
129message. 129message. Currently the following status codes are used:
130
131=over 4
132
133=item 595 - errors during connection etsbalishment, proxy handshake.
134
135=item 596 - errors during TLS negotiation, request sending and header processing.
136
137=item 597 - errors during body receiving or processing.
138
139=item 598 - user aborted request via C<on_header> or C<on_body>.
140
141=item 599 - other, usually nonretryable, errors (garbled URL etc.).
142
143=back
130 144
131A typical callback might look like this: 145A typical callback might look like this:
132 146
133 sub { 147 sub {
134 my ($body, $hdr) = @_; 148 my ($body, $hdr) = @_;
… …
182=item cookie_jar => $hash_ref 196=item cookie_jar => $hash_ref
183 197
184Passing this parameter enables (simplified) cookie-processing, loosely 198Passing this parameter enables (simplified) cookie-processing, loosely
185based on the original netscape specification. 199based on the original netscape specification.
186 200
187The C<$hash_ref> must be an (initially empty) hash reference which will 201The C<$hash_ref> must be an (initially empty) hash reference which
188get updated automatically. It is possible to save the cookie jar to 202will get updated automatically. It is possible to save the cookie jar
189persistent storage with something like JSON or Storable, but this is not 203to persistent storage with something like JSON or Storable - see the
190recommended, as session-only cookies might survive longer than expected. 204C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
205expired or session-only cookies, and also for documentation on the format
206of the cookie jar.
191 207
192Note that this cookie implementation is not meant to be complete. If 208Note that this cookie implementation is not meant to be complete. If
193you want complete cookie management you have to do that on your 209you want complete cookie management you have to do that on your
194own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites 210own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
195working. Cookies are a privacy disaster, do not use them unless required 211working. Cookies are a privacy disaster, do not use them unless required
196to. 212to.
197 213
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:> 214When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be set and handled by this module, otherwise they will be 215headers will be set and handled by this module, otherwise they will be
… …
364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 380 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
365 381
366 _slot_schedule $_[0]; 382 _slot_schedule $_[0];
367} 383}
368 384
385#############################################################################
386
387# expire cookies
388sub cookie_jar_expire($;$) {
389 my ($jar, $session_end) = @_;
390
391 %$jar = () if $jar->{version} != 1;
392
393 my $anow = AE::now;
394
395 while (my ($chost, $paths) = each %$jar) {
396 next unless ref $paths;
397
398 while (my ($cpath, $cookies) = each %$paths) {
399 while (my ($cookie, $kv) = each %$cookies) {
400 if (exists $kv->{_expires}) {
401 delete $cookies->{$cookie}
402 if $anow > $kv->{_expires};
403 } elsif ($session_end) {
404 delete $cookies->{$cookie};
405 }
406 }
407
408 delete $paths->{$cpath}
409 unless %$cookies;
410 }
411
412 delete $jar->{$chost}
413 unless %$paths;
414 }
415}
416
417# extract cookies from jar
369sub cookie_jar_extract($$$$) { 418sub cookie_jar_extract($$$$) {
370 my ($jar, $uscheme, $uhost, $upath) = @_; 419 my ($jar, $uscheme, $uhost, $upath) = @_;
371 420
372 %$jar = () if $jar->{version} != 1; 421 %$jar = () if $jar->{version} != 1;
373 422
… …
388 next unless $cpath eq substr $upath, 0, length $cpath; 437 next unless $cpath eq substr $upath, 0, length $cpath;
389 438
390 while (my ($cookie, $kv) = each %$cookies) { 439 while (my ($cookie, $kv) = each %$cookies) {
391 next if $uscheme ne "https" && exists $kv->{secure}; 440 next if $uscheme ne "https" && exists $kv->{secure};
392 441
393 if (exists $kv->{expires}) { 442 if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
394 if (AE::now > parse_date ($kv->{expires})) {
395 delete $cookies->{$cookie}; 443 delete $cookies->{$cookie};
396 next; 444 next;
397 }
398 } 445 }
399 446
400 my $value = $kv->{value}; 447 my $value = $kv->{value};
401 448
402 if ($value =~ /[=;,[:space:]]/) { 449 if ($value =~ /[=;,[:space:]]/) {
… …
410 } 457 }
411 458
412 \@cookies 459 \@cookies
413} 460}
414 461
462# parse set_cookie header into jar
463sub cookie_jar_set_cookie($$$$) {
464 my ($jar, $set_cookie, $uhost, $date) = @_;
465
466 my $anow = int AE::now;
467 my $snow; # server-now
468
469 for ($set_cookie) {
470 # parse NAME=VALUE
471 my @kv;
472
473 # expires is not http-compliant in the original cookie-spec,
474 # we support the official date format and some extensions
475 while (
476 m{
477 \G\s*
478 (?:
479 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
480 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
481 )
482 }gcxsi
483 ) {
484 my $name = $2;
485 my $value = $4;
486
487 unless (defined $name) {
488 # expires
489 $name = "expires";
490 $value = $1;
491 } elsif (!defined $value) {
492 # quoted
493 $value = $3;
494 $value =~ s/\\(.)/$1/gs;
495 }
496
497 push @kv, lc $name, $value;
498
499 last unless /\G\s*;/gc;
500 }
501
502 last unless @kv;
503
504 my $name = shift @kv;
505 my %kv = (value => shift @kv, @kv);
506
507 if (exists $kv{"max-age"}) {
508 $kv{_expires} = $anow + delete $kv{"max-age"};
509 } elsif (exists $kv{expires}) {
510 $snow ||= parse_date ($date) || $anow;
511 $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
512 } else {
513 delete $kv{_expires};
514 }
515
516 my $cdom;
517 my $cpath = (delete $kv{path}) || "/";
518
519 if (exists $kv{domain}) {
520 $cdom = delete $kv{domain};
521
522 $cdom =~ s/^\.?/./; # make sure it starts with a "."
523
524 next if $cdom =~ /\.$/;
525
526 # this is not rfc-like and not netscape-like. go figure.
527 my $ndots = $cdom =~ y/.//;
528 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
529 } else {
530 $cdom = $uhost;
531 }
532
533 # store it
534 $jar->{version} = 1;
535 $jar->{$cdom}{$cpath}{$name} = \%kv;
536
537 redo if /\G\s*,/gc;
538 }
539}
540
415# continue to parse $_ for headers and place them into the arg 541# continue to parse $_ for headers and place them into the arg
416sub parse_hdr() { 542sub parse_hdr() {
417 my %hdr; 543 my %hdr;
418 544
419 # things seen, not parsed: 545 # things seen, not parsed:
… …
531 _get_slot $uhost, sub { 657 _get_slot $uhost, sub {
532 $state{slot_guard} = shift; 658 $state{slot_guard} = shift;
533 659
534 return unless $state{connect_guard}; 660 return unless $state{connect_guard};
535 661
662 my $ae_error = 595; # connecting
663
536 my $connect_cb = sub { 664 my $connect_cb = sub {
537 $state{fh} = shift 665 $state{fh} = shift
538 or do { 666 or do {
539 my $err = "$!"; 667 my $err = "$!";
540 %state = (); 668 %state = ();
541 return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); 669 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
542 }; 670 };
543
544 pop; # free memory, save a tree
545 671
546 return unless delete $state{connect_guard}; 672 return unless delete $state{connect_guard};
547 673
548 # get handle 674 # get handle
549 $state{handle} = new AnyEvent::Handle 675 $state{handle} = new AnyEvent::Handle
… …
552 tls_ctx => $arg{tls_ctx}, 678 tls_ctx => $arg{tls_ctx},
553 # these need to be reconfigured on keepalive handles 679 # these need to be reconfigured on keepalive handles
554 timeout => $timeout, 680 timeout => $timeout,
555 on_error => sub { 681 on_error => sub {
556 %state = (); 682 %state = ();
557 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] }); 683 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
558 }, 684 },
559 on_eof => sub { 685 on_eof => sub {
560 %state = (); 686 %state = ();
561 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" }); 687 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
562 }, 688 },
563 ; 689 ;
564 690
565 # limit the number of persistent connections 691 # limit the number of persistent connections
566 # keepalive not yet supported 692 # keepalive not yet supported
… …
574 700
575 $state{handle}->starttls ("connect") if $rscheme eq "https"; 701 $state{handle}->starttls ("connect") if $rscheme eq "https";
576 702
577 # handle actual, non-tunneled, request 703 # handle actual, non-tunneled, request
578 my $handle_actual_request = sub { 704 my $handle_actual_request = sub {
705 $ae_error = 596; # request phase
706
579 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 707 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
580 708
581 # send request 709 # send request
582 $state{handle}->push_write ( 710 $state{handle}->push_write (
583 "$method $rpath HTTP/1.1\015\012" 711 "$method $rpath HTTP/1.1\015\012"
… …
594 # status line and headers 722 # status line and headers
595 $state{read_response} = sub { 723 $state{read_response} = sub {
596 for ("$_[1]") { 724 for ("$_[1]") {
597 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 725 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
598 726
599 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc 727 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
600 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 728 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
601 729
602 # 100 Continue handling 730 # 100 Continue handling
603 # should not happen as we don't send expect: 100-continue, 731 # should not happen as we don't send expect: 100-continue,
604 # but we handle it just in case. 732 # but we handle it just in case.
… …
639 767
640 if ($recurse) { 768 if ($recurse) {
641 my $status = $hdr{Status}; 769 my $status = $hdr{Status};
642 770
643 # industry standard is to redirect POST as GET for 771 # industry standard is to redirect POST as GET for
644 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 772 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
645 # also, the UA should ask the user for 301 and 307 and POST, 773 # also, the UA should ask the user for 301 and 307 and POST,
646 # industry standard seems to be to simply follow. 774 # industry standard seems to be to simply follow.
647 # we go with the industry standard. 775 # we go with the industry standard.
648 if ($status == 301 or $status == 302 or $status == 303) { 776 if ($status == 301 or $status == 302 or $status == 303) {
649 # HTTP/1.1 is unclear on how to mutate the method 777 # HTTP/1.1 is unclear on how to mutate the method
… …
653 $redirect = 1; 781 $redirect = 1;
654 } 782 }
655 } 783 }
656 784
657 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 785 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
658 my $keepalive = pop; 786 my $may_keep_alive = $_[3];
659 787
660 $state{handle}->destroy if $state{handle}; 788 $state{handle}->destroy if $state{handle};
661 %state = (); 789 %state = ();
662 790
663 if (defined $_[1]) { 791 if (defined $_[1]) {
… …
665 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; 793 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
666 } 794 }
667 795
668 # set-cookie processing 796 # set-cookie processing
669 if ($arg{cookie_jar}) { 797 if ($arg{cookie_jar}) {
670 for ($hdr{"set-cookie"}) { 798 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
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 } 799 }
733 800
734 if ($redirect && exists $hdr{location}) { 801 if ($redirect && exists $hdr{location}) {
735 # we ignore any errors, as it is very common to receive 802 # we ignore any errors, as it is very common to receive
736 # Content-Length != 0 but no actual body 803 # Content-Length != 0 but no actual body
… …
743 $cb); 810 $cb);
744 } else { 811 } else {
745 $cb->($_[0], \%hdr); 812 $cb->($_[0], \%hdr);
746 } 813 }
747 }; 814 };
815
816 $ae_error = 597; # body phase
748 817
749 my $len = $hdr{"content-length"}; 818 my $len = $hdr{"content-length"};
750 819
751 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 820 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
752 $finish->(undef, 598 => "Request cancelled by on_header"); 821 $finish->(undef, 598 => "Request cancelled by on_header");
… …
774 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) { 843 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
775 my $cl = 0; 844 my $cl = 0;
776 my $body = undef; 845 my $body = undef;
777 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 846 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
778 847
779 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
780
781 my $read_chunk; $read_chunk = sub { 848 my $read_chunk; $read_chunk = sub {
782 $_[1] =~ /^([0-9a-fA-F]+)/ 849 $_[1] =~ /^([0-9a-fA-F]+)/
783 or $finish->(undef, 599 => "Garbled chunked transfer encoding"); 850 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
784 851
785 my $len = hex $1; 852 my $len = hex $1;
786 853
787 if ($len) { 854 if ($len) {
788 $cl += $len; 855 $cl += $len;
… …
791 $on_body->($_[1], \%hdr) 858 $on_body->($_[1], \%hdr)
792 or return $finish->(undef, 598 => "Request cancelled by on_body"); 859 or return $finish->(undef, 598 => "Request cancelled by on_body");
793 860
794 $_[0]->push_read (line => sub { 861 $_[0]->push_read (line => sub {
795 length $_[1] 862 length $_[1]
796 and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); 863 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
797 $_[0]->push_read (line => $read_chunk); 864 $_[0]->push_read (line => $read_chunk);
798 }); 865 });
799 }); 866 });
800 } else { 867 } else {
801 $hdr{"content-length"} ||= $cl; 868 $hdr{"content-length"} ||= $cl;
… …
804 if (length $_[1]) { 871 if (length $_[1]) {
805 for ("$_[1]") { 872 for ("$_[1]") {
806 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 873 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
807 874
808 my $hdr = parse_hdr 875 my $hdr = parse_hdr
809 or return $finish->(undef, 599 => "Garbled response trailers"); 876 or return $finish->(undef, $ae_error => "Garbled response trailers");
810 877
811 %hdr = (%hdr, %$hdr); 878 %hdr = (%hdr, %$hdr);
812 } 879 }
813 } 880 }
814 881
… …
818 }; 885 };
819 886
820 $_[0]->push_read (line => $read_chunk); 887 $_[0]->push_read (line => $read_chunk);
821 888
822 } elsif ($arg{on_body}) { 889 } elsif ($arg{on_body}) {
823 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
824
825 if ($len) { 890 if ($len) {
826 $_[0]->on_read (sub { 891 $_[0]->on_read (sub {
827 $len -= length $_[0]{rbuf}; 892 $len -= length $_[0]{rbuf};
828 893
829 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 894 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
… …
843 } 908 }
844 } else { 909 } else {
845 $_[0]->on_eof (undef); 910 $_[0]->on_eof (undef);
846 911
847 if ($len) { 912 if ($len) {
848 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
849 $_[0]->on_read (sub { 913 $_[0]->on_read (sub {
850 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 914 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
851 if $len <= length $_[0]{rbuf}; 915 if $len <= length $_[0]{rbuf};
852 }); 916 });
853 } else { 917 } else {
854 $_[0]->on_error (sub { 918 $_[0]->on_error (sub {
855 ($! == Errno::EPIPE || !$!) 919 ($! == Errno::EPIPE || !$!)
856 ? $finish->(delete $_[0]{rbuf}) 920 ? $finish->(delete $_[0]{rbuf})
857 : $finish->(undef, 599 => $_[2]); 921 : $finish->(undef, $ae_error => $_[2]);
858 }); 922 });
859 $_[0]->on_read (sub { }); 923 $_[0]->on_read (sub { });
860 } 924 }
861 } 925 }
862 } 926 }
… …
935string of the form C<http://host:port> (optionally C<https:...>), croaks 999string of the form C<http://host:port> (optionally C<https:...>), croaks
936otherwise. 1000otherwise.
937 1001
938To clear an already-set proxy, use C<undef>. 1002To clear an already-set proxy, use C<undef>.
939 1003
1004=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1005
1006Remove all cookies from the cookie jar that have been expired. If
1007C<$session_end> is given and true, then additionally remove all session
1008cookies.
1009
1010You should call this function (with a true C<$session_end>) before you
1011save cookies to disk, and you should call this function after loading them
1012again. If you have a long-running program you can additonally call this
1013function from time to time.
1014
1015A cookie jar is initially an empty hash-reference that is managed by this
1016module. It's format is subject to change, but currently it is like this:
1017
1018The key C<version> has to contain C<1>, otherwise the hash gets
1019emptied. All other keys are hostnames or IP addresses pointing to
1020hash-references. The key for these inner hash references is the
1021server path for which this cookie is meant, and the values are again
1022hash-references. The keys of those hash-references is the cookie name, and
1023the value, you guessed it, is another hash-reference, this time with the
1024key-value pairs from the cookie, except for C<expires> and C<max-age>,
1025which have been replaced by a C<_expires> key that contains the cookie
1026expiry timestamp.
1027
1028Here is an example of a cookie jar with a single cookie, so you have a
1029chance of understanding the above paragraph:
1030
1031 {
1032 version => 1,
1033 "10.0.0.1" => {
1034 "/" => {
1035 "mythweb_id" => {
1036 _expires => 1293917923,
1037 value => "ooRung9dThee3ooyXooM1Ohm",
1038 },
1039 },
1040 },
1041 }
1042
940=item $date = AnyEvent::HTTP::format_date $timestamp 1043=item $date = AnyEvent::HTTP::format_date $timestamp
941 1044
942Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 1045Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
943Date (RFC 2616). 1046Date (RFC 2616).
944 1047
945=item $timestamp = AnyEvent::HTTP::parse_date $date 1048=item $timestamp = AnyEvent::HTTP::parse_date $date
946 1049
947Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and 1050Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
948returns the corresponding POSIX timestamp, or C<undef> if the date cannot 1051bunch of minor variations of those, and returns the corresponding POSIX
949be parsed. 1052timestamp, or C<undef> if the date cannot be parsed.
950 1053
951=item $AnyEvent::HTTP::MAX_RECURSE 1054=item $AnyEvent::HTTP::MAX_RECURSE
952 1055
953The default value for the C<recurse> request parameter (default: C<10>). 1056The default value for the C<recurse> request parameter (default: C<10>).
954 1057
… …
993sub parse_date($) { 1096sub parse_date($) {
994 my ($date) = @_; 1097 my ($date) = @_;
995 1098
996 my ($d, $m, $y, $H, $M, $S); 1099 my ($d, $m, $y, $H, $M, $S);
997 1100
998 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9])[\- ]([A-Z][a-z][a-z])[\- ]([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) { 1101 if ($date =~ /^[A-Z][a-z][a-z]+, ([0-9][0-9]?)[\- ]([A-Z][a-z][a-z])[\- ]([0-9][0-9][0-9][0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) GMT$/) {
999 # RFC 822/1123, required by RFC 2616 (with " ") 1102 # RFC 822/1123, required by RFC 2616 (with " ")
1000 # cookie dates (with "-") 1103 # cookie dates (with "-")
1001 1104
1002 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1105 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
1003 1106
1004 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) { 1107 } elsif ($date =~ /^[A-Z][a-z][a-z]+, ([0-9][0-9]?)-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) GMT$/) {
1005 # RFC 850 1108 # RFC 850
1006 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1109 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
1007 1110
1008 } elsif ($date =~ /^[A-Z][a-z][a-z] ([A-Z][a-z][a-z]) ([0-9 ][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) ([0-9][0-9][0-9][0-9])$/) { 1111 } elsif ($date =~ /^[A-Z][a-z][a-z]+ ([A-Z][a-z][a-z]) ([0-9 ]?[0-9]) ([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?) ([0-9][0-9][0-9][0-9])$/) {
1009 # ISO C's asctime 1112 # ISO C's asctime
1010 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5); 1113 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
1011 } 1114 }
1012 # other formats fail in the loop below 1115 # other formats fail in the loop below
1013 1116

Diff Legend

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