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.60 by root, Thu Dec 30 02:56:28 2010 UTC vs.
Revision 1.89 by root, Mon Jan 3 00:23:25 2011 UTC

… …
36 36
37=cut 37=cut
38 38
39package AnyEvent::HTTP; 39package AnyEvent::HTTP;
40 40
41use strict; 41use common::sense;
42no warnings;
43 42
44use Errno (); 43use Errno ();
45 44
46use AnyEvent 5.0 (); 45use AnyEvent 5.0 ();
47use AnyEvent::Util (); 46use AnyEvent::Util ();
48use AnyEvent::Handle (); 47use AnyEvent::Handle ();
49 48
50use base Exporter::; 49use base Exporter::;
51 50
52our $VERSION = '1.46'; 51our $VERSION = '1.5';
53 52
54our @EXPORT = qw(http_get http_post http_head http_request); 53our @EXPORT = qw(http_get http_post http_head http_request);
55 54
56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
57our $MAX_RECURSE = 10; 56our $MAX_RECURSE = 10;
58our $MAX_PERSISTENT = 8; 57our $MAX_PERSISTENT = 8;
59our $PERSISTENT_TIMEOUT = 2; 58our $PERSISTENT_TIMEOUT = 2;
60our $TIMEOUT = 300; 59our $TIMEOUT = 300;
61 60
62# changing these is evil 61# changing these is evil
63our $MAX_PERSISTENT_PER_HOST = 0; 62our $MAX_PERSISTENT_PER_HOST = 2;
64our $MAX_PER_HOST = 4; 63our $MAX_PER_HOST = 4;
65 64
66our $PROXY; 65our $PROXY;
67our $ACTIVE = 0; 66our $ACTIVE = 0;
68 67
… …
94C<http_request> returns a "cancellation guard" - you have to keep the 93C<http_request> returns a "cancellation guard" - you have to keep the
95object at least alive until the callback get called. If the object gets 94object at least alive until the callback get called. If the object gets
96destroyed before the callback is called, the request will be cancelled. 95destroyed before the callback is called, the request will be cancelled.
97 96
98The callback will be called with the response body data as first argument 97The callback will be called with the response body data as first argument
99(or C<undef> if an error occured), and a hash-ref with response headers as 98(or C<undef> if an error occured), and a hash-ref with response headers
100second argument. 99(and trailers) as second argument.
101 100
102All the headers in that hash are lowercased. In addition to the response 101All the headers in that hash are lowercased. In addition to the response
103headers, the "pseudo-headers" (uppercase to avoid clashing with possible 102headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 103response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105three parts of the HTTP Status-Line of the same name. 104three parts of the HTTP Status-Line of the same name. If an error occurs
105during the body phase of a request, then the original C<Status> and
106C<Reason> values from the header are available as C<OrigStatus> and
107C<OrigReason>.
106 108
107The pseudo-header C<URL> contains the actual URL (which can differ from 109The pseudo-header C<URL> contains the actual URL (which can differ from
108the requested URL when following redirects - for example, you might get 110the requested URL when following redirects - for example, you might get
109an error that your URL scheme is not supported even though your URL is a 111an error that your URL scheme is not supported even though your URL is a
110valid http URL because it redirected to an ftp URL, in which case you can 112valid http URL because it redirected to an ftp URL, in which case you can
… …
119 121
120If the server sends a header multiple times, then their contents will be 122If the server sends a header multiple times, then their contents will be
121joined together with a comma (C<,>), as per the HTTP spec. 123joined together with a comma (C<,>), as per the HTTP spec.
122 124
123If an internal error occurs, such as not being able to resolve a hostname, 125If an internal error occurs, such as not being able to resolve a hostname,
124then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x> 126then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
125(usually C<599>) and the C<Reason> pseudo-header will contain an error 127C<590>-C<599> and the C<Reason> pseudo-header will contain an error
126message. 128message. Currently the following status codes are used:
129
130=over 4
131
132=item 595 - errors during connection etsbalishment, proxy handshake.
133
134=item 596 - errors during TLS negotiation, request sending and header processing.
135
136=item 597 - errors during body receiving or processing.
137
138=item 598 - user aborted request via C<on_header> or C<on_body>.
139
140=item 599 - other, usually nonretryable, errors (garbled URL etc.).
141
142=back
127 143
128A typical callback might look like this: 144A typical callback might look like this:
129 145
130 sub { 146 sub {
131 my ($body, $hdr) = @_; 147 my ($body, $hdr) = @_;
… …
147Whether to recurse requests or not, e.g. on redirects, authentication 163Whether to recurse requests or not, e.g. on redirects, authentication
148retries and so on, and how often to do so. 164retries and so on, and how often to do so.
149 165
150=item headers => hashref 166=item headers => hashref
151 167
152The request headers to use. Currently, C<http_request> may provide its 168The request headers to use. Currently, C<http_request> may provide its own
153own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 169C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
154and will provide defaults for C<User-Agent:> and C<Referer:> (this can be 170will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
155suppressed by using C<undef> for these headers in which case they won't be 171(this can be suppressed by using C<undef> for these headers in which case
156sent at all). 172they won't be sent at all).
157 173
158=item timeout => $seconds 174=item timeout => $seconds
159 175
160The time-out to use for various stages - each connect attempt will reset 176The time-out to use for various stages - each connect attempt will reset
161the timeout, as will read or write activity, i.e. this is not an overall 177the timeout, as will read or write activity, i.e. this is not an overall
… …
171C<$scheme> must be either missing, C<http> for HTTP or C<https> for 187C<$scheme> must be either missing, C<http> for HTTP or C<https> for
172HTTPS. 188HTTPS.
173 189
174=item body => $string 190=item body => $string
175 191
176The request body, usually empty. Will be-sent as-is (future versions of 192The request body, usually empty. Will be sent as-is (future versions of
177this module might offer more options). 193this module might offer more options).
178 194
179=item cookie_jar => $hash_ref 195=item cookie_jar => $hash_ref
180 196
181Passing this parameter enables (simplified) cookie-processing, loosely 197Passing this parameter enables (simplified) cookie-processing, loosely
182based on the original netscape specification. 198based on the original netscape specification.
183 199
184The C<$hash_ref> must be an (initially empty) hash reference which will 200The C<$hash_ref> must be an (initially empty) hash reference which
185get updated automatically. It is possible to save the cookie_jar to 201will get updated automatically. It is possible to save the cookie jar
186persistent storage with something like JSON or Storable, but this is not 202to persistent storage with something like JSON or Storable - see the
187recommended, as expiry times are currently being ignored. 203C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
204expired or session-only cookies, and also for documentation on the format
205of the cookie jar.
188 206
189Note that this cookie implementation is not of very high quality, nor 207Note that this cookie implementation is not meant to be complete. If
190meant to be complete. If you want complete cookie management you have to 208you want complete cookie management you have to do that on your
191do that on your own. C<cookie_jar> is meant as a quick fix to get some 209own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
192cookie-using sites working. Cookies are a privacy disaster, do not use 210working. Cookies are a privacy disaster, do not use them unless required
193them unless required to. 211to.
212
213When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
214headers will be set and handled by this module, otherwise they will be
215left untouched.
194 216
195=item tls_ctx => $scheme | $tls_ctx 217=item tls_ctx => $scheme | $tls_ctx
196 218
197Specifies the AnyEvent::TLS context to be used for https connections. This 219Specifies the AnyEvent::TLS context to be used for https connections. This
198parameter follows the same rules as the C<tls_ctx> parameter to 220parameter follows the same rules as the C<tls_ctx> parameter to
… …
237 259
238This callback is useful, among other things, to quickly reject unwanted 260This callback is useful, among other things, to quickly reject unwanted
239content, which, if it is supposed to be rare, can be faster than first 261content, which, if it is supposed to be rare, can be faster than first
240doing a C<HEAD> request. 262doing a C<HEAD> request.
241 263
264The downside is that cancelling the request makes it impossible to re-use
265the connection. Also, the C<on_header> callback will not receive any
266trailer (headers sent after the response body).
267
242Example: cancel the request unless the content-type is "text/html". 268Example: cancel the request unless the content-type is "text/html".
243 269
244 on_header => sub { 270 on_header => sub {
245 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 271 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
246 }, 272 },
… …
252string instead of the body data. 278string instead of the body data.
253 279
254It has to return either true (in which case AnyEvent::HTTP will continue), 280It has to return either true (in which case AnyEvent::HTTP will continue),
255or false, in which case AnyEvent::HTTP will cancel the download (and call 281or false, in which case AnyEvent::HTTP will cancel the download (and call
256the completion callback with an error code of C<598>). 282the completion callback with an error code of C<598>).
283
284The downside to cancelling the request is that it makes it impossible to
285re-use the connection.
257 286
258This callback is useful when the data is too large to be held in memory 287This callback is useful when the data is too large to be held in memory
259(so the callback writes it to a file) or when only some information should 288(so the callback writes it to a file) or when only some information should
260be extracted, or when the body should be processed incrementally. 289be extracted, or when the body should be processed incrementally.
261 290
… …
287If you think you need this, first have a look at C<on_body>, to see if 316If you think you need this, first have a look at C<on_body>, to see if
288that doesn't solve your problem in a better way. 317that doesn't solve your problem in a better way.
289 318
290=back 319=back
291 320
292Example: make a simple HTTP GET request for http://www.nethype.de/ 321Example: do a simple HTTP GET request for http://www.nethype.de/ and print
322the response body.
293 323
294 http_request GET => "http://www.nethype.de/", sub { 324 http_request GET => "http://www.nethype.de/", sub {
295 my ($body, $hdr) = @_; 325 my ($body, $hdr) = @_;
296 print "$body\n"; 326 print "$body\n";
297 }; 327 };
298 328
299Example: make a HTTP HEAD request on https://www.google.com/, use a 329Example: do a HTTP HEAD request on https://www.google.com/, use a
300timeout of 30 seconds. 330timeout of 30 seconds.
301 331
302 http_request 332 http_request
303 GET => "https://www.google.com", 333 GET => "https://www.google.com",
304 timeout => 30, 334 timeout => 30,
… …
307 use Data::Dumper; 337 use Data::Dumper;
308 print Dumper $hdr; 338 print Dumper $hdr;
309 } 339 }
310 ; 340 ;
311 341
312Example: make another simple HTTP GET request, but immediately try to 342Example: do another simple HTTP GET request, but immediately try to
313cancel it. 343cancel it.
314 344
315 my $request = http_request GET => "http://www.nethype.de/", sub { 345 my $request = http_request GET => "http://www.nethype.de/", sub {
316 my ($body, $hdr) = @_; 346 my ($body, $hdr) = @_;
317 print "$body\n"; 347 print "$body\n";
… …
349 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 379 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
350 380
351 _slot_schedule $_[0]; 381 _slot_schedule $_[0];
352} 382}
353 383
384#############################################################################
385
386# expire cookies
387sub cookie_jar_expire($;$) {
388 my ($jar, $session_end) = @_;
389
390 %$jar = () if $jar->{version} != 1;
391
392 my $anow = AE::now;
393
394 while (my ($chost, $paths) = each %$jar) {
395 next unless ref $paths;
396
397 while (my ($cpath, $cookies) = each %$paths) {
398 while (my ($cookie, $kv) = each %$cookies) {
399 if (exists $kv->{_expires}) {
400 delete $cookies->{$cookie}
401 if $anow > $kv->{_expires};
402 } elsif ($session_end) {
403 delete $cookies->{$cookie};
404 }
405 }
406
407 delete $paths->{$cpath}
408 unless %$cookies;
409 }
410
411 delete $jar->{$chost}
412 unless %$paths;
413 }
414}
415
416# extract cookies from jar
417sub cookie_jar_extract($$$$) {
418 my ($jar, $uscheme, $uhost, $upath) = @_;
419
420 %$jar = () if $jar->{version} != 1;
421
422 my @cookies;
423
424 while (my ($chost, $paths) = each %$jar) {
425 next unless ref $paths;
426
427 if ($chost =~ /^\./) {
428 next unless $chost eq substr $uhost, -length $chost;
429 } elsif ($chost =~ /\./) {
430 next unless $chost eq $uhost;
431 } else {
432 next;
433 }
434
435 while (my ($cpath, $cookies) = each %$paths) {
436 next unless $cpath eq substr $upath, 0, length $cpath;
437
438 while (my ($cookie, $kv) = each %$cookies) {
439 next if $uscheme ne "https" && exists $kv->{secure};
440
441 if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
442 delete $cookies->{$cookie};
443 next;
444 }
445
446 my $value = $kv->{value};
447
448 if ($value =~ /[=;,[:space:]]/) {
449 $value =~ s/([\\"])/\\$1/g;
450 $value = "\"$value\"";
451 }
452
453 push @cookies, "$cookie=$value";
454 }
455 }
456 }
457
458 \@cookies
459}
460
461# parse set_cookie header into jar
462sub cookie_jar_set_cookie($$$$) {
463 my ($jar, $set_cookie, $uhost, $date) = @_;
464
465 my $anow = int AE::now;
466 my $snow; # server-now
467
468 for ($set_cookie) {
469 # parse NAME=VALUE
470 my @kv;
471
472 # expires is not http-compliant in the original cookie-spec,
473 # we support the official date format and some extensions
474 while (
475 m{
476 \G\s*
477 (?:
478 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
479 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )?
480 )
481 }gcxsi
482 ) {
483 my $name = $2;
484 my $value = $4;
485
486 if (defined $1) {
487 # expires
488 $name = "expires";
489 $value = $1;
490 } elsif (defined $3) {
491 # quoted
492 $value = $3;
493 $value =~ s/\\(.)/$1/gs;
494 }
495
496 push @kv, lc $name, $value;
497
498 last unless /\G\s*;/gc;
499 }
500
501 last unless @kv;
502
503 my $name = shift @kv;
504 my %kv = (value => shift @kv, @kv);
505
506 if (exists $kv{"max-age"}) {
507 $kv{_expires} = $anow + delete $kv{"max-age"};
508 } elsif (exists $kv{expires}) {
509 $snow ||= parse_date ($date) || $anow;
510 $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
511 } else {
512 delete $kv{_expires};
513 }
514
515 my $cdom;
516 my $cpath = (delete $kv{path}) || "/";
517
518 if (exists $kv{domain}) {
519 $cdom = delete $kv{domain};
520
521 $cdom =~ s/^\.?/./; # make sure it starts with a "."
522
523 next if $cdom =~ /\.$/;
524
525 # this is not rfc-like and not netscape-like. go figure.
526 my $ndots = $cdom =~ y/.//;
527 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
528 } else {
529 $cdom = $uhost;
530 }
531
532 # store it
533 $jar->{version} = 1;
534 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
535
536 redo if /\G\s*,/gc;
537 }
538}
539
540# continue to parse $_ for headers and place them into the arg
541sub parse_hdr() {
542 my %hdr;
543
544 # things seen, not parsed:
545 # p3pP="NON CUR OTPi OUR NOR UNI"
546
547 $hdr{lc $1} .= ",$2"
548 while /\G
549 ([^:\000-\037]*):
550 [\011\040]*
551 ((?: [^\012]+ | \012[\011\040] )*)
552 \012
553 /gxc;
554
555 /\G$/
556 or return;
557
558 # remove the "," prefix we added to all headers above
559 substr $_, 0, 1, ""
560 for values %hdr;
561
562 \%hdr
563}
564
354our $qr_nlnl = qr{(?<![^\012])\015?\012}; 565our $qr_nlnl = qr{(?<![^\012])\015?\012};
355 566
356our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 567our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
357our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 568our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
358 569
… …
377 my @pseudo = (URL => $url); 588 my @pseudo = (URL => $url);
378 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 589 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
379 590
380 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 591 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
381 592
382 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 593 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
383 if $recurse < 0; 594 if $recurse < 0;
384 595
385 my $proxy = $arg{proxy} || $PROXY; 596 my $proxy = $arg{proxy} || $PROXY;
386 my $timeout = $arg{timeout} || $TIMEOUT; 597 my $timeout = $arg{timeout} || $TIMEOUT;
387 598
… …
390 601
391 $uscheme = lc $uscheme; 602 $uscheme = lc $uscheme;
392 603
393 my $uport = $uscheme eq "http" ? 80 604 my $uport = $uscheme eq "http" ? 80
394 : $uscheme eq "https" ? 443 605 : $uscheme eq "https" ? 443
395 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 606 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
396 607
397 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 608 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
398 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 609 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
399 610
400 my $uhost = $1; 611 my $uhost = lc $1;
401 $uport = $2 if defined $2; 612 $uport = $2 if defined $2;
402 613
403 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 614 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
404 unless exists $hdr{host}; 615 unless exists $hdr{host};
405 616
… …
408 619
409 $upath =~ s%^/?%/%; 620 $upath =~ s%^/?%/%;
410 621
411 # cookie processing 622 # cookie processing
412 if (my $jar = $arg{cookie_jar}) { 623 if (my $jar = $arg{cookie_jar}) {
413 %$jar = () if $jar->{version} != 1; 624 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
414 625
415 my @cookie;
416
417 while (my ($chost, $v) = each %$jar) {
418 if ($chost =~ /^\./) {
419 next unless $chost eq substr $uhost, -length $chost;
420 } elsif ($chost =~ /\./) {
421 next unless $chost eq $uhost;
422 } else {
423 next;
424 }
425
426 while (my ($cpath, $v) = each %$v) {
427 next unless $cpath eq substr $upath, 0, length $cpath;
428
429 while (my ($k, $v) = each %$v) {
430 next if $uscheme ne "https" && exists $v->{secure};
431 my $value = $v->{value};
432 $value =~ s/([\\"])/\\$1/g;
433 push @cookie, "$k=\"$value\"";
434 }
435 }
436 }
437
438 $hdr{cookie} = join "; ", @cookie 626 $hdr{cookie} = join "; ", @$cookies
439 if @cookie; 627 if @$cookies;
440 } 628 }
441 629
442 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 630 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
443 631
444 if ($proxy) { 632 if ($proxy) {
… …
447 $rscheme = "http" unless defined $rscheme; 635 $rscheme = "http" unless defined $rscheme;
448 636
449 # don't support https requests over https-proxy transport, 637 # don't support https requests over https-proxy transport,
450 # can't be done with tls as spec'ed, unless you double-encrypt. 638 # can't be done with tls as spec'ed, unless you double-encrypt.
451 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 639 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
640
641 $rhost = lc $rhost;
642 $rscheme = lc $rscheme;
452 } else { 643 } else {
453 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 644 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
454 } 645 }
455 646
456 # leave out fragment and query string, just a heuristic 647 # leave out fragment and query string, just a heuristic
457 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 648 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
458 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 649 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
459 650
460 $hdr{"content-length"} = length $arg{body} 651 $hdr{"content-length"} = length $arg{body}
461 if length $arg{body} || $method ne "GET"; 652 if length $arg{body} || $method ne "GET";
462 653
654 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/;
655
656 # default value for keepalive is true iff the request is for an idempotent method
657 my $keepalive = exists $arg{keepalive}
658 ? $arg{keepalive}*1
659 : $idempotent ? $PERSISTENT_TIMEOUT : 0;
660
661 $hdr{connection} = ($keepalive ? "" : "close ") . "Te"; #1.1
662 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
663
463 my %state = (connect_guard => 1); 664 my %state = (connect_guard => 1);
464 665
465 _get_slot $uhost, sub { 666 my $ae_error = 595; # connecting
466 $state{slot_guard} = shift;
467 667
668 # handle actual, non-tunneled, request
669 my $handle_actual_request = sub {
670 $ae_error = 596; # request phase
671
672 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
673
674 # send request
675 $state{handle}->push_write (
676 "$method $rpath HTTP/1.1\015\012"
677 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
678 . "\015\012"
679 . (delete $arg{body})
680 );
681
682 # return if error occured during push_write()
468 return unless $state{connect_guard}; 683 return unless %state;
469 684
470 my $tcp_connect = $arg{tcp_connect} 685 # reduce memory usage, save a kitten, also re-use it for the response headers.
471 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 686 %hdr = ();
472 687
473 $state{connect_guard} = $tcp_connect->( 688 # status line and headers
474 $rhost, 689 $state{read_response} = sub {
475 $rport, 690 for ("$_[1]") {
476 sub { 691 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
477 $state{fh} = shift
478 or do {
479 my $err = "$!";
480 %state = ();
481 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
482 };
483 692
484 pop; # free memory, save a tree 693 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
694 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
485 695
486 return unless delete $state{connect_guard}; 696 # 100 Continue handling
697 # should not happen as we don't send expect: 100-continue,
698 # but we handle it just in case.
699 # since we send the request body regardless, if we get an error
700 # we are out of-sync, which we currently do NOT handle correctly.
701 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
702 if $2 eq 100;
487 703
488 # get handle 704 push @pseudo,
489 $state{handle} = new AnyEvent::Handle 705 HTTPVersion => $1,
490 fh => $state{fh}, 706 Status => $2,
491 peername => $rhost, 707 Reason => $3,
492 tls_ctx => $arg{tls_ctx},
493 # these need to be reconfigured on keepalive handles
494 timeout => $timeout,
495 on_error => sub {
496 %state = ();
497 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
498 },
499 on_eof => sub {
500 %state = ();
501 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
502 },
503 ; 708 ;
504 709
710 my $hdr = parse_hdr
711 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
712
713 %hdr = (%$hdr, @pseudo);
714 }
715
716 # redirect handling
717 # microsoft and other shitheads don't give a shit for following standards,
718 # try to support some common forms of broken Location headers.
719 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
720 $hdr{location} =~ s/^\.\/+//;
721
722 my $url = "$rscheme://$uhost:$uport";
723
724 unless ($hdr{location} =~ s/^\///) {
725 $url .= $upath;
726 $url =~ s/\/[^\/]*$//;
727 }
728
729 $hdr{location} = "$url/$hdr{location}";
730 }
731
732 my $redirect;
733
734 if ($recurse) {
735 my $status = $hdr{Status};
736
737 # industry standard is to redirect POST as GET for
738 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
739 # also, the UA should ask the user for 301 and 307 and POST,
740 # industry standard seems to be to simply follow.
741 # we go with the industry standard.
742 if ($status == 301 or $status == 302 or $status == 303) {
743 # HTTP/1.1 is unclear on how to mutate the method
744 $method = "GET" unless $method eq "HEAD";
745 $redirect = 1;
746 } elsif ($status == 307) {
747 $redirect = 1;
748 }
749 }
750
751 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
752 my $may_keep_alive = $_[3];
753
754 $state{handle}->destroy if $state{handle};
755 %state = ();
756
757 if (defined $_[1]) {
758 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
759 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
760 }
761
762 # set-cookie processing
763 if ($arg{cookie_jar}) {
764 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
765 }
766
767 if ($redirect && exists $hdr{location}) {
768 # we ignore any errors, as it is very common to receive
769 # Content-Length != 0 but no actual body
770 # we also access %hdr, as $_[1] might be an erro
771 http_request (
772 $method => $hdr{location},
773 %arg,
774 recurse => $recurse - 1,
775 Redirect => [$_[0], \%hdr],
776 $cb);
777 } else {
778 $cb->($_[0], \%hdr);
779 }
780 };
781
782 $ae_error = 597; # body phase
783
784 my $len = $hdr{"content-length"};
785
786 # body handling, many different code paths
787 # - no body expected
788 # - want_body_handle
789 # - te chunked
790 # - 2x length known (with or without on_body)
791 # - 2x length not known (with or without on_body)
792 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
793 $finish->(undef, 598 => "Request cancelled by on_header");
794 } elsif (
795 $hdr{Status} =~ /^(?:1..|204|205|304)$/
796 or $method eq "HEAD"
797 or (defined $len && $len == 0) # == 0, not !, because "0 " is true
798 ) {
799 # no body
800 $finish->("", undef, undef, 1);
801
802 } elsif (!$redirect && $arg{want_body_handle}) {
803 $_[0]->on_eof (undef);
804 $_[0]->on_error (undef);
805 $_[0]->on_read (undef);
806
807 $finish->(delete $state{handle});
808
809 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
810 my $cl = 0;
811 my $body = undef;
812 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
813
814 $state{read_chunk} = sub {
815 $_[1] =~ /^([0-9a-fA-F]+)/
816 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
817
818 my $len = hex $1;
819
820 if ($len) {
821 $cl += $len;
822
823 $_[0]->push_read (chunk => $len, sub {
824 $on_body->($_[1], \%hdr)
825 or return $finish->(undef, 598 => "Request cancelled by on_body");
826
827 $_[0]->push_read (line => sub {
828 length $_[1]
829 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
830 $_[0]->push_read (line => $state{read_chunk});
831 });
832 });
833 } else {
834 $hdr{"content-length"} ||= $cl;
835
836 $_[0]->push_read (line => $qr_nlnl, sub {
837 if (length $_[1]) {
838 for ("$_[1]") {
839 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
840
841 my $hdr = parse_hdr
842 or return $finish->(undef, $ae_error => "Garbled response trailers");
843
844 %hdr = (%hdr, %$hdr);
845 }
846 }
847
848 $finish->($body, undef, undef, 1);
849 });
850 }
851 };
852
853 $_[0]->push_read (line => $state{read_chunk});
854
855 } elsif ($arg{on_body}) {
856 if (defined $len) {
857 $_[0]->on_read (sub {
858 $len -= length $_[0]{rbuf};
859
860 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
861 or return $finish->(undef, 598 => "Request cancelled by on_body");
862
863 $len > 0
864 or $finish->("", undef, undef, 1);
865 });
866 } else {
867 $_[0]->on_eof (sub {
868 $finish->("");
869 });
870 $_[0]->on_read (sub {
871 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
872 or $finish->(undef, 598 => "Request cancelled by on_body");
873 });
874 }
875 } else {
876 $_[0]->on_eof (undef);
877
878 if (defined $len) {
879 $_[0]->on_read (sub {
880 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
881 if $len <= length $_[0]{rbuf};
882 });
883 } else {
884 $_[0]->on_error (sub {
885 ($! == Errno::EPIPE || !$!)
886 ? $finish->(delete $_[0]{rbuf})
887 : $finish->(undef, $ae_error => $_[2]);
888 });
889 $_[0]->on_read (sub { });
890 }
891 }
892 };
893
894 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
895 };
896
897 my $connect_cb = sub {
898 $state{fh} = shift
899 or do {
900 my $err = "$!";
901 %state = ();
902 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
903 };
904
905 return unless delete $state{connect_guard};
906
907 # get handle
908 $state{handle} = new AnyEvent::Handle
909 fh => $state{fh},
910 peername => $rhost,
911 tls_ctx => $arg{tls_ctx},
912 # these need to be reconfigured on keepalive handles
913 timeout => $timeout,
914 on_error => sub {
915 %state = ();
916 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
917 },
918 on_eof => sub {
919 %state = ();
920 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
921 },
922 ;
923
505 # limit the number of persistent connections 924 # limit the number of persistent connections
506 # keepalive not yet supported 925 # keepalive not yet supported
507# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 926# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
508# ++$KA_COUNT{$_[1]}; 927# ++$KA_COUNT{$_[1]};
509# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 928# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
510# --$KA_COUNT{$_[1]} 929# --$KA_COUNT{$_[1]}
511# }; 930# };
512# $hdr{connection} = "keep-alive"; 931# $hdr{connection} = "keep-alive";
513# } else {
514 delete $hdr{connection};
515# } 932# }
516 933
517 $state{handle}->starttls ("connect") if $rscheme eq "https"; 934 $state{handle}->starttls ("connect") if $rscheme eq "https";
518 935
519 # handle actual, non-tunneled, request
520 my $handle_actual_request = sub {
521 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
522
523 # send request
524 $state{handle}->push_write (
525 "$method $rpath HTTP/1.0\015\012"
526 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
527 . "\015\012"
528 . (delete $arg{body})
529 );
530
531 # return if error occured during push_write()
532 return unless %state;
533
534 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
535
536 # status line and headers
537 $state{handle}->push_read (line => $qr_nlnl, sub {
538 for ("$_[1]") {
539 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
540
541 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
542 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
543
544 push @pseudo,
545 HTTPVersion => $1,
546 Status => $2,
547 Reason => $3,
548 ;
549
550 # things seen, not parsed:
551 # p3pP="NON CUR OTPi OUR NOR UNI"
552
553 $hdr{lc $1} .= ",$2"
554 while /\G
555 ([^:\000-\037]*):
556 [\011\040]*
557 ((?: [^\012]+ | \012[\011\040] )*)
558 \012
559 /gxc;
560
561 /\G$/
562 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
563 }
564
565 # remove the "," prefix we added to all headers above
566 substr $_, 0, 1, ""
567 for values %hdr;
568
569 # patch in all pseudo headers
570 %hdr = (%hdr, @pseudo);
571
572 # redirect handling
573 # microsoft and other shitheads don't give a shit for following standards,
574 # try to support some common forms of broken Location headers.
575 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
576 $hdr{location} =~ s/^\.\/+//;
577
578 my $url = "$rscheme://$uhost:$uport";
579
580 unless ($hdr{location} =~ s/^\///) {
581 $url .= $upath;
582 $url =~ s/\/[^\/]*$//;
583 }
584
585 $hdr{location} = "$url/$hdr{location}";
586 }
587
588 my $redirect;
589
590 if ($recurse) {
591 my $status = $hdr{Status};
592
593 # industry standard is to redirect POST as GET for
594 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
595 # also, the UA should ask the user for 301 and 307 and POST,
596 # industry standard seems to be to simply follow.
597 # we go with the industry standard.
598 if ($status == 301 or $status == 302 or $status == 303) {
599 # HTTP/1.1 is unclear on how to mutate the method
600 $method = "GET" unless $method eq "HEAD";
601 $redirect = 1;
602 } elsif ($status == 307) {
603 $redirect = 1;
604 }
605 }
606
607 my $finish = sub {
608 $state{handle}->destroy if $state{handle};
609 %state = ();
610
611 # set-cookie processing
612 if ($arg{cookie_jar}) {
613 for ($_[1]{"set-cookie"}) {
614 # parse NAME=VALUE
615 my @kv;
616
617 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
618 my $name = $1;
619 my $value = $3;
620
621 unless ($value) {
622 $value = $2;
623 $value =~ s/\\(.)/$1/gs;
624 }
625
626 push @kv, $name => $value;
627
628 last unless /\G\s*;/gc;
629 }
630
631 last unless @kv;
632
633 my $name = shift @kv;
634 my %kv = (value => shift @kv, @kv);
635
636 my $cdom;
637 my $cpath = (delete $kv{path}) || "/";
638
639 if (exists $kv{domain}) {
640 $cdom = delete $kv{domain};
641
642 $cdom =~ s/^\.?/./; # make sure it starts with a "."
643
644 next if $cdom =~ /\.$/;
645
646 # this is not rfc-like and not netscape-like. go figure.
647 my $ndots = $cdom =~ y/.//;
648 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
649 } else {
650 $cdom = $uhost;
651 }
652
653 # store it
654 $arg{cookie_jar}{version} = 1;
655 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
656
657 redo if /\G\s*,/gc;
658 }
659 }
660
661 if ($redirect && exists $hdr{location}) {
662 # we ignore any errors, as it is very common to receive
663 # Content-Length != 0 but no actual body
664 # we also access %hdr, as $_[1] might be an erro
665 http_request (
666 $method => $hdr{location},
667 %arg,
668 recurse => $recurse - 1,
669 Redirect => \@_,
670 $cb);
671 } else {
672 $cb->($_[0], $_[1]);
673 }
674 };
675
676 my $len = $hdr{"content-length"};
677
678 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
679 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
680 } elsif (
681 $hdr{Status} =~ /^(?:1..|[23]04)$/
682 or $method eq "HEAD"
683 or (defined $len && !$len)
684 ) {
685 # no body
686 $finish->("", \%hdr);
687 } else {
688 # body handling, four different code paths
689 # for want_body_handle, on_body (2x), normal (2x)
690 # we might read too much here, but it does not matter yet (no pers. connections)
691 if (!$redirect && $arg{want_body_handle}) {
692 $_[0]->on_eof (undef);
693 $_[0]->on_error (undef);
694 $_[0]->on_read (undef);
695
696 $finish->(delete $state{handle}, \%hdr);
697
698 } elsif ($arg{on_body}) {
699 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
700 if ($len) {
701 $_[0]->on_eof (undef);
702 $_[0]->on_read (sub {
703 $len -= length $_[0]{rbuf};
704
705 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
706 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
707
708 $len > 0
709 or $finish->("", \%hdr);
710 });
711 } else {
712 $_[0]->on_eof (sub {
713 $finish->("", \%hdr);
714 });
715 $_[0]->on_read (sub {
716 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
717 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
718 });
719 }
720 } else {
721 $_[0]->on_eof (undef);
722
723 if ($len) {
724 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
725 $_[0]->on_read (sub {
726 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
727 if $len <= length $_[0]{rbuf};
728 });
729 } else {
730 $_[0]->on_error (sub {
731 ($! == Errno::EPIPE || !$!)
732 ? $finish->(delete $_[0]{rbuf}, \%hdr)
733 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
734 });
735 $_[0]->on_read (sub { });
736 }
737 }
738 }
739 });
740 };
741
742 # now handle proxy-CONNECT method 936 # now handle proxy-CONNECT method
743 if ($proxy && $uscheme eq "https") { 937 if ($proxy && $uscheme eq "https") {
744 # oh dear, we have to wrap it into a connect request 938 # oh dear, we have to wrap it into a connect request
745 939
746 # maybe re-use $uauthority with patched port? 940 # maybe re-use $uauthority with patched port?
747 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 941 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
748 $state{handle}->push_read (line => $qr_nlnl, sub { 942 $state{handle}->push_read (line => $qr_nlnl, sub {
749 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 943 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
750 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 944 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
751 945
752 if ($2 == 200) { 946 if ($2 == 200) {
753 $rpath = $upath; 947 $rpath = $upath;
754 &$handle_actual_request; 948 $handle_actual_request->();
755 } else {
756 %state = ();
757 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
758 }
759 });
760 } else { 949 } else {
761 &$handle_actual_request; 950 %state = ();
951 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
762 } 952 }
763
764 }, 953 });
765 $arg{on_prepare} || sub { $timeout } 954 } else {
955 $handle_actual_request->();
766 ); 956 }
957 };
958
959 _get_slot $uhost, sub {
960 $state{slot_guard} = shift;
961
962 return unless $state{connect_guard};
963
964 my $tcp_connect = $arg{tcp_connect}
965 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
966
967 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
767 }; 968 };
768 969
769 defined wantarray && AnyEvent::Util::guard { %state = () } 970 defined wantarray && AnyEvent::Util::guard { %state = () }
770} 971}
771 972
… …
806string of the form C<http://host:port> (optionally C<https:...>), croaks 1007string of the form C<http://host:port> (optionally C<https:...>), croaks
807otherwise. 1008otherwise.
808 1009
809To clear an already-set proxy, use C<undef>. 1010To clear an already-set proxy, use C<undef>.
810 1011
1012=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1013
1014Remove all cookies from the cookie jar that have been expired. If
1015C<$session_end> is given and true, then additionally remove all session
1016cookies.
1017
1018You should call this function (with a true C<$session_end>) before you
1019save cookies to disk, and you should call this function after loading them
1020again. If you have a long-running program you can additonally call this
1021function from time to time.
1022
1023A cookie jar is initially an empty hash-reference that is managed by this
1024module. It's format is subject to change, but currently it is like this:
1025
1026The key C<version> has to contain C<1>, otherwise the hash gets
1027emptied. All other keys are hostnames or IP addresses pointing to
1028hash-references. The key for these inner hash references is the
1029server path for which this cookie is meant, and the values are again
1030hash-references. The keys of those hash-references is the cookie name, and
1031the value, you guessed it, is another hash-reference, this time with the
1032key-value pairs from the cookie, except for C<expires> and C<max-age>,
1033which have been replaced by a C<_expires> key that contains the cookie
1034expiry timestamp.
1035
1036Here is an example of a cookie jar with a single cookie, so you have a
1037chance of understanding the above paragraph:
1038
1039 {
1040 version => 1,
1041 "10.0.0.1" => {
1042 "/" => {
1043 "mythweb_id" => {
1044 _expires => 1293917923,
1045 value => "ooRung9dThee3ooyXooM1Ohm",
1046 },
1047 },
1048 },
1049 }
1050
1051=item $date = AnyEvent::HTTP::format_date $timestamp
1052
1053Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
1054Date (RFC 2616).
1055
1056=item $timestamp = AnyEvent::HTTP::parse_date $date
1057
1058Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
1059bunch of minor variations of those, and returns the corresponding POSIX
1060timestamp, or C<undef> if the date cannot be parsed.
1061
811=item $AnyEvent::HTTP::MAX_RECURSE 1062=item $AnyEvent::HTTP::MAX_RECURSE
812 1063
813The default value for the C<recurse> request parameter (default: C<10>). 1064The default value for the C<recurse> request parameter (default: C<10>).
814 1065
815=item $AnyEvent::HTTP::USERAGENT 1066=item $AnyEvent::HTTP::USERAGENT
… …
833connections. This number of can be useful for load-leveling. 1084connections. This number of can be useful for load-leveling.
834 1085
835=back 1086=back
836 1087
837=cut 1088=cut
1089
1090our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
1091our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
1092
1093sub format_date($) {
1094 my ($time) = @_;
1095
1096 # RFC 822/1123 format
1097 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
1098
1099 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
1100 $weekday[$wday], $mday, $month[$mon], $year + 1900,
1101 $H, $M, $S;
1102}
1103
1104sub parse_date($) {
1105 my ($date) = @_;
1106
1107 my ($d, $m, $y, $H, $M, $S);
1108
1109 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$/) {
1110 # RFC 822/1123, required by RFC 2616 (with " ")
1111 # cookie dates (with "-")
1112
1113 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
1114
1115 } 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$/) {
1116 # RFC 850
1117 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
1118
1119 } 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])$/) {
1120 # ISO C's asctime
1121 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
1122 }
1123 # other formats fail in the loop below
1124
1125 for (0..11) {
1126 if ($m eq $month[$_]) {
1127 require Time::Local;
1128 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
1129 }
1130 }
1131
1132 undef
1133}
838 1134
839sub set_proxy($) { 1135sub set_proxy($) {
840 if (length $_[0]) { 1136 if (length $_[0]) {
841 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix 1137 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
842 or Carp::croak "$_[0]: invalid proxy URL"; 1138 or Carp::croak "$_[0]: invalid proxy URL";

Diff Legend

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