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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC vs.
Revision 1.30 by root, Thu Oct 23 02:46:20 2008 UTC

 AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client
 =head1 SYNOPSIS
    use AnyEvent::HTTP;
+   http_get "http://www.nethype.de/", sub { print $_[1] };
+   # ... do something else here
 =head1 DESCRIPTION
 This module is an L<AnyEvent> user, you need to make sure that you use and
 run a supported event loop.
 use AnyEvent::Socket ();
 use AnyEvent::Handle ();
 use base Exporter::;
-our $VERSION = '1.0';
+our $VERSION = '1.05';
-our @EXPORT = qw(http_get http_request);
+our @EXPORT = qw(http_get http_post http_head http_request);
 our $USERAGENT          = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
 our $MAX_RECURSE        =  10;
 our $MAX_PERSISTENT     =   8;
 our $PERSISTENT_TIMEOUT =   2;
 # changing these is evil
 our $MAX_PERSISTENT_PER_HOST = 2;
 our $MAX_PER_HOST       = 4;
 our $PROXY;
+our $ACTIVE = 0;
 my %KA_COUNT; # number of open keep-alive connections per host
 my %CO_SLOT;  # number of open connections, and wait queue, per host
 =item http_get $url, key => value..., $cb->($data, $headers)
 Executes an HTTP-GET request. See the http_request function for details on
-additional parameters.
+additional parameters and the return value.
 =item http_head $url, key => value..., $cb->($data, $headers)
-Executes an HTTP-HEAD request. See the http_request function for details on
+Executes an HTTP-HEAD request. See the http_request function for details
-additional parameters.
+on additional parameters and the return value.
 =item http_post $url, $body, key => value..., $cb->($data, $headers)
-Executes an HTTP-POST request with a request body of C<$bod>. See the
+Executes an HTTP-POST request with a request body of C<$body>. See the
-http_request function for details on additional parameters.
+http_request function for details on additional parameters and the return
+value.
 =item http_request $method => $url, key => value..., $cb->($data, $headers)
 Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
 must be an absolute http or https URL.
+When called in void context, nothing is returned. In other contexts,
+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 callbakc is called, the request will be cancelled.
 The callback will be called with the response data as first argument
 (or C<undef> if it wasn't available due to errors), 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 three "pseudo-headers" C<HTTPVersion>, C<Status> and
+headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
-C<Reason> contain the three parts of the HTTP Status-Line of the same
+contain the three parts of the HTTP Status-Line of the same name. The
+pseudo-header C<URL> contains the original URL (which can differ from the
+requested URL when following redirects).
-name. If the server sends a header multiple lines, then their contents
+If the server sends a header multiple lines, then their contents will be
-will be joined together with C<\x00>.
+joined together with C<\x00>.
 If an internal error occurs, such as not being able to resolve a hostname,
 then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
 and the C<Reason> pseudo-header will contain an error message.
 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.
+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:>.
 =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.
          use Data::Dumper;
          print Dumper $hdr;
       }
    ;
+Example: make 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";
+   };
+   undef $request;
 =cut
+sub _slot_schedule;
 sub _slot_schedule($) {
    my $host = shift;
    while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
       if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
-         # somebody wnats that slot
+         # somebody wants that slot
          ++$CO_SLOT{$host}[0];
+         ++$ACTIVE;
          $cb->(AnyEvent::Util::guard {
+            --$ACTIVE;
             --$CO_SLOT{$host}[0];
             _slot_schedule $host;
          });
       } else {
          # nobody wants the slot, maybe we can forget about it
          delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
-         warn "$host deleted" unless $CO_SLOT{$host}[0];#d#
          last;
       }
    }
 }
    push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
    _slot_schedule $_[0];
 }
-sub http_request($$$;@) {
+sub http_request($$@) {
    my $cb = pop;
    my ($method, $url, %arg) = @_;
    my %hdr;
       while (my ($k, $v) = each %$hdr) {
          $hdr{lc $k} = $v;
       }
    }
-   my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
+   my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
-   return $cb->(undef, { Status => 599, Reason => "recursion limit reached" })
+   return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url })
       if $recurse < 0;
    my $proxy   = $arg{proxy}   || $PROXY;
    my $timeout = $arg{timeout} || $TIMEOUT;
    $scheme = lc $scheme;
    my $uport = $scheme eq "http"  ?  80
              : $scheme eq "https" ? 443
-             : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" });
+             : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url });
+   $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
    $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
