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.62 by root, Thu Dec 30 04:30:24 2010 UTC vs.
Revision 1.68 by root, Fri Dec 31 19:22:18 2010 UTC

… …
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Handle (); 48use AnyEvent::Handle ();
49 49
50use base Exporter::; 50use base Exporter::;
51 51
52our $VERSION = '1.46'; 52our $VERSION = '1.5';
53 53
54our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
55 55
56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
57our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
… …
94C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
95object at least alive until the callback get called. If the object gets 95object at least alive until the callback get called. If the object gets
96destroyed before the callback is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
97 97
98The callback will be called with the response body data as first argument 98The 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 99(or C<undef> if an error occured), and a hash-ref with response headers
100second argument. 100(and trailers) as second argument.
101 101
102All the headers in that hash are lowercased. In addition to the response 102All the headers in that hash are lowercased. In addition to the response
103headers, the "pseudo-headers" (uppercase to avoid clashing with possible 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105three parts of the HTTP Status-Line of the same name. 105three parts of the HTTP Status-Line of the same name. If an error occurs
106during the body phase of a request, then the original C<Status> and
107C<Reason> values from the header are available as C<OrigStatus> and
108C<OrigReason>.
106 109
107The pseudo-header C<URL> contains the actual URL (which can differ from 110The pseudo-header C<URL> contains the actual URL (which can differ from
108the requested URL when following redirects - for example, you might get 111the 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 112an 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 113valid http URL because it redirected to an ftp URL, in which case you can
… …
147Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
148retries and so on, and how often to do so. 151retries and so on, and how often to do so.
149 152
150=item headers => hashref 153=item headers => hashref
151 154
152The request headers to use, with the header name (I<MUST be in lowercase>) 155The request headers to use. Currently, C<http_request> may provide its own
153as key and header value as hash value. 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
154 157will provide defaults for C<TE:>, C<Referer:> and C<User-Agent:> (this can
155Currently, http_request> may provide its own C<host>, C<content-length>, 158be suppressed by using C<undef> for these headers in which case they won't
156C<connection> and C<cookie> headers and will provide defaults for 159be sent at all).
157C<user-agent> and C<referer> (this can be suppressed by using a value of
158C<undef> for these headers in which case they won't be sent at all).
159 160
160=item timeout => $seconds 161=item timeout => $seconds
161 162
162The time-out to use for various stages - each connect attempt will reset 163The time-out to use for various stages - each connect attempt will reset
163the timeout, as will read or write activity, i.e. this is not an overall 164the timeout, as will read or write activity, i.e. this is not an overall
… …
173C<$scheme> must be either missing, C<http> for HTTP or C<https> for 174C<$scheme> must be either missing, C<http> for HTTP or C<https> for
174HTTPS. 175HTTPS.
175 176
176=item body => $string 177=item body => $string
177 178
178The request body, usually empty. Will be-sent as-is (future versions of 179The request body, usually empty. Will be sent as-is (future versions of
179this module might offer more options). 180this module might offer more options).
180 181
181=item cookie_jar => $hash_ref 182=item cookie_jar => $hash_ref
182 183
183Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
… …
239 240
240This callback is useful, among other things, to quickly reject unwanted 241This callback is useful, among other things, to quickly reject unwanted
241content, which, if it is supposed to be rare, can be faster than first 242content, which, if it is supposed to be rare, can be faster than first
242doing a C<HEAD> request. 243doing a C<HEAD> request.
243 244
245The downside is that cancelling the request makes it impossible to re-use
246the connection. Also, the C<on_header> callback will not receive any
247trailer (headers sent after the response body).
248
244Example: cancel the request unless the content-type is "text/html". 249Example: cancel the request unless the content-type is "text/html".
245 250
246 on_header => sub { 251 on_header => sub {
247 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 252 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
248 }, 253 },
… …
254string instead of the body data. 259string instead of the body data.
255 260
256It has to return either true (in which case AnyEvent::HTTP will continue), 261It has to return either true (in which case AnyEvent::HTTP will continue),
257or false, in which case AnyEvent::HTTP will cancel the download (and call 262or false, in which case AnyEvent::HTTP will cancel the download (and call
258the completion callback with an error code of C<598>). 263the completion callback with an error code of C<598>).
264
265The downside to cancelling the request is that it makes it impossible to
266re-use the connection.
259 267
260This callback is useful when the data is too large to be held in memory 268This callback is useful when the data is too large to be held in memory
261(so the callback writes it to a file) or when only some information should 269(so the callback writes it to a file) or when only some information should
262be extracted, or when the body should be processed incrementally. 270be extracted, or when the body should be processed incrementally.
263 271
… …
289If you think you need this, first have a look at C<on_body>, to see if 297If you think you need this, first have a look at C<on_body>, to see if
290that doesn't solve your problem in a better way. 298that doesn't solve your problem in a better way.
291 299
292=back 300=back
293 301
294Example: make a simple HTTP GET request for http://www.nethype.de/ 302Example: do a simple HTTP GET request for http://www.nethype.de/ and print
303the response body.
295 304
296 http_request GET => "http://www.nethype.de/", sub { 305 http_request GET => "http://www.nethype.de/", sub {
297 my ($body, $hdr) = @_; 306 my ($body, $hdr) = @_;
298 print "$body\n"; 307 print "$body\n";
299 }; 308 };
300 309
301Example: make a HTTP HEAD request on https://www.google.com/, use a 310Example: do a HTTP HEAD request on https://www.google.com/, use a
302timeout of 30 seconds. 311timeout of 30 seconds.
303 312
304 http_request 313 http_request
305 GET => "https://www.google.com", 314 GET => "https://www.google.com",
306 timeout => 30, 315 timeout => 30,
… …
309 use Data::Dumper; 318 use Data::Dumper;
310 print Dumper $hdr; 319 print Dumper $hdr;
311 } 320 }
312 ; 321 ;
313 322
314Example: make another simple HTTP GET request, but immediately try to 323Example: do another simple HTTP GET request, but immediately try to
315cancel it. 324cancel it.
316 325
317 my $request = http_request GET => "http://www.nethype.de/", sub { 326 my $request = http_request GET => "http://www.nethype.de/", sub {
318 my ($body, $hdr) = @_; 327 my ($body, $hdr) = @_;
319 print "$body\n"; 328 print "$body\n";
… …
351 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 360 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
352 361
353 _slot_schedule $_[0]; 362 _slot_schedule $_[0];
354} 363}
355 364
365# continue to parse $_ for headers and place them into the arg
366sub parse_hdr() {
367 my %hdr;
368
369 # things seen, not parsed:
370 # p3pP="NON CUR OTPi OUR NOR UNI"
371
372 $hdr{lc $1} .= ",$2"
373 while /\G
374 ([^:\000-\037]*):
375 [\011\040]*
376 ((?: [^\012]+ | \012[\011\040] )*)
377 \012
378 /gxc;
379
380 /\G$/
381 or return;
382
383 # remove the "," prefix we added to all headers above
384 substr $_, 0, 1, ""
385 for values %hdr;
386
387 \%hdr
388}
389
356our $qr_nlnl = qr{(?<![^\012])\015?\012}; 390our $qr_nlnl = qr{(?<![^\012])\015?\012};
357 391
358our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 392our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
359our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 393our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
360 394
… …
379 my @pseudo = (URL => $url); 413 my @pseudo = (URL => $url);
380 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 414 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
381 415
382 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 416 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
383 417
384 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 418 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
385 if $recurse < 0; 419 if $recurse < 0;
386 420
387 my $proxy = $arg{proxy} || $PROXY; 421 my $proxy = $arg{proxy} || $PROXY;
388 my $timeout = $arg{timeout} || $TIMEOUT; 422 my $timeout = $arg{timeout} || $TIMEOUT;
389 423
… …
392 426
393 $uscheme = lc $uscheme; 427 $uscheme = lc $uscheme;
394 428
395 my $uport = $uscheme eq "http" ? 80 429 my $uport = $uscheme eq "http" ? 80
396 : $uscheme eq "https" ? 443 430 : $uscheme eq "https" ? 443
397 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 431 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
398 432
399 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 433 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
400 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 434 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
401 435
402 my $uhost = $1; 436 my $uhost = $1;
403 $uport = $2 if defined $2; 437 $uport = $2 if defined $2;
404 438
405 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 439 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
454 } else { 488 } else {
455 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 489 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
456 } 490 }
457 491
458 # leave out fragment and query string, just a heuristic 492 # leave out fragment and query string, just a heuristic
459 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 493 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
460 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 494 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
461 495
462 $hdr{"content-length"} = length $arg{body} 496 $hdr{"content-length"} = length $arg{body}
463 if length $arg{body} || $method ne "GET"; 497 if length $arg{body} || $method ne "GET";
464 498
499 $hdr{connection} = "close TE"; #1.1
500 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
501
465 my %state = (connect_guard => 1); 502 my %state = (connect_guard => 1);
466 503
467 _get_slot $uhost, sub { 504 _get_slot $uhost, sub {
468 $state{slot_guard} = shift; 505 $state{slot_guard} = shift;
469 506
470 return unless $state{connect_guard}; 507 return unless $state{connect_guard};
471 508
472 my $tcp_connect = $arg{tcp_connect} 509 my $connect_cb = sub {
473 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
474
475 $state{connect_guard} = $tcp_connect->(
476 $rhost,
477 $rport,
478 sub {
479 $state{fh} = shift 510 $state{fh} = shift
480 or do { 511 or do {
481 my $err = "$!"; 512 my $err = "$!";
482 %state = (); 513 %state = ();
483 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 514 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
484 }; 515 };
485 516
486 pop; # free memory, save a tree 517 pop; # free memory, save a tree
487 518
488 return unless delete $state{connect_guard}; 519 return unless delete $state{connect_guard};
489 520
490 # get handle 521 # get handle
491 $state{handle} = new AnyEvent::Handle 522 $state{handle} = new AnyEvent::Handle
492 fh => $state{fh}, 523 fh => $state{fh},
493 peername => $rhost, 524 peername => $rhost,
494 tls_ctx => $arg{tls_ctx}, 525 tls_ctx => $arg{tls_ctx},
495 # these need to be reconfigured on keepalive handles 526 # these need to be reconfigured on keepalive handles
496 timeout => $timeout, 527 timeout => $timeout,
497 on_error => sub { 528 on_error => sub {
498 %state = (); 529 %state = ();
499 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 530 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
500 }, 531 },
501 on_eof => sub { 532 on_eof => sub {
502 %state = (); 533 %state = ();
503 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 534 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
504 }, 535 },
505 ; 536 ;
506 537
507 # limit the number of persistent connections 538 # limit the number of persistent connections
508 # keepalive not yet supported 539 # keepalive not yet supported
509# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 540# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
510# ++$KA_COUNT{$_[1]}; 541# ++$KA_COUNT{$_[1]};
511# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 542# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
512# --$KA_COUNT{$_[1]} 543# --$KA_COUNT{$_[1]}
513# }; 544# };
514# $hdr{connection} = "keep-alive"; 545# $hdr{connection} = "keep-alive";
515# } else {
516 delete $hdr{connection};
517# } 546# }
518 547
519 $state{handle}->starttls ("connect") if $rscheme eq "https"; 548 $state{handle}->starttls ("connect") if $rscheme eq "https";
520 549
521 # handle actual, non-tunneled, request 550 # handle actual, non-tunneled, request
522 my $handle_actual_request = sub { 551 my $handle_actual_request = sub {
523 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 552 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
524 553
525 # send request 554 # send request
526 $state{handle}->push_write ( 555 $state{handle}->push_write (
527 "$method $rpath HTTP/1.0\015\012" 556 "$method $rpath HTTP/1.1\015\012"
528 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 557 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
529 . "\015\012" 558 . "\015\012"
530 . (delete $arg{body}) 559 . (delete $arg{body})
531 ); 560 );
532 561
533 # return if error occured during push_write() 562 # return if error occured during push_write()
534 return unless %state; 563 return unless %state;
535 564
536 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 565 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
537 566
538 # status line and headers 567 # status line and headers
539 $state{handle}->push_read (line => $qr_nlnl, sub { 568 $state{read_response} = sub {
540 for ("$_[1]") { 569 for ("$_[1]") {
541 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 570 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
542 571
543 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 572 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
544 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); 573 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
545 574
575 # 100 Continue handling
576 # should not happen as we don't send expect: 100-continue,
577 # but we handle it just in case.
578 # since we send the request body regardless, if we get an error
579 # we are out of-sync, which we currently do NOT handle correctly.
580 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
581 if $2 eq 100;
582
546 push @pseudo, 583 push @pseudo,
547 HTTPVersion => $1, 584 HTTPVersion => $1,
548 Status => $2, 585 Status => $2,
549 Reason => $3, 586 Reason => $3,
550 ; 587 ;
551 588
552 # things seen, not parsed: 589 my $hdr = parse_hdr
553 # p3pP="NON CUR OTPi OUR NOR UNI"
554
555 $hdr{lc $1} .= ",$2"
556 while /\G
557 ([^:\000-\037]*):
558 [\011\040]*
559 ((?: [^\012]+ | \012[\011\040] )*)
560 \012
561 /gxc;
562
563 /\G$/
564 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 590 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
591
592 %hdr = (%$hdr, @pseudo);
593 }
594
595 # redirect handling
596 # microsoft and other shitheads don't give a shit for following standards,
597 # try to support some common forms of broken Location headers.
598 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
599 $hdr{location} =~ s/^\.\/+//;
600
601 my $url = "$rscheme://$uhost:$uport";
602
603 unless ($hdr{location} =~ s/^\///) {
604 $url .= $upath;
605 $url =~ s/\/[^\/]*$//;
565 } 606 }
566 607
567 # remove the "," prefix we added to all headers above
568 substr $_, 0, 1, ""
569 for values %hdr;
570
571 # patch in all pseudo headers
572 %hdr = (%hdr, @pseudo);
573
574 # redirect handling
575 # microsoft and other shitheads don't give a shit for following standards,
576 # try to support some common forms of broken Location headers.
577 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
578 $hdr{location} =~ s/^\.\/+//;
579
580 my $url = "$rscheme://$uhost:$uport";
581
582 unless ($hdr{location} =~ s/^\///) {
583 $url .= $upath;
584 $url =~ s/\/[^\/]*$//;
585 }
586
587 $hdr{location} = "$url/$hdr{location}"; 608 $hdr{location} = "$url/$hdr{location}";
609 }
610
611 my $redirect;
612
613 if ($recurse) {
614 my $status = $hdr{Status};
615
616 # industry standard is to redirect POST as GET for
617 # 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,
619 # industry standard seems to be to simply follow.
620 # we go with the industry standard.
621 if ($status == 301 or $status == 302 or $status == 303) {
622 # HTTP/1.1 is unclear on how to mutate the method
623 $method = "GET" unless $method eq "HEAD";
624 $redirect = 1;
625 } elsif ($status == 307) {
626 $redirect = 1;
588 } 627 }
628 }
589 629
630 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
590 my $redirect; 631 my $keepalive = pop;
591 632
633 $state{handle}->destroy if $state{handle};
634 %state = ();
635
636 if (defined $_[1]) {
637 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
638 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
639 }
640
641 # set-cookie processing
592 if ($recurse) { 642 if ($arg{cookie_jar}) {
593 my $status = $hdr{Status}; 643 for ($hdr{"set-cookie"}) {
644 # parse NAME=VALUE
645 my @kv;
594 646
595 # industry standard is to redirect POST as GET for 647 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
596 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
597 # also, the UA should ask the user for 301 and 307 and POST,
598 # industry standard seems to be to simply follow.
599 # we go with the industry standard.
600 if ($status == 301 or $status == 302 or $status == 303) {
601 # HTTP/1.1 is unclear on how to mutate the method
602 $method = "GET" unless $method eq "HEAD";
603 $redirect = 1; 648 my $name = $1;
604 } elsif ($status == 307) { 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
605 $redirect = 1; 683 # store it
684 $arg{cookie_jar}{version} = 1;
685 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
686
687 redo if /\G\s*,/gc;
606 } 688 }
607 } 689 }
608 690
609 my $finish = sub {
610 $state{handle}->destroy if $state{handle};
611 %state = ();
612
613 # set-cookie processing
614 if ($arg{cookie_jar}) {
615 for ($_[1]{"set-cookie"}) {
616 # parse NAME=VALUE
617 my @kv;
618
619 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
620 my $name = $1;
621 my $value = $3;
622
623 unless ($value) {
624 $value = $2;
625 $value =~ s/\\(.)/$1/gs;
626 }
627
628 push @kv, $name => $value;
629
630 last unless /\G\s*;/gc;
631 }
632
633 last unless @kv;
634
635 my $name = shift @kv;
636 my %kv = (value => shift @kv, @kv);
637
638 my $cdom;
639 my $cpath = (delete $kv{path}) || "/";
640
641 if (exists $kv{domain}) {
642 $cdom = delete $kv{domain};
643
644 $cdom =~ s/^\.?/./; # make sure it starts with a "."
645
646 next if $cdom =~ /\.$/;
647
648 # this is not rfc-like and not netscape-like. go figure.
649 my $ndots = $cdom =~ y/.//;
650 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
651 } else {
652 $cdom = $uhost;
653 }
654
655 # store it
656 $arg{cookie_jar}{version} = 1;
657 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
658
659 redo if /\G\s*,/gc;
660 }
661 }
662
663 if ($redirect && exists $hdr{location}) { 691 if ($redirect && exists $hdr{location}) {
664 # we ignore any errors, as it is very common to receive 692 # we ignore any errors, as it is very common to receive
665 # Content-Length != 0 but no actual body 693 # Content-Length != 0 but no actual body
666 # we also access %hdr, as $_[1] might be an erro 694 # we also access %hdr, as $_[1] might be an erro
667 http_request ( 695 http_request (
668 $method => $hdr{location}, 696 $method => $hdr{location},
669 %arg, 697 %arg,
670 recurse => $recurse - 1, 698 recurse => $recurse - 1,
671 Redirect => \@_, 699 Redirect => [$_[0], \%hdr],
672 $cb); 700 $cb);
673 } else {
674 $cb->($_[0], $_[1]);
675 }
676 };
677
678 my $len = $hdr{"content-length"};
679
680 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
681 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
682 } elsif (
683 $hdr{Status} =~ /^(?:1..|[23]04)$/
684 or $method eq "HEAD"
685 or (defined $len && !$len)
686 ) {
687 # no body
688 $finish->("", \%hdr);
689 } else { 701 } else {
702 $cb->($_[0], \%hdr);
703 }
704 };
705
706 my $len = $hdr{"content-length"};
707
708 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
709 $finish->(undef, 598 => "Request cancelled by on_header");
710 } elsif (
711 $hdr{Status} =~ /^(?:1..|204|205|304)$/
712 or $method eq "HEAD"
713 or (defined $len && !$len)
714 ) {
715 # no body
716 $finish->("", undef, undef, 1);
717 } else {
690 # body handling, four different code paths 718 # body handling, many different code paths
691 # for want_body_handle, on_body (2x), normal (2x) 719 # - no body expected
692 # we might read too much here, but it does not matter yet (no pers. connections) 720 # - want_body_handle
721 # - te chunked
722 # - 2x length known (with or without on_body)
723 # - 2x length not known (with or without on_body)
693 if (!$redirect && $arg{want_body_handle}) { 724 if (!$redirect && $arg{want_body_handle}) {
694 $_[0]->on_eof (undef); 725 $_[0]->on_eof (undef);
695 $_[0]->on_error (undef); 726 $_[0]->on_error (undef);
696 $_[0]->on_read (undef); 727 $_[0]->on_read (undef);
697 728
698 $finish->(delete $state{handle}, \%hdr); 729 $finish->(delete $state{handle});
699 730
700 } elsif ($arg{on_body}) { 731 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
732 my $cl = 0;
733 my $body = undef;
734 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
735
701 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 736 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
737
738 my $read_chunk; $read_chunk = sub {
739 $_[1] =~ /^([0-9a-fA-F]+)/
740 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
741
742 my $len = hex $1;
743
702 if ($len) { 744 if ($len) {
703 $_[0]->on_eof (undef); 745 $cl += $len;
746
747 $_[0]->push_read (chunk => $len, sub {
748 $on_body->($_[1], \%hdr)
749 or return $finish->(undef, 598 => "Request cancelled by on_body");
750
704 $_[0]->on_read (sub { 751 $_[0]->push_read (line => sub {
705 $len -= length $_[0]{rbuf}; 752 length $_[1]
706 753 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
707 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 754 $_[0]->push_read (line => $read_chunk);
708 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
709
710 $len > 0 755 });
711 or $finish->("", \%hdr);
712 }); 756 });
713 } else { 757 } else {
714 $_[0]->on_eof (sub { 758 $hdr{"content-length"} ||= $cl;
715 $finish->("", \%hdr); 759
760 $_[0]->push_read (line => $qr_nlnl, sub {
761 if (length $_[1]) {
762 for ("$_[1]") {
763 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
764
765 my $hdr = parse_hdr
766 or return $finish->(undef, 599 => "Garbled response trailers");
767
768 %hdr = (%hdr, %$hdr);
769 }
716 }); 770 }
717 $_[0]->on_read (sub { 771
718 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 772 $finish->($body, undef, undef, 1);
719 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
720 }); 773 });
721 } 774 }
775 };
776
777 $_[0]->push_read (line => $read_chunk);
778
779 } elsif ($arg{on_body}) {
780 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
781
782 if ($len) {
783 $_[0]->on_read (sub {
784 $len -= length $_[0]{rbuf};
785
786 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
787 or return $finish->(undef, 598 => "Request cancelled by on_body");
788
789 $len > 0
790 or $finish->("", undef, undef, 1);
791 });
722 } else { 792 } else {
723 $_[0]->on_eof (undef); 793 $_[0]->on_eof (sub {
724 794 $finish->("");
725 if ($len) { 795 });
726 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
727 $_[0]->on_read (sub { 796 $_[0]->on_read (sub {
797 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
798 or $finish->(undef, 598 => "Request cancelled by on_body");
799 });
800 }
801 } else {
802 $_[0]->on_eof (undef);
803
804 if ($len) {
805 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
806 $_[0]->on_read (sub {
728 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 807 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
729 if $len <= length $_[0]{rbuf}; 808 if $len <= length $_[0]{rbuf};
730 }); 809 });
731 } else { 810 } else {
732 $_[0]->on_error (sub { 811 $_[0]->on_error (sub {
733 ($! == Errno::EPIPE || !$!) 812 ($! == Errno::EPIPE || !$!)
734 ? $finish->(delete $_[0]{rbuf}, \%hdr) 813 ? $finish->(delete $_[0]{rbuf})
735 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 814 : $finish->(undef, 599 => $_[2]);
736 }); 815 });
737 $_[0]->on_read (sub { }); 816 $_[0]->on_read (sub { });
738 }
739 } 817 }
740 } 818 }
741 }); 819 }
742 }; 820 };
743 821
822 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
823 };
824
744 # now handle proxy-CONNECT method 825 # now handle proxy-CONNECT method
745 if ($proxy && $uscheme eq "https") { 826 if ($proxy && $uscheme eq "https") {
746 # oh dear, we have to wrap it into a connect request 827 # oh dear, we have to wrap it into a connect request
747 828
748 # maybe re-use $uauthority with patched port? 829 # maybe re-use $uauthority with patched port?
749 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 830 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
750 $state{handle}->push_read (line => $qr_nlnl, sub { 831 $state{handle}->push_read (line => $qr_nlnl, sub {
751 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 832 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
752 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 833 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
753 834
754 if ($2 == 200) { 835 if ($2 == 200) {
755 $rpath = $upath; 836 $rpath = $upath;
756 &$handle_actual_request; 837 &$handle_actual_request;
757 } else { 838 } else {
758 %state = (); 839 %state = ();
759 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 840 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
760 }
761 }); 841 }
842 });
762 } else { 843 } else {
763 &$handle_actual_request; 844 &$handle_actual_request;
764 }
765
766 }, 845 }
767 $arg{on_prepare} || sub { $timeout }
768 ); 846 };
847
848 my $tcp_connect = $arg{tcp_connect}
849 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
850
851 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
852
769 }; 853 };
770 854
771 defined wantarray && AnyEvent::Util::guard { %state = () } 855 defined wantarray && AnyEvent::Util::guard { %state = () }
772} 856}
773 857

Diff Legend

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