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.57 by root, Mon Sep 6 06:31:32 2010 UTC vs.
Revision 1.60 by root, Thu Dec 30 02:56:28 2010 UTC

… …
43 43
44use Errno (); 44use Errno ();
45 45
46use AnyEvent 5.0 (); 46use AnyEvent 5.0 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 48use AnyEvent::Handle ();
50 49
51use base Exporter::; 50use base Exporter::;
52 51
53our $VERSION = '1.46'; 52our $VERSION = '1.46';
… …
92must be an absolute http or https URL. 91must be an absolute http or https URL.
93 92
94When called in void context, nothing is returned. In other contexts, 93When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
96object 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
97destroyed before the callbakc is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
98 97
99The 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
100(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 as
101second argument. 100second argument.
102 101
… …
211connect (for exmaple, to bind it on a given IP address). This parameter 210connect (for exmaple, to bind it on a given IP address). This parameter
212overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 211overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
213and behaves exactly the same way (e.g. it has to provide a 212and behaves exactly the same way (e.g. it has to provide a
214timeout). See the description for the C<$prepare_cb> argument of 213timeout). See the description for the C<$prepare_cb> argument of
215C<AnyEvent::Socket::tcp_connect> for details. 214C<AnyEvent::Socket::tcp_connect> for details.
215
216=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
217
218In even rarer cases you want total control over how AnyEvent::HTTP
219establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
220to do this, but you can provide your own C<tcp_connect> function -
221obviously, it has to follow the same calling conventions, except that it
222may always return a connection guard object.
223
224There are probably lots of weird uses for this function, starting from
225tracing the hosts C<http_request> actually tries to connect, to (inexact
226but fast) host => IP address caching or even socks protocol support.
216 227
217=item on_header => $callback->($headers) 228=item on_header => $callback->($headers)
218 229
219When specified, this callback will be called with the header hash as soon 230When specified, this callback will be called with the header hash as soon
220as headers have been successfully received from the remote server (not on 231as headers have been successfully received from the remote server (not on
… …
454 _get_slot $uhost, sub { 465 _get_slot $uhost, sub {
455 $state{slot_guard} = shift; 466 $state{slot_guard} = shift;
456 467
457 return unless $state{connect_guard}; 468 return unless $state{connect_guard};
458 469
459 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 470 my $tcp_connect = $arg{tcp_connect}
471 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
472
473 $state{connect_guard} = $tcp_connect->(
474 $rhost,
475 $rport,
476 sub {
460 $state{fh} = shift 477 $state{fh} = shift
461 or do { 478 or do {
462 my $err = "$!"; 479 my $err = "$!";
463 %state = (); 480 %state = ();
464 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 481 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
465 }; 482 };
466 483
467 pop; # free memory, save a tree 484 pop; # free memory, save a tree
468 485
469 return unless delete $state{connect_guard}; 486 return unless delete $state{connect_guard};
470 487
471 # get handle 488 # get handle
472 $state{handle} = new AnyEvent::Handle 489 $state{handle} = new AnyEvent::Handle
473 fh => $state{fh}, 490 fh => $state{fh},
474 peername => $rhost, 491 peername => $rhost,
475 tls_ctx => $arg{tls_ctx}, 492 tls_ctx => $arg{tls_ctx},
476 # these need to be reconfigured on keepalive handles 493 # these need to be reconfigured on keepalive handles
477 timeout => $timeout, 494 timeout => $timeout,
478 on_error => sub { 495 on_error => sub {
479 %state = (); 496 %state = ();
480 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 497 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
481 }, 498 },
482 on_eof => sub { 499 on_eof => sub {
483 %state = (); 500 %state = ();
484 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 501 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
485 }, 502 },
486 ; 503 ;
487 504
488 # limit the number of persistent connections 505 # limit the number of persistent connections
489 # keepalive not yet supported 506 # keepalive not yet supported
490# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 507# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
491# ++$KA_COUNT{$_[1]}; 508# ++$KA_COUNT{$_[1]};
492# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 509# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
493# --$KA_COUNT{$_[1]} 510# --$KA_COUNT{$_[1]}
494# }; 511# };
495# $hdr{connection} = "keep-alive"; 512# $hdr{connection} = "keep-alive";
496# } else { 513# } else {
497 delete $hdr{connection}; 514 delete $hdr{connection};
498# } 515# }
499 516
500 $state{handle}->starttls ("connect") if $rscheme eq "https"; 517 $state{handle}->starttls ("connect") if $rscheme eq "https";
501 518
502 # handle actual, non-tunneled, request 519 # handle actual, non-tunneled, request
503 my $handle_actual_request = sub { 520 my $handle_actual_request = sub {
504 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 521 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
505 522
506 # send request 523 # send request
507 $state{handle}->push_write ( 524 $state{handle}->push_write (
508 "$method $rpath HTTP/1.0\015\012" 525 "$method $rpath HTTP/1.0\015\012"
509 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 526 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
510 . "\015\012" 527 . "\015\012"
511 . (delete $arg{body}) 528 . (delete $arg{body})
512 ); 529 );
513 530
514 # return if error occured during push_write() 531 # return if error occured during push_write()
515 return unless %state; 532 return unless %state;
516 533
517 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 534 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
518 535
519 # status line and headers 536 # status line and headers
520 $state{handle}->push_read (line => $qr_nlnl, sub { 537 $state{handle}->push_read (line => $qr_nlnl, sub {
521 for ("$_[1]") { 538 for ("$_[1]") {
522 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 539 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
523 540
524 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 541 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
525 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); 542 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
526 543
527 push @pseudo, 544 push @pseudo,
528 HTTPVersion => $1, 545 HTTPVersion => $1,
529 Status => $2, 546 Status => $2,
530 Reason => $3, 547 Reason => $3,
531 ; 548 ;
532 549
533 # things seen, not parsed: 550 # things seen, not parsed:
534 # p3pP="NON CUR OTPi OUR NOR UNI" 551 # p3pP="NON CUR OTPi OUR NOR UNI"
535 552
536 $hdr{lc $1} .= ",$2" 553 $hdr{lc $1} .= ",$2"
537 while /\G 554 while /\G
538 ([^:\000-\037]*): 555 ([^:\000-\037]*):
539 [\011\040]* 556 [\011\040]*
540 ((?: [^\012]+ | \012[\011\040] )*) 557 ((?: [^\012]+ | \012[\011\040] )*)
541 \012 558 \012
542 /gxc; 559 /gxc;
543 560
544 /\G$/ 561 /\G$/
545 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 562 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
546 }
547
548 # remove the "," prefix we added to all headers above
549 substr $_, 0, 1, ""
550 for values %hdr;
551
552 # patch in all pseudo headers
553 %hdr = (%hdr, @pseudo);
554
555 # redirect handling
556 # microsoft and other shitheads don't give a shit for following standards,
557 # try to support some common forms of broken Location headers.
558 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
559 $hdr{location} =~ s/^\.\/+//;
560
561 my $url = "$rscheme://$uhost:$uport";
562
563 unless ($hdr{location} =~ s/^\///) {
564 $url .= $upath;
565 $url =~ s/\/[^\/]*$//;
566 } 563 }
567 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
568 $hdr{location} = "$url/$hdr{location}"; 585 $hdr{location} = "$url/$hdr{location}";
569 }
570
571 my $redirect;
572
573 if ($recurse) {
574 my $status = $hdr{Status};
575
576 # industry standard is to redirect POST as GET for
577 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
578 # also, the UA should ask the user for 301 and 307 and POST,
579 # industry standard seems to be to simply follow.
580 # we go with the industry standard.
581 if ($status == 301 or $status == 302 or $status == 303) {
582 # HTTP/1.1 is unclear on how to mutate the method
583 $method = "GET" unless $method eq "HEAD";
584 $redirect = 1;
585 } elsif ($status == 307) {
586 $redirect = 1;
587 } 586 }
588 }
589 587
590 my $finish = sub { 588 my $redirect;
591 $state{handle}->destroy if $state{handle};
592 %state = ();
593 589
594 # set-cookie processing 590 if ($recurse) {
595 if ($arg{cookie_jar}) { 591 my $status = $hdr{Status};
596 for ($_[1]{"set-cookie"}) {
597 # parse NAME=VALUE
598 my @kv;
599 592
600 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 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 my $name = $1; 601 $redirect = 1;
602 my $value = $3; 602 } elsif ($status == 307) {
603
604 unless ($value) {
605 $value = $2;
606 $value =~ s/\\(.)/$1/gs;
607 }
608
609 push @kv, $name => $value;
610
611 last unless /\G\s*;/gc;
612 }
613
614 last unless @kv;
615
616 my $name = shift @kv;
617 my %kv = (value => shift @kv, @kv);
618
619 my $cdom;
620 my $cpath = (delete $kv{path}) || "/";
621
622 if (exists $kv{domain}) {
623 $cdom = delete $kv{domain};
624
625 $cdom =~ s/^\.?/./; # make sure it starts with a "."
626
627 next if $cdom =~ /\.$/;
628
629 # this is not rfc-like and not netscape-like. go figure.
630 my $ndots = $cdom =~ y/.//;
631 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
632 } else {
633 $cdom = $uhost;
634 }
635
636 # store it 603 $redirect = 1;
637 $arg{cookie_jar}{version} = 1;
638 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
639
640 redo if /\G\s*,/gc;
641 } 604 }
642 } 605 }
643 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
644 if ($redirect && exists $hdr{location}) { 661 if ($redirect && exists $hdr{location}) {
645 # we ignore any errors, as it is very common to receive 662 # we ignore any errors, as it is very common to receive
646 # Content-Length != 0 but no actual body 663 # Content-Length != 0 but no actual body
647 # we also access %hdr, as $_[1] might be an erro 664 # we also access %hdr, as $_[1] might be an erro
648 http_request ( 665 http_request (
649 $method => $hdr{location}, 666 $method => $hdr{location},
650 %arg, 667 %arg,
651 recurse => $recurse - 1, 668 recurse => $recurse - 1,
652 Redirect => \@_, 669 Redirect => \@_,
653 $cb); 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);
654 } else { 687 } else {
655 $cb->($_[0], $_[1]);
656 }
657 };
658
659 my $len = $hdr{"content-length"};
660
661 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
662 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
663 } elsif (
664 $hdr{Status} =~ /^(?:1..|[23]04)$/
665 or $method eq "HEAD"
666 or (defined $len && !$len)
667 ) {
668 # no body
669 $finish->("", \%hdr);
670 } else {
671 # body handling, four different code paths 688 # body handling, four different code paths
672 # for want_body_handle, on_body (2x), normal (2x) 689 # for want_body_handle, on_body (2x), normal (2x)
673 # we might read too much here, but it does not matter yet (no pers. connections) 690 # we might read too much here, but it does not matter yet (no pers. connections)
674 if (!$redirect && $arg{want_body_handle}) { 691 if (!$redirect && $arg{want_body_handle}) {
675 $_[0]->on_eof (undef); 692 $_[0]->on_eof (undef);
676 $_[0]->on_error (undef); 693 $_[0]->on_error (undef);
677 $_[0]->on_read (undef); 694 $_[0]->on_read (undef);
678 695
679 $finish->(delete $state{handle}, \%hdr); 696 $finish->(delete $state{handle}, \%hdr);
680 697
681 } elsif ($arg{on_body}) { 698 } elsif ($arg{on_body}) {
682 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 699 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
683 if ($len) { 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 {
684 $_[0]->on_eof (undef); 721 $_[0]->on_eof (undef);
685 $_[0]->on_read (sub {
686 $len -= length $_[0]{rbuf};
687 722
688 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
689 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
690
691 $len > 0
692 or $finish->("", \%hdr);
693 });
694 } else {
695 $_[0]->on_eof (sub {
696 $finish->("", \%hdr);
697 });
698 $_[0]->on_read (sub {
699 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
700 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
701 });
702 }
703 } else {
704 $_[0]->on_eof (undef);
705
706 if ($len) { 723 if ($len) {
707 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 724 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
708 $_[0]->on_read (sub { 725 $_[0]->on_read (sub {
709 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 726 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
710 if $len <= length $_[0]{rbuf}; 727 if $len <= length $_[0]{rbuf};
711 }); 728 });
712 } else { 729 } else {
713 $_[0]->on_error (sub { 730 $_[0]->on_error (sub {
714 ($! == Errno::EPIPE || !$!) 731 ($! == Errno::EPIPE || !$!)
715 ? $finish->(delete $_[0]{rbuf}, \%hdr) 732 ? $finish->(delete $_[0]{rbuf}, \%hdr)
716 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 733 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
717 }); 734 });
718 $_[0]->on_read (sub { }); 735 $_[0]->on_read (sub { });
736 }
719 } 737 }
720 } 738 }
721 } 739 });
722 }); 740 };
723 };
724 741
725 # now handle proxy-CONNECT method 742 # now handle proxy-CONNECT method
726 if ($proxy && $uscheme eq "https") { 743 if ($proxy && $uscheme eq "https") {
727 # oh dear, we have to wrap it into a connect request 744 # oh dear, we have to wrap it into a connect request
728 745
729 # maybe re-use $uauthority with patched port? 746 # maybe re-use $uauthority with patched port?
730 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 747 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
731 $state{handle}->push_read (line => $qr_nlnl, sub { 748 $state{handle}->push_read (line => $qr_nlnl, sub {
732 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 749 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
733 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 750 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
734 751
735 if ($2 == 200) { 752 if ($2 == 200) {
736 $rpath = $upath; 753 $rpath = $upath;
737 &$handle_actual_request; 754 &$handle_actual_request;
738 } else { 755 } else {
739 %state = (); 756 %state = ();
740 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 757 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
758 }
741 } 759 });
742 });
743 } else { 760 } else {
744 &$handle_actual_request; 761 &$handle_actual_request;
762 }
763
745 } 764 },
746
747 }, $arg{on_prepare} || sub { $timeout }; 765 $arg{on_prepare} || sub { $timeout }
766 );
748 }; 767 };
749 768
750 defined wantarray && AnyEvent::Util::guard { %state = () } 769 defined wantarray && AnyEvent::Util::guard { %state = () }
751} 770}
752 771
… …
830# initialise proxy from environment 849# initialise proxy from environment
831eval { 850eval {
832 set_proxy $ENV{http_proxy}; 851 set_proxy $ENV{http_proxy};
833}; 852};
834 853
854=head2 SOCKS PROXIES
855
856Socks proxies are not directly supported by AnyEvent::HTTP. You can
857compile your perl to support socks, or use an external program such as
858F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
859transparently.
860
861Alternatively, for AnyEvent::HTTP only, you can use your own
862C<tcp_connect> function that does the proxy handshake - here is an example
863that works with socks4a proxies:
864
865 use Errno;
866 use AnyEvent::Util;
867 use AnyEvent::Socket;
868 use AnyEvent::Handle;
869
870 # host, port and username of/for your socks4a proxy
871 my $socks_host = "10.0.0.23";
872 my $socks_port = 9050;
873 my $socks_user = "";
874
875 sub socks4a_connect {
876 my ($host, $port, $connect_cb, $prepare_cb) = @_;
877
878 my $hdl = new AnyEvent::Handle
879 connect => [$socks_host, $socks_port],
880 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
881 on_error => sub { $connect_cb->() },
882 ;
883
884 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
885
886 $hdl->push_read (chunk => 8, sub {
887 my ($hdl, $chunk) = @_;
888 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
889
890 if ($status == 0x5a) {
891 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
892 } else {
893 $! = Errno::ENXIO; $connect_cb->();
894 }
895 });
896
897 $hdl
898 }
899
900Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
901possibly after switching off other proxy types:
902
903 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
904
905 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
906 my ($data, $headers) = @_;
907 ...
908 };
909
835=head1 SEE ALSO 910=head1 SEE ALSO
836 911
837L<AnyEvent>. 912L<AnyEvent>.
838 913
839=head1 AUTHOR 914=head1 AUTHOR

Diff Legend

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