--- AnyEvent-HTTP/HTTP.pm 2010/11/14 20:23:00 1.58 +++ AnyEvent-HTTP/HTTP.pm 2010/12/31 22:40:54 1.74 @@ -45,12 +45,11 @@ 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); @@ -97,13 +96,16 @@ 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 if an error occured), and a hash-ref with response headers as -second argument. +(or C if an error occured), and a hash-ref with response headers +(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, C and C 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 and +C values from the header are available as C and +C. The pseudo-header C contains the actual URL (which can differ from the requested URL when following redirects - for example, you might get @@ -150,11 +152,11 @@ =item headers => hashref -The request headers to use. Currently, C may provide its -own C, C, C and C headers -and will provide defaults for C and C (this can be -suppressed by using C for these headers in which case they won't be -sent at all). +The request headers to use. Currently, C may provide its own +C, C, C and C headers and +will provide defaults at least for C, C and C +(this can be suppressed by using C for these headers in which case +they won't be sent at all). =item timeout => $seconds @@ -174,7 +176,7 @@ =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 @@ -183,15 +185,19 @@ based on the original netscape specification. The C<$hash_ref> must be an (initially empty) hash reference which will -get updated automatically. It is possible to save the cookie_jar to +get updated automatically. It is possible to save the cookie jar to persistent storage with something like JSON or Storable, but this is not -recommended, as expiry times are currently being ignored. +recommended, as session-only cookies might survive longer than expected. -Note that this cookie implementation is not of very high quality, nor -meant to be complete. If you want complete cookie management you have to -do that on your own. C is meant as a quick fix to get some -cookie-using sites working. Cookies are a privacy disaster, do not use -them unless required to. +Note that this cookie implementation is not meant to be complete. If +you want complete cookie management you have to do that on your +own. C is meant as a quick fix to get some cookie-using sites +working. Cookies are a privacy disaster, do not use them unless required +to. + +When cookie processing is enabled, the C and C +headers will be set and handled by this module, otherwise they will be +left untouched. =item tls_ctx => $scheme | $tls_ctx @@ -214,6 +220,18 @@ timeout). See the description for the C<$prepare_cb> argument of C 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 +to do this, but you can provide your own C 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 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 @@ -228,6 +246,10 @@ content, which, if it is supposed to be rare, can be faster than first doing a C request. +The downside is that cancelling the request makes it impossible to re-use +the connection. Also, the C 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 { @@ -244,6 +266,9 @@ 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. @@ -278,14 +303,15 @@ =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 @@ -298,7 +324,7 @@ } ; -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 { @@ -340,6 +366,146 @@ _slot_schedule $_[0]; } +# extract cookies from jar +sub cookie_jar_extract($$$$) { + my ($jar, $uscheme, $uhost, $upath) = @_; + + %$jar = () if $jar->{version} != 1; + + my @cookies; + + while (my ($chost, $paths) = each %$jar) { + next unless ref $paths; + + if ($chost =~ /^\./) { + next unless $chost eq substr $uhost, -length $chost; + } elsif ($chost =~ /\./) { + next unless $chost eq $uhost; + } else { + next; + } + + while (my ($cpath, $cookies) = each %$paths) { + next unless $cpath eq substr $upath, 0, length $cpath; + + while (my ($cookie, $kv) = each %$cookies) { + next if $uscheme ne "https" && exists $kv->{secure}; + + if (exists $kv->{expires}) { + if (AE::now > parse_date ($kv->{expires})) { + delete $cookies->{$cookie}; + next; + } + } + + my $value = $kv->{value}; + + if ($value =~ /[=;,[:space:]]/) { + $value =~ s/([\\"])/\\$1/g; + $value = "\"$value\""; + } + + push @cookies, "$cookie=$value"; + } + } + } + + \@cookies +} + +# parse set_cookie header into jar +sub cookie_jar_set_cookie($$$) { + my ($jar, $set_cookie, $uhost) = @_; + + for ($set_cookie) { + # parse NAME=VALUE + my @kv; + + while ( + m{ + \G\s* + (?: + expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+) + | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) + ) + }gcxsi + ) { + my $name = $2; + my $value = $4; + + unless (defined $name) { + # expires + $name = "expires"; + $value = $1; + } elsif (!defined $value) { + # quoted + $value = $3; + $value =~ s/\\(.)/$1/gs; + } + + push @kv, lc $name, $value; + + last unless /\G\s*;/gc; + } + + last unless @kv; + + my $name = shift @kv; + my %kv = (value => shift @kv, @kv); + + $kv{expires} ||= format_date (AE::now + $kv{"max-age"}) + if exists $kv{"max-age"}; + + my $cdom; + my $cpath = (delete $kv{path}) || "/"; + + if (exists $kv{domain}) { + $cdom = delete $kv{domain}; + + $cdom =~ s/^\.?/./; # make sure it starts with a "." + + next if $cdom =~ /\.$/; + + # this is not rfc-like and not netscape-like. go figure. + my $ndots = $cdom =~ y/.//; + next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); + } else { + $cdom = $uhost; + } + + # store it + $jar->{version} = 1; + $jar->{$cdom}{$cpath}{$name} = \%kv; + + redo if /\G\s*,/gc; + } +} + +# 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{(? 1, sslv2 => 1 }; @@ -368,7 +534,7 @@ 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; @@ -381,10 +547,10 @@ 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; @@ -399,33 +565,10 @@ # cookie processing if (my $jar = $arg{cookie_jar}) { - %$jar = () if $jar->{version} != 1; - - my @cookie; - - while (my ($chost, $v) = each %$jar) { - if ($chost =~ /^\./) { - next unless $chost eq substr $uhost, -length $chost; - } elsif ($chost =~ /\./) { - next unless $chost eq $uhost; - } else { - next; - } - - while (my ($cpath, $v) = each %$v) { - next unless $cpath eq substr $upath, 0, length $cpath; - - while (my ($k, $v) = each %$v) { - next if $uscheme ne "https" && exists $v->{secure}; - my $value = $v->{value}; - $value =~ s/([\\"])/\\$1/g; - push @cookie, "$k=\"$value\""; - } - } - } - - $hdr{cookie} = join "; ", @cookie - if @cookie; + my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath; + + $hdr{cookie} = join "; ", @$cookies + if @$cookies; } my ($rhost, $rport, $rscheme, $rpath); # request host, port, path @@ -443,12 +586,15 @@ } # leave out fragment and query string, just a heuristic - $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; - $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; + $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer}; + $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 { @@ -456,12 +602,12 @@ 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 @@ -477,11 +623,11 @@ 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" }); }, ; @@ -493,8 +639,6 @@ # --$KA_COUNT{$_[1]} # }; # $hdr{connection} = "keep-alive"; -# } else { - delete $hdr{connection}; # } $state{handle}->starttls ("connect") if $rscheme eq "https"; @@ -505,7 +649,7 @@ # 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}) @@ -517,12 +661,20 @@ %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 - or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); + /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc + 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, @@ -530,28 +682,12 @@ Reason => $3, ; - # things seen, not parsed: - # p3pP="NON CUR OTPi OUR NOR UNI" + my $hdr = parse_hdr + or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" })); - $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 })); + %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. @@ -587,58 +723,20 @@ } } - my $finish = sub { + my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) + my $may_keep_alive = $_[3]; + $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"}) { - # parse NAME=VALUE - my @kv; - - while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { - my $name = $1; - my $value = $3; - - unless ($value) { - $value = $2; - $value =~ s/\\(.)/$1/gs; - } - - push @kv, $name => $value; - - last unless /\G\s*;/gc; - } - - last unless @kv; - - my $name = shift @kv; - my %kv = (value => shift @kv, @kv); - - my $cdom; - my $cpath = (delete $kv{path}) || "/"; - - if (exists $kv{domain}) { - $cdom = delete $kv{domain}; - - $cdom =~ s/^\.?/./; # make sure it starts with a "." - - next if $cdom =~ /\.$/; - - # this is not rfc-like and not netscape-like. go figure. - my $ndots = $cdom =~ y/.//; - next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); - } else { - $cdom = $uhost; - } - - # store it - $arg{cookie_jar}{version} = 1; - $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; - - redo if /\G\s*,/gc; - } + cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost; } if ($redirect && exists $hdr{location}) { @@ -649,77 +747,130 @@ $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 - # for want_body_handle, on_body (2x), normal (2x) - # we might read too much here, but it does not matter yet (no pers. connections) + # body handling, many different code paths + # - no body expected + # - 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->(undef, { Status => 599, Reason => $_[2], @pseudo }); + ? $finish->(delete $_[0]{rbuf}) + : $finish->(undef, 599 => $_[2]); }); $_[0]->on_read (sub { }); } } } - }); + }; + + $state{handle}->push_read (line => $qr_nlnl, $state{read_response}); }; # now handle proxy-CONNECT method @@ -730,21 +881,26 @@ $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; } + }; + + 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 }); - }, $arg{on_prepare} || sub { $timeout }; }; defined wantarray && AnyEvent::Util::guard { %state = () } @@ -789,6 +945,17 @@ To clear an already-set proxy, use C. +=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) or a Cookie date (netscape cookie spec) and +returns the corresponding POSIX timestamp, or C if the date cannot +be parsed. + =item $AnyEvent::HTTP::MAX_RECURSE The default value for the C request parameter (default: C<10>). @@ -817,6 +984,51 @@ =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 (with " ") + # cookie dates (with "-") + + ($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 @@ -832,6 +1044,62 @@ 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 (dante) or F to make your program use a socks proxy +transparently. + +Alternatively, for AnyEvent::HTTP only, you can use your own +C 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 instead of C when doing Cs, +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.