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.68 by root, Fri Dec 31 19:22:18 2010 UTC vs.
Revision 1.79 by root, Sat Jan 1 20:01:07 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) = @_;
… …
152 166
153=item headers => hashref 167=item headers => hashref
154 168
155The request headers to use. Currently, C<http_request> may provide its own 169The request headers to use. Currently, C<http_request> may provide its own
156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 170C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
157will provide defaults for C<TE:>, C<Referer:> and C<User-Agent:> (this can 171will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
158be suppressed by using C<undef> for these headers in which case they won't 172(this can be suppressed by using C<undef> for these headers in which case
159be sent at all). 173they won't be sent at all).
160 174
161=item timeout => $seconds 175=item timeout => $seconds
162 176
163The time-out to use for various stages - each connect attempt will reset 177The time-out to use for various stages - each connect attempt will reset
164the timeout, as will read or write activity, i.e. this is not an overall 178the timeout, as will read or write activity, i.e. this is not an overall
… …
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 will
188get updated automatically. It is possible to save the cookie_jar to 202get updated automatically. It is possible to save the cookie jar to
189persistent storage with something like JSON or Storable, but this is not 203persistent storage with something like JSON or Storable, but this is not
190recommended, as expiry times are currently being ignored. 204recommended, as session-only cookies might survive longer than expected.
191 205
192Note that this cookie implementation is not of very high quality, nor 206Note that this cookie implementation is not meant to be complete. If
193meant to be complete. If you want complete cookie management you have to 207you want complete cookie management you have to do that on your
194do that on your own. C<cookie_jar> is meant as a quick fix to get some 208own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
195cookie-using sites working. Cookies are a privacy disaster, do not use 209working. Cookies are a privacy disaster, do not use them unless required
196them unless required to. 210to.
211
212When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
213headers will be set and handled by this module, otherwise they will be
214left untouched.
197 215
198=item tls_ctx => $scheme | $tls_ctx 216=item tls_ctx => $scheme | $tls_ctx
199 217
200Specifies the AnyEvent::TLS context to be used for https connections. This 218Specifies the AnyEvent::TLS context to be used for https connections. This
201parameter follows the same rules as the C<tls_ctx> parameter to 219parameter follows the same rules as the C<tls_ctx> parameter to
… …
360 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 378 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
361 379
362 _slot_schedule $_[0]; 380 _slot_schedule $_[0];
363} 381}
364 382
383# extract cookies from jar
384sub cookie_jar_extract($$$$) {
385 my ($jar, $uscheme, $uhost, $upath) = @_;
386
387 %$jar = () if $jar->{version} != 1;
388
389 my @cookies;
390
391 while (my ($chost, $paths) = each %$jar) {
392 next unless ref $paths;
393
394 if ($chost =~ /^\./) {
395 next unless $chost eq substr $uhost, -length $chost;
396 } elsif ($chost =~ /\./) {
397 next unless $chost eq $uhost;
398 } else {
399 next;
400 }
401
402 while (my ($cpath, $cookies) = each %$paths) {
403 next unless $cpath eq substr $upath, 0, length $cpath;
404
405 while (my ($cookie, $kv) = each %$cookies) {
406 next if $uscheme ne "https" && exists $kv->{secure};
407
408 if (exists $kv->{expires}) {
409 if (AE::now > parse_date ($kv->{expires})) {
410 delete $cookies->{$cookie};
411 next;
412 }
413 }
414
415 my $value = $kv->{value};
416
417 if ($value =~ /[=;,[:space:]]/) {
418 $value =~ s/([\\"])/\\$1/g;
419 $value = "\"$value\"";
420 }
421
422 push @cookies, "$cookie=$value";
423 }
424 }
425 }
426
427 \@cookies
428}
429
430# parse set_cookie header into jar
431sub cookie_jar_set_cookie($$$) {
432 my ($jar, $set_cookie, $uhost) = @_;
433
434 for ($set_cookie) {
435 # parse NAME=VALUE
436 my @kv;
437
438 # expires is not http-compliant in the original cookie-spec,
439 # we support the official date format and some extensions
440 while (
441 m{
442 \G\s*
443 (?:
444 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
445 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
446 )
447 }gcxsi
448 ) {
449 my $name = $2;
450 my $value = $4;
451
452 unless (defined $name) {
453 # expires
454 $name = "expires";
455 $value = $1;
456 } elsif (!defined $value) {
457 # quoted
458 $value = $3;
459 $value =~ s/\\(.)/$1/gs;
460 }
461
462 push @kv, lc $name, $value;
463
464 last unless /\G\s*;/gc;
465 }
466
467 last unless @kv;
468
469 my $name = shift @kv;
470 my %kv = (value => shift @kv, @kv);
471
472 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
473 if exists $kv{"max-age"};
474
475 my $cdom;
476 my $cpath = (delete $kv{path}) || "/";
477
478 if (exists $kv{domain}) {
479 $cdom = delete $kv{domain};
480
481 $cdom =~ s/^\.?/./; # make sure it starts with a "."
482
483 next if $cdom =~ /\.$/;
484
485 # this is not rfc-like and not netscape-like. go figure.
486 my $ndots = $cdom =~ y/.//;
487 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
488 } else {
489 $cdom = $uhost;
490 }
491
492 # store it
493 $jar->{version} = 1;
494 $jar->{$cdom}{$cpath}{$name} = \%kv;
495
496 redo if /\G\s*,/gc;
497 }
498}
499
365# continue to parse $_ for headers and place them into the arg 500# continue to parse $_ for headers and place them into the arg
366sub parse_hdr() { 501sub parse_hdr() {
367 my %hdr; 502 my %hdr;
368 503
369 # things seen, not parsed: 504 # things seen, not parsed:
… …
444 579
445 $upath =~ s%^/?%/%; 580 $upath =~ s%^/?%/%;
446 581
447 # cookie processing 582 # cookie processing
448 if (my $jar = $arg{cookie_jar}) { 583 if (my $jar = $arg{cookie_jar}) {
449 %$jar = () if $jar->{version} != 1; 584 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
450 585
451 my @cookie;
452
453 while (my ($chost, $v) = each %$jar) {
454 if ($chost =~ /^\./) {
455 next unless $chost eq substr $uhost, -length $chost;
456 } elsif ($chost =~ /\./) {
457 next unless $chost eq $uhost;
458 } else {
459 next;
460 }
461
462 while (my ($cpath, $v) = each %$v) {
463 next unless $cpath eq substr $upath, 0, length $cpath;
464
465 while (my ($k, $v) = each %$v) {
466 next if $uscheme ne "https" && exists $v->{secure};
467 my $value = $v->{value};
468 $value =~ s/([\\"])/\\$1/g;
469 push @cookie, "$k=\"$value\"";
470 }
471 }
472 }
473
474 $hdr{cookie} = join "; ", @cookie 586 $hdr{cookie} = join "; ", @$cookies
475 if @cookie; 587 if @$cookies;
476 } 588 }
477 589
478 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 590 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
479 591
480 if ($proxy) { 592 if ($proxy) {
… …
504 _get_slot $uhost, sub { 616 _get_slot $uhost, sub {
505 $state{slot_guard} = shift; 617 $state{slot_guard} = shift;
506 618
507 return unless $state{connect_guard}; 619 return unless $state{connect_guard};
508 620
621 my $ae_error = 595; # connecting
622
509 my $connect_cb = sub { 623 my $connect_cb = sub {
510 $state{fh} = shift 624 $state{fh} = shift
511 or do { 625 or do {
512 my $err = "$!"; 626 my $err = "$!";
513 %state = (); 627 %state = ();
514 return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); 628 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
515 }; 629 };
516
517 pop; # free memory, save a tree
518 630
519 return unless delete $state{connect_guard}; 631 return unless delete $state{connect_guard};
520 632
521 # get handle 633 # get handle
522 $state{handle} = new AnyEvent::Handle 634 $state{handle} = new AnyEvent::Handle
… …
525 tls_ctx => $arg{tls_ctx}, 637 tls_ctx => $arg{tls_ctx},
526 # these need to be reconfigured on keepalive handles 638 # these need to be reconfigured on keepalive handles
527 timeout => $timeout, 639 timeout => $timeout,
528 on_error => sub { 640 on_error => sub {
529 %state = (); 641 %state = ();
530 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] }); 642 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
531 }, 643 },
532 on_eof => sub { 644 on_eof => sub {
533 %state = (); 645 %state = ();
534 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" }); 646 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
535 }, 647 },
536 ; 648 ;
537 649
538 # limit the number of persistent connections 650 # limit the number of persistent connections
539 # keepalive not yet supported 651 # keepalive not yet supported
… …
547 659
548 $state{handle}->starttls ("connect") if $rscheme eq "https"; 660 $state{handle}->starttls ("connect") if $rscheme eq "https";
549 661
550 # handle actual, non-tunneled, request 662 # handle actual, non-tunneled, request
551 my $handle_actual_request = sub { 663 my $handle_actual_request = sub {
664 $ae_error = 596; # request phase
665
552 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 666 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
553 667
554 # send request 668 # send request
555 $state{handle}->push_write ( 669 $state{handle}->push_write (
556 "$method $rpath HTTP/1.1\015\012" 670 "$method $rpath HTTP/1.1\015\012"
… …
567 # status line and headers 681 # status line and headers
568 $state{read_response} = sub { 682 $state{read_response} = sub {
569 for ("$_[1]") { 683 for ("$_[1]") {
570 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 684 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
571 685
572 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc 686 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
573 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 687 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
574 688
575 # 100 Continue handling 689 # 100 Continue handling
576 # should not happen as we don't send expect: 100-continue, 690 # should not happen as we don't send expect: 100-continue,
577 # but we handle it just in case. 691 # but we handle it just in case.
… …
612 726
613 if ($recurse) { 727 if ($recurse) {
614 my $status = $hdr{Status}; 728 my $status = $hdr{Status};
615 729
616 # industry standard is to redirect POST as GET for 730 # industry standard is to redirect POST as GET for
617 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 731 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
618 # also, the UA should ask the user for 301 and 307 and POST, 732 # also, the UA should ask the user for 301 and 307 and POST,
619 # industry standard seems to be to simply follow. 733 # industry standard seems to be to simply follow.
620 # we go with the industry standard. 734 # we go with the industry standard.
621 if ($status == 301 or $status == 302 or $status == 303) { 735 if ($status == 301 or $status == 302 or $status == 303) {
622 # HTTP/1.1 is unclear on how to mutate the method 736 # HTTP/1.1 is unclear on how to mutate the method
… …
626 $redirect = 1; 740 $redirect = 1;
627 } 741 }
628 } 742 }
629 743
630 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 744 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
631 my $keepalive = pop; 745 my $may_keep_alive = $_[3];
632 746
633 $state{handle}->destroy if $state{handle}; 747 $state{handle}->destroy if $state{handle};
634 %state = (); 748 %state = ();
635 749
636 if (defined $_[1]) { 750 if (defined $_[1]) {
… …
638 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; 752 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
639 } 753 }
640 754
641 # set-cookie processing 755 # set-cookie processing
642 if ($arg{cookie_jar}) { 756 if ($arg{cookie_jar}) {
643 for ($hdr{"set-cookie"}) { 757 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
644 # parse NAME=VALUE
645 my @kv;
646
647 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
648 my $name = $1;
649 my $value = $3;
650
651 unless ($value) {
652 $value = $2;
653 $value =~ s/\\(.)/$1/gs;
654 }
655
656 push @kv, $name => $value;
657
658 last unless /\G\s*;/gc;
659 }
660
661 last unless @kv;
662
663 my $name = shift @kv;
664 my %kv = (value => shift @kv, @kv);
665
666 my $cdom;
667 my $cpath = (delete $kv{path}) || "/";
668
669 if (exists $kv{domain}) {
670 $cdom = delete $kv{domain};
671
672 $cdom =~ s/^\.?/./; # make sure it starts with a "."
673
674 next if $cdom =~ /\.$/;
675
676 # this is not rfc-like and not netscape-like. go figure.
677 my $ndots = $cdom =~ y/.//;
678 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
679 } else {
680 $cdom = $uhost;
681 }
682
683 # store it
684 $arg{cookie_jar}{version} = 1;
685 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
686
687 redo if /\G\s*,/gc;
688 }
689 } 758 }
690 759
691 if ($redirect && exists $hdr{location}) { 760 if ($redirect && exists $hdr{location}) {
692 # we ignore any errors, as it is very common to receive 761 # we ignore any errors, as it is very common to receive
693 # Content-Length != 0 but no actual body 762 # Content-Length != 0 but no actual body
… …
700 $cb); 769 $cb);
701 } else { 770 } else {
702 $cb->($_[0], \%hdr); 771 $cb->($_[0], \%hdr);
703 } 772 }
704 }; 773 };
774
775 $ae_error = 597; # body phase
705 776
706 my $len = $hdr{"content-length"}; 777 my $len = $hdr{"content-length"};
707 778
708 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 779 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
709 $finish->(undef, 598 => "Request cancelled by on_header"); 780 $finish->(undef, 598 => "Request cancelled by on_header");
… …
731 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) { 802 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
732 my $cl = 0; 803 my $cl = 0;
733 my $body = undef; 804 my $body = undef;
734 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 805 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
735 806
736 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
737
738 my $read_chunk; $read_chunk = sub { 807 my $read_chunk; $read_chunk = sub {
739 $_[1] =~ /^([0-9a-fA-F]+)/ 808 $_[1] =~ /^([0-9a-fA-F]+)/
740 or $finish->(undef, 599 => "Garbled chunked transfer encoding"); 809 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
741 810
742 my $len = hex $1; 811 my $len = hex $1;
743 812
744 if ($len) { 813 if ($len) {
745 $cl += $len; 814 $cl += $len;
… …
748 $on_body->($_[1], \%hdr) 817 $on_body->($_[1], \%hdr)
749 or return $finish->(undef, 598 => "Request cancelled by on_body"); 818 or return $finish->(undef, 598 => "Request cancelled by on_body");
750 819
751 $_[0]->push_read (line => sub { 820 $_[0]->push_read (line => sub {
752 length $_[1] 821 length $_[1]
753 and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); 822 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
754 $_[0]->push_read (line => $read_chunk); 823 $_[0]->push_read (line => $read_chunk);
755 }); 824 });
756 }); 825 });
757 } else { 826 } else {
758 $hdr{"content-length"} ||= $cl; 827 $hdr{"content-length"} ||= $cl;
… …
761 if (length $_[1]) { 830 if (length $_[1]) {
762 for ("$_[1]") { 831 for ("$_[1]") {
763 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 832 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
764 833
765 my $hdr = parse_hdr 834 my $hdr = parse_hdr
766 or return $finish->(undef, 599 => "Garbled response trailers"); 835 or return $finish->(undef, $ae_error => "Garbled response trailers");
767 836
768 %hdr = (%hdr, %$hdr); 837 %hdr = (%hdr, %$hdr);
769 } 838 }
770 } 839 }
771 840
… …
775 }; 844 };
776 845
777 $_[0]->push_read (line => $read_chunk); 846 $_[0]->push_read (line => $read_chunk);
778 847
779 } elsif ($arg{on_body}) { 848 } elsif ($arg{on_body}) {
780 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
781
782 if ($len) { 849 if ($len) {
783 $_[0]->on_read (sub { 850 $_[0]->on_read (sub {
784 $len -= length $_[0]{rbuf}; 851 $len -= length $_[0]{rbuf};
785 852
786 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 853 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
… …
800 } 867 }
801 } else { 868 } else {
802 $_[0]->on_eof (undef); 869 $_[0]->on_eof (undef);
803 870
804 if ($len) { 871 if ($len) {
805 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
806 $_[0]->on_read (sub { 872 $_[0]->on_read (sub {
807 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 873 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
808 if $len <= length $_[0]{rbuf}; 874 if $len <= length $_[0]{rbuf};
809 }); 875 });
810 } else { 876 } else {
811 $_[0]->on_error (sub { 877 $_[0]->on_error (sub {
812 ($! == Errno::EPIPE || !$!) 878 ($! == Errno::EPIPE || !$!)
813 ? $finish->(delete $_[0]{rbuf}) 879 ? $finish->(delete $_[0]{rbuf})
814 : $finish->(undef, 599 => $_[2]); 880 : $finish->(undef, $ae_error => $_[2]);
815 }); 881 });
816 $_[0]->on_read (sub { }); 882 $_[0]->on_read (sub { });
817 } 883 }
818 } 884 }
819 } 885 }
… …
899Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 965Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
900Date (RFC 2616). 966Date (RFC 2616).
901 967
902=item $timestamp = AnyEvent::HTTP::parse_date $date 968=item $timestamp = AnyEvent::HTTP::parse_date $date
903 969
904Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 970Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
971bunch of minor variations of those, and returns the corresponding POSIX
905timestamp, or C<undef> if the date cannot be parsed. 972timestamp, or C<undef> if the date cannot be parsed.
906 973
907=item $AnyEvent::HTTP::MAX_RECURSE 974=item $AnyEvent::HTTP::MAX_RECURSE
908 975
909The default value for the C<recurse> request parameter (default: C<10>). 976The default value for the C<recurse> request parameter (default: C<10>).
… …
949sub parse_date($) { 1016sub parse_date($) {
950 my ($date) = @_; 1017 my ($date) = @_;
951 1018
952 my ($d, $m, $y, $H, $M, $S); 1019 my ($d, $m, $y, $H, $M, $S);
953 1020
954 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$/) { 1021 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$/) {
955 # RFC 822/1123, required by RFC 2616 1022 # RFC 822/1123, required by RFC 2616 (with " ")
1023 # cookie dates (with "-")
1024
956 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1025 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
957 1026
958 } 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$/) { 1027 } 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$/) {
959 # RFC 850 1028 # RFC 850
960 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1029 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
961 1030
962 } 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])$/) { 1031 } 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])$/) {
963 # ISO C's asctime 1032 # ISO C's asctime
964 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5); 1033 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
965 } 1034 }
966 # other formats fail in the loop below 1035 # other formats fail in the loop below
967 1036

Diff Legend

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