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.33 by root, Mon Oct 27 11:09:54 2008 UTC vs.
Revision 1.38 by root, Sat Mar 7 03:43:09 2009 UTC

… …
48use AnyEvent::Socket (); 48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 49use AnyEvent::Handle ();
50 50
51use base Exporter::; 51use base Exporter::;
52 52
53our $VERSION = '1.05'; 53our $VERSION = '1.11';
54 54
55our @EXPORT = qw(http_get http_post http_head http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
56 56
57our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
… …
236sub _get_slot($$) { 236sub _get_slot($$) {
237 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 237 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
238 238
239 _slot_schedule $_[0]; 239 _slot_schedule $_[0];
240} 240}
241
242our $qr_nl = qr<\015?\012>;
243our $qr_nlnl = qr<\015?\012\015?\012>;
241 244
242sub http_request($$@) { 245sub http_request($$@) {
243 my $cb = pop; 246 my $cb = pop;
244 my ($method, $url, %arg) = @_; 247 my ($method, $url, %arg) = @_;
245 248
… …
317 } 320 }
318 321
319 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 322 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
320 323
321 if ($proxy) { 324 if ($proxy) {
322 ($rhost, $rport, $rscheme, $rpath) = (@$proxy, $url); 325 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
323 326
324 # don't support https requests over https-proxy transport, 327 # don't support https requests over https-proxy transport,
325 # can't be done with tls as spec'ed. 328 # can't be done with tls as spec'ed, unless you double-encrypt.
326 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 329 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
327 } else { 330 } else {
328 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 331 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
329 } 332 }
330 333
… …
339 return unless $state{connect_guard}; 342 return unless $state{connect_guard};
340 343
341 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 344 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
342 $state{fh} = shift 345 $state{fh} = shift
343 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); 346 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url });
347 pop; # free memory, save a tree
344 348
345 delete $state{connect_guard}; # reduce memory usage, save a tree 349 return unless delete $state{connect_guard};
346 350
347 # get handle 351 # get handle
348 $state{handle} = new AnyEvent::Handle 352 $state{handle} = new AnyEvent::Handle
349 fh => $state{fh}; 353 fh => $state{fh},
354 timeout => $timeout;
350 355
351 # limit the number of persistent connections 356 # limit the number of persistent connections
357 # keepalive not yet supported
352 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 358 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
353 ++$KA_COUNT{$_[1]}; 359 ++$KA_COUNT{$_[1]};
354 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; 360 $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
361 --$KA_COUNT{$_[1]}
362 };
355 $hdr{connection} = "keep-alive"; 363 $hdr{connection} = "keep-alive";
356 delete $hdr{connection}; # keep-alive not yet supported
357 } else { 364 } else {
358 delete $hdr{connection}; 365 delete $hdr{connection};
359 } 366 }
360 367
361 # (re-)configure handle 368 # (re-)configure handle
362 $state{handle}->timeout ($timeout);
363 $state{handle}->on_error (sub { 369 $state{handle}->on_error (sub {
364 my $errno = "$!"; 370 my $errno = "$!";
365 %state = (); 371 %state = ();
366 $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); 372 $cb->(undef, { Status => 599, Reason => $errno, URL => $url });
367 }); 373 });
… …
372 378
373 $state{handle}->starttls ("connect") if $rscheme eq "https"; 379 $state{handle}->starttls ("connect") if $rscheme eq "https";
374 380
375 # handle actual, non-tunneled, request 381 # handle actual, non-tunneled, request
376 my $handle_actual_request = sub { 382 my $handle_actual_request = sub {
377 $state{handle}->starttls ("connect") if $uscheme eq "https"; 383 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
378 384
379 # send request 385 # send request
380 $state{handle}->push_write ( 386 $state{handle}->push_write (
381 "$method $rpath HTTP/1.0\015\012" 387 "$method $rpath HTTP/1.0\015\012"
382 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) 388 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
… …
385 ); 391 );
386 392
387 %hdr = (); # reduce memory usage, save a kitten 393 %hdr = (); # reduce memory usage, save a kitten
388 394
389 # status line 395 # status line
390 $state{handle}->push_read (line => qr/\015?\012/, sub { 396 $state{handle}->push_read (line => $qr_nl, sub {
391 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 397 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
392 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url })); 398 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
393 399
394 my %hdr = ( # response headers 400 my %hdr = ( # response headers
395 HTTPVersion => ",$1", 401 HTTPVersion => ",$1",
… …
397 Reason => ",$3", 403 Reason => ",$3",
398 URL => ",$url" 404 URL => ",$url"
399 ); 405 );
400 406
401 # headers, could be optimized a bit 407 # headers, could be optimized a bit
402 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 408 $state{handle}->unshift_read (line => $qr_nlnl, sub {
403 for ("$_[1]\012") { 409 for ("$_[1]\012") {
404 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 410 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
405 411
406 # we support spaces in field names, as lotus domino 412 # we support spaces in field names, as lotus domino
407 # creates them (actually spaces around seperators 413 # creates them (actually spaces around seperators
… …
420 426
421 substr $_, 0, 1, "" 427 substr $_, 0, 1, ""
422 for values %hdr; 428 for values %hdr;
423 429
424 my $finish = sub { 430 my $finish = sub {
425 # TODO: use destroy method, when/if available
426 #$state{handle}->destroy; 431 $state{handle}->destroy;
427 $state{handle}->on_eof (undef);
428 $state{handle}->on_error (undef);
429 %state = (); 432 %state = ();
430 433
431 # set-cookie processing 434 # set-cookie processing
432 if ($arg{cookie_jar}) { 435 if ($arg{cookie_jar}) {
433 for ($hdr{"set-cookie"}) { 436 for ($hdr{"set-cookie"}) {
… …
522 }); 525 });
523 } else { 526 } else {
524 # too bad, need to read until we get an error or EOF, 527 # too bad, need to read until we get an error or EOF,
525 # no way to detect winged data. 528 # no way to detect winged data.
526 $_[0]->on_error (sub { 529 $_[0]->on_error (sub {
530 # delete ought to be more efficient, as we would have to make
531 # a copy otherwise as $_[0] gets destroyed.
527 $finish->($_[0]{rbuf}, \%hdr); 532 $finish->(delete $_[0]{rbuf}, \%hdr);
528 }); 533 });
529 $_[0]->on_eof (undef); 534 $_[0]->on_eof (undef);
530 $_[0]->on_read (sub { }); 535 $_[0]->on_read (sub { });
531 } 536 }
532 } 537 }
… …
538 if ($proxy && $uscheme eq "https") { 543 if ($proxy && $uscheme eq "https") {
539 # oh dear, we have to wrap it into a connect request 544 # oh dear, we have to wrap it into a connect request
540 545
541 # maybe re-use $uauthority with patched port? 546 # maybe re-use $uauthority with patched port?
542 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 547 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
543 $state{handle}->push_read (line => qr/\015?\012\015?\012/, sub { 548 $state{handle}->push_read (line => $qr_nlnl, sub {
544 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 549 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
545 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url })); 550 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url }));
546 551
547 if ($2 == 200) { 552 if ($2 == 200) {
548 $rpath = $upath; 553 $rpath = $upath;
… …
636=head1 AUTHOR 641=head1 AUTHOR
637 642
638 Marc Lehmann <schmorp@schmorp.de> 643 Marc Lehmann <schmorp@schmorp.de>
639 http://home.schmorp.de/ 644 http://home.schmorp.de/
640 645
646With many thanks to Дмитрий Шалашов, who provided countless
647testcases and bugreports.
648
641=cut 649=cut
642 650
6431 6511
644 652

Diff Legend

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