[ViewVC] Diff of: cvs/AnyEvent-HTTP/HTTP.pm

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.58 by root, Sun Nov 14 20:23:00 2010 UTC vs.
Revision 1.68 by root, Fri Dec 31 19:22:18 2010 UTC

 use Errno ();
 use AnyEvent 5.0 ();
 use AnyEvent::Util ();
-use AnyEvent::Socket ();
 use AnyEvent::Handle ();
 use base Exporter::;
-our $VERSION = '1.46';
+our $VERSION = '1.5';
 our @EXPORT = qw(http_get http_post http_head http_request);
 our $USERAGENT          = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
 our $MAX_RECURSE        =  10;
 C<http_request> returns a "cancellation guard" - you have to keep the
 object at least alive until the callback get called. If the object gets
 destroyed before the callback is called, the request will be cancelled.
 The callback will be called with the response body data as first argument
-(or C<undef> if an error occured), and a hash-ref with response headers as
+(or C<undef> if an error occured), and a hash-ref with response headers
-second argument.
+(and trailers) as second argument.
 All the headers in that hash are lowercased. In addition to the response
 headers, the "pseudo-headers" (uppercase to avoid clashing with possible
 response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
-three parts of the HTTP Status-Line of the same name.
+three parts of the HTTP Status-Line of the same name. If an error occurs
+during the body phase of a request, then the original C<Status> and
+C<Reason> values from the header are available as C<OrigStatus> and
+C<OrigReason>.
 The pseudo-header C<URL> contains the actual URL (which can differ from
 the requested URL when following redirects - for example, you might get
 an error that your URL scheme is not supported even though your URL is a
 valid http URL because it redirected to an ftp URL, in which case you can
 Whether to recurse requests or not, e.g. on redirects, authentication
 retries and so on, and how often to do so.
 =item headers => hashref
-The request headers to use. Currently, C<http_request> may provide its
+The request headers to use. Currently, C<http_request> may provide its own
-own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
+C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
-and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
+will provide defaults for C<TE:>, C<Referer:> and C<User-Agent:> (this can
-suppressed by using C<undef> for these headers in which case they won't be
+be suppressed by using C<undef> for these headers in which case they won't
-sent at all).
+be sent at all).
 =item timeout => $seconds
 The time-out to use for various stages - each connect attempt will reset
 the timeout, as will read or write activity, i.e. this is not an overall
 C<$scheme> must be either missing, C<http> for HTTP or C<https> for
 HTTPS.
 =item body => $string
-The request body, usually empty. Will be-sent as-is (future versions of
+The request body, usually empty. Will be sent as-is (future versions of
 this module might offer more options).
 =item cookie_jar => $hash_ref
 Passing this parameter enables (simplified) cookie-processing, loosely
 overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
 and behaves exactly the same way (e.g. it has to provide a
 timeout). See the description for the C<$prepare_cb> argument of
 C<AnyEvent::Socket::tcp_connect> for details.
+=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
+In even rarer cases you want total control over how AnyEvent::HTTP
+establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
+to do this, but you can provide your own C<tcp_connect> function -
+obviously, it has to follow the same calling conventions, except that it
+may always return a connection guard object.
+There are probably lots of weird uses for this function, starting from
+tracing the hosts C<http_request> actually tries to connect, to (inexact
+but fast) host => IP address caching or even socks protocol support.
 =item on_header => $callback->($headers)
 When specified, this callback will be called with the header hash as soon
 as headers have been successfully received from the remote server (not on
 locally-generated errors).
 This callback is useful, among other things, to quickly reject unwanted
 content, which, if it is supposed to be rare, can be faster than first
 doing a C<HEAD> request.
+The downside is that cancelling the request makes it impossible to re-use
+the connection. Also, the C<on_header> callback will not receive any
+trailer (headers sent after the response body).
 Example: cancel the request unless the content-type is "text/html".
    on_header => sub {
       $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
    },
 string instead of the body data.
 It has to return either true (in which case AnyEvent::HTTP will continue),
 or false, in which case AnyEvent::HTTP will cancel the download (and call
 the completion callback with an error code of C<598>).
+The downside to cancelling the request is that it makes it impossible to
+re-use the connection.
 This callback is useful when the data is too large to be held in memory
 (so the callback writes it to a file) or when only some information should
 be extracted, or when the body should be processed incrementally.
 If you think you need this, first have a look at C<on_body>, to see if
 that doesn't solve your problem in a better way.
 =back
-Example: make a simple HTTP GET request for http://www.nethype.de/
+Example: do a simple HTTP GET request for http://www.nethype.de/ and print
+the response body.
    http_request GET => "http://www.nethype.de/", sub {
       my ($body, $hdr) = @_;
       print "$body\n";
    };
-Example: make a HTTP HEAD request on https://www.google.com/, use a
+Example: do a HTTP HEAD request on https://www.google.com/, use a
 timeout of 30 seconds.
    http_request
       GET     => "https://www.google.com",
       timeout => 30,
          use Data::Dumper;
          print Dumper $hdr;
       }
    ;
-Example: make another simple HTTP GET request, but immediately try to
+Example: do another simple HTTP GET request, but immediately try to
 cancel it.
    my $request = http_request GET => "http://www.nethype.de/", sub {
       my ($body, $hdr) = @_;
       print "$body\n";
    push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
    _slot_schedule $_[0];
 }
+# continue to parse $_ for headers and place them into the arg
+sub parse_hdr() {
+   my %hdr;
+   # things seen, not parsed:
+   # p3pP="NON CUR OTPi OUR NOR UNI"
+   $hdr{lc $1} .= ",$2"
+      while /\G
+            ([^:\000-\037]*):
+            [\011\040]*
+            ((?: [^\012]+ | \012[\011\040] )*)
+            \012
+         /gxc;
+   /\G$/
+     or return;
+   # remove the "," prefix we added to all headers above
+   substr $_, 0, 1, ""
+      for values %hdr;
+   \%hdr
+}
 our $qr_nlnl = qr{(?<![^\012])\015?\012};
 our $TLS_CTX_LOW  = { cache => 1, sslv2 => 1 };
 our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
    my @pseudo = (URL => $url);
    push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
    my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
-   return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
+   return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
       if $recurse < 0;
    my $proxy   = $arg{proxy}   || $PROXY;
    my $timeout = $arg{timeout} || $TIMEOUT;
    $uscheme = lc $uscheme;
    my $uport = $uscheme eq "http"  ?  80
              : $uscheme eq "https" ? 443
-             : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
+             : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
    $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
-      or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
+      or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
    my $uhost = $1;
    $uport = $2 if defined $2;
    $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
    } else {
       ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
    }
    # leave out fragment and query string, just a heuristic