-      or return $cb->(undef, { Status => 599, Reason => "unparsable URL" });
+      or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url });
    my $uhost = $1;
    $uport = $2 if defined $2;
    $uhost =~ s/^\[(.*)\]$/$1/;
       %$jar = () if $jar->{version} < 1;
       my @cookie;
       while (my ($chost, $v) = each %$jar) {
+         if ($chost =~ /^\./) {
-         next unless $chost eq substr $uhost, -length $chost;
+            next unless $chost eq substr $uhost, -length $chost;
-         next unless $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) {
       return unless $state{connect_guard};
       $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
          $state{fh} = shift
-            or return $cb->(undef, { Status => 599, Reason => "$!" });
+            or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url });
          delete $state{connect_guard}; # reduce memory usage, save a tree
          # get handle
          $state{handle} = new AnyEvent::Handle
          }
          # (re-)configure handle
          $state{handle}->timeout ($timeout);
          $state{handle}->on_error (sub {
+            my $errno = "$!";
             %state = ();
-            $cb->(undef, { Status => 599, Reason => "$!" });
+            $cb->(undef, { Status => 599, Reason => $errno, URL => $url });
          });
          $state{handle}->on_eof (sub {
             %state = ();
-            $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
+            $cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
          });
          # send request
          $state{handle}->push_write (
             "$method $rpath HTTP/1.0\015\012"
          %hdr = (); # reduce memory usage, save a kitten
          # status line
          $state{handle}->push_read (line => qr/\015?\012/, sub {
-            $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
+            $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
-               or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
+               or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
             my %hdr = ( # response headers
                HTTPVersion => "\x00$1",
                Status      => "\x00$2",
                Reason      => "\x00$3",
+               URL         => "\x00$url"
             );
             # headers, could be optimized a bit
             $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
                for ("$_[1]\012") {
                   # we support spaces in field names, as lotus domino
-                  # creates them.
+                  # creates them (actually spaces around seperators
+                  # are strictly allowed in http, they are a security issue).
                   $hdr{lc $1} .= "\x00$2"
                      while /\G
                            ([^:\000-\037]+):
                            [\011\040]*
                            ((?: [^\015\012]+ | \015?\012[\011\040] )*)
                            \015?\012
                         /gxc;
                   /\G$/
-                    or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
+                    or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url }));
                }
                substr $_, 0, 1, ""
                   for values %hdr;
                my $finish = sub {
+                  # TODO: use destroy method, when/if available
+                  #$state{handle}->destroy;
+                  $state{handle}->on_eof   (undef);
+                  $state{handle}->on_error (undef);
                   %state = ();
                   # set-cookie processing
                   if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
                      for (split /\x00/, $hdr{"set-cookie"}) {
                         my ($cookie, @arg) = split /;\s*/;
                         my ($name, $value) = split /=/, $cookie, 2;
                         my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
-                        my $cdom  = (delete $kv{domain}) || $uhost;
+                        my $cdom;
                         my $cpath = (delete $kv{path})   || "/";
+                        if (exists $kv{domain}) {
+                           $cdom = delete $kv{domain};
-                        $cdom =~ s/^.?/./; # make sure it starts with a "."
+                           $cdom =~ s/^\.?/./; # make sure it starts with a "."
-                        next if $cdom =~ /\.$/;
+                           next if $cdom =~ /\.$/;
-                        # this is not rfc-like and not netscape-like. go figure.
+                           # this is not rfc-like and not netscape-like. go figure.
-                        my $ndots = $cdom =~ y/.//;
+                           my $ndots = $cdom =~ y/.//;
-                        next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
+                           next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
+                        } else {
+                           $cdom = $uhost;
+                        }
                         # store it
                         $arg{cookie_jar}{version} = 1;
                         $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
                      }
                   }
-                  if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
-                     # microsoft and other assholes don't give a shit for following standards,
+                  # microsoft and other shitheads don't give a shit for following standards,
-                     # try to support a common form of broken Location header.
+                  # try to support some common forms of broken Location headers.
+                  if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
+                     $_[1]{location} =~ s/^\.\/+//;
-                     $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
+                     my $url = "$scheme://$uhost:$uport";
+                     unless ($_[1]{location} =~ s/^\///) {
+                        $url .= $upath;
+                        $url =~ s/\/[^\/]*$//;
+                     }
+                     $_[1]{location} = "$url/$_[1]{location}";
+                  }
+                  if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
+                     # apparently, mozilla et al. just change POST to GET here
+                     # more research is needed before we do the same
                      http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
+                  } elsif ($_[1]{Status} == 303 && $recurse) {
+                     # even http/1.1 is unclear on how to mutate the method
+                     $method = "GET" unless $method eq "HEAD";
+                     http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
+                  } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
+                     http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
                   } else {
                      $cb->($_[0], $_[1]);
                   }
                };
    };
    defined wantarray && AnyEvent::Util::guard { %state = () }
 }
-sub http_get($$;@) {
+sub http_get($@) {
    unshift @_, "GET";
    &http_request
 }
-sub http_head($$;@) {
+sub http_head($@) {
    unshift @_, "HEAD";
    &http_request
 }
-sub http_post($$$;@) {
+sub http_post($$@) {
+   my $url = shift;
-   unshift @_, "POST", "body";
+   unshift @_, "POST", $url, "body";
    &http_request
 }
 =back
 The maximum time to cache a persistent connection, in seconds (default: 2).
 Not implemented currently.
+=item $AnyEvent::HTTP::ACTIVE
+The number of active connections. This is not the number of currently
+running requests, but the number of currently open and non-idle TCP
+connections. This number of can be useful for load-leveling.
 =back
 =cut
 sub set_proxy($) {
 L<AnyEvent>.
 =head1 AUTHOR
- Marc Lehmann <schmorp@schmorp.de>
+   Marc Lehmann <schmorp@schmorp.de>
- http://home.schmorp.de/
+   http://home.schmorp.de/
 =cut
 1

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC vs. Revision 1.30 by root, Thu Oct 23 02:46:20 2008 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC vs.
Revision 1.30 by root, Thu Oct 23 02:46:20 2008 UTC