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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.45 by root, Fri Jul 17 16:56:36 2009 UTC vs.
Revision 1.55 by root, Wed Jun 16 19:17:30 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.4';
+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,
 =item headers => hashref
 The request headers to use. Currently, C<http_request> may provide its
 own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
-and will provide defaults for C<User-Agent:> and C<Referer:>.
+and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
+suppressed by using C<undef> for these headers in which case they won't 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. 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.
-C<$scheme> must be either missing or C<http> for HTTP, or C<https> for
+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
 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
    push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
    _slot_schedule $_[0];
 }
-our $qr_nl   = qr<\015?\012>;
+our $qr_nl   = qr{\015?\012};
-our $qr_nlnl = qr<\015?\012\015?\012>;
+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" };
 sub http_request($$@) {
       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;
    $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 =~ s%^/?%/%;
    my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
    if ($proxy) {
       ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
+      $rscheme = "http" unless defined $rscheme;
       # don't support https requests over https-proxy transport,
       # can't be done with tls as spec'ed, unless you double-encrypt.
       $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
    } else {
       ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
    }
-   $hdr{"user-agent"} ||= $USERAGENT;
+   # leave out fragment and query string, just a heuristic
-   $hdr{referer}      ||= "$uscheme://$uauthority$upath"; # 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};
          }
          # (re-)configure handle
          $state{handle}->on_error (sub {
             %state = ();
-            $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
+            $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
          });
          $state{handle}->on_eof (sub {
             %state = ();
-            $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
+            $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
          });
          $state{handle}->starttls ("connect") if $rscheme eq "https";
          # handle actual, non-tunneled, request
             $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"
-               . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
+               . (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]\012") {
+                  for ("$_[1]") {
                      y/\015//d; # weed out any \015, as they show up in the weirdest of places.
                      # things seen, not parsed:
                      # p3pP="NON CUR OTPi OUR NOR UNI"
                               ((?: [^\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 {
                            redo if /\G\s*,/gc;
                         }
                      }
-                     if ($redirect) {
+                     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;
          }
-      }, sub {
+      }, $arg{on_prepare} || sub { $timeout };
-         $timeout
-      };
    };
    defined wantarray && AnyEvent::Util::guard { %state = () }
 }
    &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>).
 The default value for the C<User-Agent> header (the default is
 C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
 =item $AnyEvent::HTTP::MAX_PER_HOST
-The maximum number of concurrent conenctions to the same host (identified
+The maximum number of concurrent connections to the same host (identified
 by the hostname). If the limit is exceeded, then the additional requests
 are queued until previous connections are closed.
 The default value for this is C<4>, and it is highly advisable to not
 increase it.
 =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.45 by root, Fri Jul 17 16:56:36 2009 UTC vs. Revision 1.55 by root, Wed Jun 16 19:17:30 2010 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.45 by root, Fri Jul 17 16:56:36 2009 UTC vs.
Revision 1.55 by root, Wed Jun 16 19:17:30 2010 UTC