-   $hdr{referer}      ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
+   $hdr{referer}      = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
-   $hdr{"user-agent"} ||= $USERAGENT                     unless exists $hdr{"user-agent"};
+   $hdr{"user-agent"} = $USERAGENT                     unless exists $hdr{"user-agent"};
    $hdr{"content-length"} = length $arg{body}
       if length $arg{body} || $method ne "GET";
+   $hdr{connection} = "close TE"; #1.1
+   $hdr{te}         = "trailers" unless exists $hdr{te}; #1.1
    my %state = (connect_guard => 1);
    _get_slot $uhost, sub {
       $state{slot_guard} = shift;
       return unless $state{connect_guard};
-      $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
+      my $connect_cb = sub {
          $state{fh} = shift
             or do {
                my $err = "$!";
                %state = ();
-               return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
+               return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
             };
          pop; # free memory, save a tree
          return unless delete $state{connect_guard};
             tls_ctx  => $arg{tls_ctx},
             # these need to be reconfigured on keepalive handles
             timeout  => $timeout,
             on_error => sub {
                %state = ();
-               $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
+               $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
             },
             on_eof   => sub {
                %state = ();
-               $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
+               $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
             },
          ;
          # limit the number of persistent connections
          # keepalive not yet supported
 #            ++$KA_COUNT{$_[1]};
 #            $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
 #               --$KA_COUNT{$_[1]}
 #            };
 #            $hdr{connection} = "keep-alive";
-#         } else {
-            delete $hdr{connection};
 #         }
          $state{handle}->starttls ("connect") if $rscheme eq "https";
          # handle actual, non-tunneled, request
          my $handle_actual_request = sub {
             $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
             # send request
             $state{handle}->push_write (
-               "$method $rpath HTTP/1.0\015\012"
+               "$method $rpath HTTP/1.1\015\012"
                . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
                . "\015\012"
                . (delete $arg{body})
             );
             return unless %state;
             %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
             # status line and headers
-            $state{handle}->push_read (line => $qr_nlnl, sub {
+            $state{read_response} = sub {
                for ("$_[1]") {
                   y/\015//d; # weed out any \015, as they show up in the weirdest of places.
-                  /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
+                  /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
-                     or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
+                     or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
+                  # 100 Continue handling
+                  # should not happen as we don't send expect: 100-continue,
+                  # but we handle it just in case.
+                  # since we send the request body regardless, if we get an error
+                  # we are out of-sync, which we currently do NOT handle correctly.
+                  return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
+                     if $2 eq 100;
                   push @pseudo,
                      HTTPVersion => $1,
                      Status      => $2,
                      Reason      => $3,
                   ;
-                  # things seen, not parsed:
+                  my $hdr = parse_hdr
-                  # p3pP="NON CUR OTPi OUR NOR UNI"
-                  $hdr{lc $1} .= ",$2"
-                     while /\G
-                           ([^:\000-\037]*):
-                           [\011\040]*
-                           ((?: [^\012]+ | \012[\011\040] )*)
-                           \012
-                        /gxc;
-                  /\G$/
-                    or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
+                     or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
+                  %hdr = (%$hdr, @pseudo);
                }
-               # remove the "," prefix we added to all headers above
-               substr $_, 0, 1, ""
-                  for values %hdr;
-               # patch in all pseudo headers
-               %hdr = (%hdr, @pseudo);
                # redirect handling
                # microsoft and other shitheads don't give a shit for following standards,
                # try to support some common forms of broken Location headers.
                if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
                   } elsif ($status == 307) {
                      $redirect = 1;
                   }
                }
-               my $finish = sub {
+               my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
+                  my $keepalive = pop;
                   $state{handle}->destroy if $state{handle};
                   %state = ();
+                  if (defined $_[1]) {
+                     $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
+                     $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
+                  }
                   # set-cookie processing
                   if ($arg{cookie_jar}) {
-                     for ($_[1]{"set-cookie"}) {
+                     for ($hdr{"set-cookie"}) {
                         # parse NAME=VALUE
                         my @kv;
                         while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
                            my $name = $1;
                      # we also access %hdr, as $_[1] might be an erro
                      http_request (
                         $method  => $hdr{location},
                         %arg,
                         recurse  => $recurse - 1,
-                        Redirect => \@_,
+                        Redirect => [$_[0], \%hdr],
                         $cb);
                   } else {
-                     $cb->($_[0], $_[1]);
+                     $cb->($_[0], \%hdr);
                   }
                };
                my $len = $hdr{"content-length"};
                if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
-                  $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
+                  $finish->(undef, 598 => "Request cancelled by on_header");
                } elsif (
-                  $hdr{Status} =~ /^(?:1..|[23]04)$/
+                  $hdr{Status} =~ /^(?:1..|204|205|304)$/
                   or $method eq "HEAD"
                   or (defined $len && !$len)
                ) {
                   # no body
-                  $finish->("", \%hdr);
+                  $finish->("", undef, undef, 1);
                } else {
-                  # body handling, four different code paths
+                  # body handling, many different code paths
-                  # for want_body_handle, on_body (2x), normal (2x)
+                  # - no body expected
-                  # we might read too much here, but it does not matter yet (no pers. connections)
+                  # - want_body_handle
+                  # - te chunked
+                  # - 2x length known (with or without on_body)
+                  # - 2x length not known (with or without on_body)
                   if (!$redirect && $arg{want_body_handle}) {
                      $_[0]->on_eof   (undef);
                      $_[0]->on_error (undef);
                      $_[0]->on_read  (undef);
-                     $finish->(delete $state{handle}, \%hdr);
+                     $finish->(delete $state{handle});
+                  } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
+                     my $cl = 0;
+                     my $body = undef;
+                     my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
+                     $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
+                     my $read_chunk; $read_chunk = sub {
+                        $_[1] =~ /^([0-9a-fA-F]+)/
+                           or $finish->(undef, 599 => "Garbled chunked transfer encoding");
+                        my $len = hex $1;
+                        if ($len) {
+                           $cl += $len;
+                           $_[0]->push_read (chunk => $len, sub {
+                              $on_body->($_[1], \%hdr)
+                                 or return $finish->(undef, 598 => "Request cancelled by on_body");
+                              $_[0]->push_read (line => sub {
+                                 length $_[1]
+                                    and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
+                                 $_[0]->push_read (line => $read_chunk);
+                              });
+                           });
+                        } else {
+                           $hdr{"content-length"} ||= $cl;
+                           $_[0]->push_read (line => $qr_nlnl, sub {
+                              if (length $_[1]) {
+                                 for ("$_[1]") {
+                                    y/\015//d; # weed out any \015, as they show up in the weirdest of places.
+                                    my $hdr = parse_hdr
+                                       or return $finish->(undef, 599 => "Garbled response trailers");
+                                    %hdr = (%hdr, %$hdr);
+                                 }
+                              }
+                              $finish->($body, undef, undef, 1);
+                           });
+                        }
+                     };
+                     $_[0]->push_read (line => $read_chunk);
                   } elsif ($arg{on_body}) {
-                     $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
+                     $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
                      if ($len) {
-                        $_[0]->on_eof (undef);
                         $_[0]->on_read (sub {
                            $len -= length $_[0]{rbuf};
                            $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
-                              or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
+                              or return $finish->(undef, 598 => "Request cancelled by on_body");
                            $len > 0
-                              or $finish->("", \%hdr);
+                              or $finish->("", undef, undef, 1);
                         });
                      } else {
                         $_[0]->on_eof (sub {
-                           $finish->("", \%hdr);
+                           $finish->("");
                         });
                         $_[0]->on_read (sub {
                            $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
-                              or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
+                              or $finish->(undef, 598 => "Request cancelled by on_body");
                         });
                      }
                   } else {
                      $_[0]->on_eof (undef);
                      if ($len) {
-                        $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
+                        $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
                         $_[0]->on_read (sub {
-                           $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
+                           $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
                               if $len <= length $_[0]{rbuf};
                         });
                      } else {
                         $_[0]->on_error (sub {
                            ($! == Errno::EPIPE || !$!)
-                              ? $finish->(delete $_[0]{rbuf}, \%hdr)
+                              ? $finish->(delete $_[0]{rbuf})
-                              : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
+                              : $finish->(undef, 599 => $_[2]);
                         });
                         $_[0]->on_read (sub { });
                      }
                   }
                }
-            });
+            };
+            $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
          };
          # now handle proxy-CONNECT method
          if ($proxy && $uscheme eq "https") {
             # oh dear, we have to wrap it into a connect request
             # maybe re-use $uauthority with patched port?
             $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
             $state{handle}->push_read (line => $qr_nlnl, sub {
                $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
-                  or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
+                  or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
                if ($2 == 200) {
                   $rpath = $upath;
                   &$handle_actual_request;
                } else {
                   %state = ();
-                  $cb->(undef, { Status => $2, Reason => $3, @pseudo });
+                  $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
                }
             });
          } else {
             &$handle_actual_request;
          }
