[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/DNS.pm

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.49 by root, Thu May 29 22:34:51 2008 UTC vs.
Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC

    die "encoding of resource records is not supported";
 }
 =item $pkt = AnyEvent::DNS::dns_pack $dns
-Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly
+Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
 recommended, then everything will be totally clear. Or maybe not.
 Resource records are not yet encodable.
 Examples:
          $self->parse_resolv_conf (<$fh>);
       }
    }
 }
+=item $resolver->timeout ($timeout, ...)
+Sets the timeout values. See the C<timeout> constructor argument (and note
+that this method uses the values itselt, not an array-reference).
+=cut
+sub timeout {
+   my ($self, @timeout) = @_;
+   $self->{timeout} = \@timeout;
+   $self->_compile;
+}
+=item $resolver->max_outstanding ($nrequests)
+Sets the maximum number of outstanding requests to C<$nrequests>. See the
+C<max_outstanding> constructor argument.
+=cut
+sub max_outstanding {
+   my ($self, $max) = @_;
+   $self->{max_outstanding} = $max;
+   $self->_scheduler;
+}
 sub _compile {
    my $self = shift;
    my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
    my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
          my ($res) = @_;
          if ($res->{tc}) {
             # success, but truncated, so use tcp
             AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
+               return unless $do_retry; # some other request could have invalidated us already
                my ($fh) = @_
                   or return &$do_retry;
-               my $handle = new AnyEvent::Handle
+               my $handle; $handle = new AnyEvent::Handle
                   fh       => $fh,
+                  timeout  => $timeout,
                   on_error => sub {
+                     undef $handle;
+                     return unless $do_retry; # some other request could have invalidated us already
                      # failure, try next
                      &$do_retry;
                   };
                $handle->push_write (pack "n/a", $req->[0]);
                $handle->push_read (chunk => 2, sub {
                   $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
+                     undef $handle;
                      $self->_feed ($_[1]);
                   });
                });
-               shutdown $fh, 1;
             }, sub { $timeout });
          } else {
             # success
 }
 sub _scheduler {
    my ($self) = @_;
+   no strict 'refs';
    $NOW = time;
    # first clear id reuse queue
    delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
       while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
             $self->_scheduler;
          });
          last;
       }
-      my $req = shift @{ $self->{queue} }
+      if (my $req = shift @{ $self->{queue} }) {
-         or last;
+         # found a request in the queue, execute it
-      while () {
+         while () {
-         $req->[2] = int rand 65536;
+            $req->[2] = int rand 65536;
-         last unless exists $self->{id}{$req->[2]};
+            last unless exists $self->{id}{$req->[2]};
+         }
+         ++$self->{outstanding};
+         $self->{id}{$req->[2]} = 1;
+         substr $req->[0], 0, 2, pack "n", $req->[2];
+         $self->_exec ($req);
+      } elsif (my $cb = shift @{ $self->{wait} }) {
+         # found a wait_for_slot callback, call that one first
+         $cb->($self);
+      } else {
+         # nothing to do, just exit
+         last;
       }
-      ++$self->{outstanding};
-      $self->{id}{$req->[2]} = 1;
-      substr $req->[0], 0, 2, pack "n", $req->[2];
-      $self->_exec ($req);
    }
 }
 =item $resolver->request ($req, $cb->($res))
 Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
 A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or
 a lowercase name (you have to look at the source to see which aliases are
-supported, but all types from RFC 1034, C<aaaa>, C<srv>, C<spf> and a few
+supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
 more are known to this module). A qtype of "*" is supported and means
 "any" record type.
 The callback will be invoked with a list of matching result records or
 none on any error or if the name could not be found.
 the domain name, C<$type> a type string or number, C<$class> a class name
 and @data is resource-record-dependent data. For C<a> records, this will
 be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
 a domain name, for C<txt> records these are all the strings and so on.
-All types mentioned in RFC 1034, C<aaaa>, C<srv> and C<spf> are
+All types mentioned in RFC 1035, C<aaaa>, C<srv> and C<spf> are
 decoded. All resource records not known to this module will just return
 the raw C<rdata> field as fourth entry.
 Note that this resolver is just a stub resolver: it requires a name server
 supporting recursive queries, will not do any recursive queries itself and
    };
    $do_search->();
 }
+=item $resolver->wait_for_slot ($cb->($resolver))
+Wait until a free request slot is available and call the callback with the
+resolver object.
+A request slot is used each time a request is actually sent to the
+nameservers: There are never more than C<max_outstanding> of them.
+Although you can submit more requests (they will simply be queued until
+a request slot becomes available), sometimes, usually for rate-limiting
+purposes, it is useful to instead wait for a slot before generating the
+request (or simply to know when the request load is low enough so one can
+submit requests again).
+This is what this method does: The callback will be called when submitting
+a DNS request will not result in that request being queued. The callback
+may or may not generate any requests in response.
+Note that the callback will only be invoked when the request queue is
+empty, so this does not play well if somebody else keeps the request queue
+full at all times.
+=cut
+sub wait_for_slot {
+   my ($self, $cb) = @_;
+   push @{ $self->{wait} }, $cb;
+   $self->_scheduler;
+}
 use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
 1;
 =back

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.49 by root, Thu May 29 22:34:51 2008 UTC vs. Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.49 by root, Thu May 29 22:34:51 2008 UTC vs.
Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC