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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.50 by root, Tue Aug 11 13:20:42 2009 UTC vs.
Revision 1.56 by root, Mon Sep 6 05:30:54 2010 UTC

 use strict;
 no warnings;
 use Errno ();
-use AnyEvent 4.8 ();
+use AnyEvent 5.0 ();
 use AnyEvent::Util ();
 use AnyEvent::Socket ();
 use AnyEvent::Handle ();
 use base Exporter::;
-our $VERSION = '1.42';
+our $VERSION = '1.45';
 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;
 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
 second argument.
 All the headers in that hash are lowercased. In addition to the response
-headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
+headers, the "pseudo-headers" (uppercase to avoid clashing with possible
+response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
-contain the three parts of the HTTP Status-Line of the same name. The
+three parts of the HTTP Status-Line of the same name.
-pseudo-header C<URL> contains the original URL (which can differ from the
+The pseudo-header C<URL> contains the actual URL (which can differ from
-requested URL when following redirects).
+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
+look at the URL pseudo header).
+The pseudo-header C<Redirect> only exists when the request was a result
+of an internal redirect. In that case it is an array reference with
+the C<($data, $headers)> from the redirect response. Note that this
+response could in turn be the result of a redirect itself, and C<<
+$headers->{Redirect}[1]{Redirect} >> will then contain the original
+response, and so on.
 If the server sends a header multiple times, then their contents will be
 joined together with a comma (C<,>), as per the HTTP spec.
 If an internal error occurs, such as not being able to resolve a hostname,
 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. Default timeout is 5 minutes.
+the timeout, as will read or write activity, i.e. this is not an overall
+timeout.
+Default timeout is 5 minutes.
 =item proxy => [$host, $port[, $scheme]] or undef
 Use the given http proxy for all requests. If not specified, then the
 default proxy (as specified by C<$ENV{http_proxy}>) is used.
 verification, highest compatibility) and high-security (CA and common-name
 verification) TLS context.
 The default for this option is C<low>, which could be interpreted as "give
 me the page, no matter what".
+=item on_prepare => $callback->($fh)
+In rare cases you need to "tune" the socket before it is used to
+connect (for exmaple, to bind it on a given IP address). This parameter
+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 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
       while (my ($k, $v) = each %$hdr) {
          $hdr{lc $k} = $v;
       }
    }
+   # pseudo headers for all subsequent responses
+   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", URL => $url })
+   return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
       if $recurse < 0;
    my $proxy   = $arg{proxy}   || $PROXY;
    my $timeout = $arg{timeout} || $TIMEOUT;
    my ($uscheme, $uauthority, $upath, $query, $fragment) =
-      $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
+      $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
    $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", URL => $url });
+             : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
    $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
-      or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
+      or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
    my $uhost = $1;
    $uport = $2 if defined $2;
-   $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost";
+   $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
+      unless exists $hdr{host};
    $uhost =~ s/^\[(.*)\]$/$1/;
-   $upath .= "?$query" if length $query;
+   $upath .= $query if length $query;
    $upath =~ s%^/?%/%;
    # cookie processing
    if (my $jar = $arg{cookie_jar}) {
    # 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{"content-length"} = length $arg{body};
+   $hdr{"content-length"} = length $arg{body}
+      if length $arg{body} || $method ne "GET";
    my %state = (connect_guard => 1);
    _get_slot $uhost, sub {
       $state{slot_guard} = shift;
       $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
          $state{fh} = shift
             or do {
                my $err = "$!";
                %state = ();
-               return $cb->(undef, { Status => 599, Reason => $err, URL => $url });
+               return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
             };
          pop; # free memory, save a tree
          return unless delete $state{connect_guard};
          # get handle
          $state{handle} = new AnyEvent::Handle
             fh       => $state{fh},
+            peername => $rhost,
+            tls_ctx  => $arg{tls_ctx},
+            # these need to be reconfigured on keepalive handles
             timeout  => $timeout,
-            peername => $rhost,
+            on_error => sub {
-            tls_ctx  => $arg{tls_ctx};
+               %state = ();
+               $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
+            },
+            on_eof   => sub {
+               %state = ();
+               $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
+            },
+         ;
          # limit the number of persistent connections
          # keepalive not yet supported
-         if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
+#         if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
-            ++$KA_COUNT{$_[1]};
+#            ++$KA_COUNT{$_[1]};
-            $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
+#            $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
-               --$KA_COUNT{$_[1]}
+#               --$KA_COUNT{$_[1]}
-            };
+#            };
-            $hdr{connection} = "keep-alive";
+#            $hdr{connection} = "keep-alive";
-         } else {
+#         } else {
             delete $hdr{connection};
-         }
+#         }
-         # (re-)configure handle
-         $state{handle}->on_error (sub {
-            %state = ();
-            $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
-         });
-         $state{handle}->on_eof (sub {
-            %state = ();
-            $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
-         });
          $state{handle}->starttls ("connect") if $rscheme eq "https";
          # handle actual, non-tunneled, request
          my $handle_actual_request = sub {
                . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
                . "\015\012"
                . (delete $arg{body})
             );