+      };
-      }, $arg{on_prepare} || sub { $timeout };
+      my $tcp_connect = $arg{tcp_connect}
+                        || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
+      $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
    };
    defined wantarray && AnyEvent::Util::guard { %state = () }
 }
 string of the form C<http://host:port> (optionally C<https:...>), croaks
 otherwise.
 To clear an already-set proxy, use C<undef>.
+=item $date = AnyEvent::HTTP::format_date $timestamp
+Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
+Date (RFC 2616).
+=item $timestamp = AnyEvent::HTTP::parse_date $date
+Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
+timestamp, or C<undef> if the date cannot be parsed.
 =item $AnyEvent::HTTP::MAX_RECURSE
 The default value for the C<recurse> request parameter (default: C<10>).
 =item $AnyEvent::HTTP::USERAGENT
 connections. This number of can be useful for load-leveling.
 =back
 =cut
+our @month   = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
+sub format_date($) {
+   my ($time) = @_;
+   # RFC 822/1123 format
+   my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
+   sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
+      $weekday[$wday], $mday, $month[$mon], $year + 1900,
+      $H, $M, $S;
+}
+sub parse_date($) {
+   my ($date) = @_;
+   my ($d, $m, $y, $H, $M, $S);
+   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$/) {
+      # RFC 822/1123, required by RFC 2616
+      ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
+   } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
+      # RFC 850
+      ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
+   } 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])$/) {
+      # ISO C's asctime
+      ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
+   }
+   # other formats fail in the loop below
+   for (0..11) {
+      if ($m eq $month[$_]) {
+         require Time::Local;
+         return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
+      }
+   }
+   undef
+}
 sub set_proxy($) {
    if (length $_[0]) {
       $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
          or Carp::croak "$_[0]: invalid proxy URL";
 # initialise proxy from environment
 eval {
    set_proxy $ENV{http_proxy};
 };
+=head2 SOCKS PROXIES
+Socks proxies are not directly supported by AnyEvent::HTTP. You can
+compile your perl to support socks, or use an external program such as
+F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
+transparently.
+Alternatively, for AnyEvent::HTTP only, you can use your own
+C<tcp_connect> function that does the proxy handshake - here is an example
+that works with socks4a proxies:
+   use Errno;
+   use AnyEvent::Util;
+   use AnyEvent::Socket;
+   use AnyEvent::Handle;
+   # host, port and username of/for your socks4a proxy
+   my $socks_host = "10.0.0.23";
+   my $socks_port = 9050;
+   my $socks_user = "";
+   sub socks4a_connect {
+      my ($host, $port, $connect_cb, $prepare_cb) = @_;
+      my $hdl = new AnyEvent::Handle
+         connect    => [$socks_host, $socks_port],
+         on_prepare => sub { $prepare_cb->($_[0]{fh}) },
+         on_error   => sub { $connect_cb->() },
+      ;
+      $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
+      $hdl->push_read (chunk => 8, sub {
+         my ($hdl, $chunk) = @_;
+         my ($status, $port, $ipn) = unpack "xCna4", $chunk;
+         if ($status == 0x5a) {
+            $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
+         } else {
+            $! = Errno::ENXIO; $connect_cb->();
+         }
+      });
+      $hdl
+   }
+Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
+possibly after switching off other proxy types:
+   AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
+   http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
+      my ($data, $headers) = @_;
+      ...
+   };
 =head1 SEE ALSO
 L<AnyEvent>.
 =head1 AUTHOR

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.58 by root, Sun Nov 14 20:23:00 2010 UTC vs. Revision 1.68 by root, Fri Dec 31 19:22:18 2010 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.58 by root, Sun Nov 14 20:23:00 2010 UTC vs.
Revision 1.68 by root, Fri Dec 31 19:22:18 2010 UTC