+            # return if error occured during push_write()
+            return unless %state;
-            %hdr = (); # reduce memory usage, save a kitten
+            %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
             # status line
             $state{handle}->push_read (line => $qr_nl, sub {
                $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
-                  or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
+                  or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", @pseudo }));
-               my %hdr = ( # response headers
+               push @pseudo,
-                  HTTPVersion => ",$1",
+                  HTTPVersion => $1,
-                  Status      => ",$2",
+                  Status      => $2,
-                  Reason      => ",$3",
+                  Reason      => $3,
-                  URL         => ",$url"
-               );
+               ;
                # headers, could be optimized a bit
                $state{handle}->unshift_read (line => $qr_nlnl, sub {
                   for ("$_[1]") {
                      y/\015//d; # weed out any \015, as they show up in the weirdest of places.
                               ((?: [^\012]+ | \012[\011\040] )*)
                               \012
                            /gxc;
                      /\G$/
-                       or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
+                       or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @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) {
                   }
                   my $redirect;
                   if ($recurse) {
+                     my $status = $hdr{Status};
-                     if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
+                     if (($status == 301 || $status == 302) && $method ne "POST") {
                         # apparently, mozilla et al. just change POST to GET here
                         # more research is needed before we do the same
                         $redirect = 1;
-                     } elsif ($hdr{Status} == 303) {
+                     } elsif ($status == 303) {
                         # even http/1.1 is unclear on how to mutate the method
                         $method = "GET" unless $method eq "HEAD";
                         $redirect = 1;
-                     } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) {
+                     } elsif ($status == 307 && $method =~ /^(?:GET|HEAD)$/) {
                         $redirect = 1;
                      }
                   }
                   my $finish = sub {
                      if ($redirect && exists $hdr{location}) {
                         # we ignore any errors, as it is very common to receive
                         # Content-Length != 0 but no actual body
                         # we also access %hdr, as $_[1] might be an erro
-                        http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb);
+                        http_request (
+                           $method  => $hdr{location},
+                           %arg,
+                           recurse  => $recurse - 1,
+                           Redirect => \@_,
+                           $cb);
                      } else {
                         $cb->($_[0], $_[1]);
                      }
                   };
                   my $len = $hdr{"content-length"};
                   if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
-                     $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
+                     $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
                   } elsif (
                      $hdr{Status} =~ /^(?:1..|[23]04)$/
                      or $method eq "HEAD"
                      or (defined $len && !$len)
                   ) {
                         $_[0]->on_read  (undef);
                         $finish->(delete $state{handle}, \%hdr);
                      } elsif ($arg{on_body}) {
-                        $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
+                        $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
                         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", URL => $url });
+                                 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
                               $len > 0
                                  or $finish->("", \%hdr);
                            });
                         } else {
                            $_[0]->on_eof (sub {
                               $finish->("", \%hdr);
                            });
                            $_[0]->on_read (sub {
                               $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
-                                 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
+                                 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
                            });
                         }
                      } else {
                         $_[0]->on_eof (undef);
                         if ($len) {
-                           $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
+                           $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
                            $_[0]->on_read (sub {
                               $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
                                  if $len <= length $_[0]{rbuf};
                            });
                         } else {
                            $_[0]->on_error (sub {
                               $! == Errno::EPIPE || !$!
                                  ? $finish->(delete $_[0]{rbuf}, \%hdr)
-                                 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
+                                 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
                            });
                            $_[0]->on_read (sub { });
                         }
                      }
                   }
             # 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])", URL => $url }));
+                  or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
                if ($2 == 200) {
                   $rpath = $upath;
                   &$handle_actual_request;
                } else {
                   %state = ();
-                  $cb->(undef, { Status => $2, Reason => $3, URL => $url });
+                  $cb->(undef, { Status => $2, Reason => $3, @pseudo });
                }
             });
          } else {
             &$handle_actual_request;
          }
    &http_request
 }
 =back
+=head2 DNS CACHING
+AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
+the actual connection, which in turn uses AnyEvent::DNS to resolve
+hostnames. The latter is a simple stub resolver and does no caching
+on its own. If you want DNS caching, you currently have to provide
+your own default resolver (by storing a suitable resolver object in
+C<$AnyEvent::DNS::RESOLVER>).
 =head2 GLOBAL FUNCTIONS AND VARIABLES
 =over 4
 =item AnyEvent::HTTP::set_proxy "proxy-url"
 Sets the default proxy server to use. The proxy-url must begin with a
-string of the form C<http://host:port> (optionally C<https:...>).
+string of the form C<http://host:port> (optionally C<https:...>), croaks
+otherwise.
+To clear an already-set proxy, use C<undef>.
 =item $AnyEvent::HTTP::MAX_RECURSE
 The default value for the C<recurse> request parameter (default: C<10>).
 =back
 =cut
 sub set_proxy($) {
+   if (length $_[0]) {
-   $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;
+      $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
+         or Carp::croak "$_[0]: invalid proxy URL";
+      $PROXY = [$2, $3 || 3128, $1]
+   } else {
+      undef $PROXY;
+   }
 }
 # initialise proxy from environment
+eval {
-set_proxy $ENV{http_proxy};
+   set_proxy $ENV{http_proxy};
+};
 =head1 SEE ALSO
 L<AnyEvent>.

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.50 by root, Tue Aug 11 13:20:42 2009 UTC vs. Revision 1.56 by root, Mon Sep 6 05:30:54 2010 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.50 by root, Tue Aug 11 13:20:42 2009 UTC vs.
Revision 1.56 by root, Mon Sep 6 05:30:54 2010 UTC