r17091 - in /branches/upstream/libnet-dns-async-perl: ./ current/ current/lib/ current/lib/Net/ current/lib/Net/DNS/ current/t/
waja-guest at users.alioth.debian.org
waja-guest at users.alioth.debian.org
Sun Mar 9 20:09:52 UTC 2008
Author: waja-guest
Date: Sun Mar 9 20:09:52 2008
New Revision: 17091
URL: http://svn.debian.org/wsvn/?sc=1&rev=17091
Log:
[svn-inject] Installing original source of libnet-dns-async-perl
Added:
branches/upstream/libnet-dns-async-perl/
branches/upstream/libnet-dns-async-perl/current/
branches/upstream/libnet-dns-async-perl/current/MANIFEST
branches/upstream/libnet-dns-async-perl/current/MANIFEST.SKIP
branches/upstream/libnet-dns-async-perl/current/META.yml
branches/upstream/libnet-dns-async-perl/current/Makefile.PL
branches/upstream/libnet-dns-async-perl/current/README
branches/upstream/libnet-dns-async-perl/current/lib/
branches/upstream/libnet-dns-async-perl/current/lib/Net/
branches/upstream/libnet-dns-async-perl/current/lib/Net/DNS/
branches/upstream/libnet-dns-async-perl/current/lib/Net/DNS/Async.pm
branches/upstream/libnet-dns-async-perl/current/t/
branches/upstream/libnet-dns-async-perl/current/t/01_use.t
branches/upstream/libnet-dns-async-perl/current/t/02_resolve.t
Added: branches/upstream/libnet-dns-async-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/MANIFEST?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/MANIFEST (added)
+++ branches/upstream/libnet-dns-async-perl/current/MANIFEST Sun Mar 9 20:09:52 2008
@@ -1,0 +1,8 @@
+lib/Net/DNS/Async.pm
+Makefile.PL
+MANIFEST This list of files
+MANIFEST.SKIP
+META.yml Module meta-data (added by MakeMaker)
+README
+t/01_use.t
+t/02_resolve.t
Added: branches/upstream/libnet-dns-async-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/MANIFEST.SKIP?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libnet-dns-async-perl/current/MANIFEST.SKIP Sun Mar 9 20:09:52 2008
@@ -1,0 +1,19 @@
+^blib
+Makefile$
+Makefile\.[a-z]+$
+^pm_to_blib$
+CVS/.*
+.svn/
+,v$
+^tmp/
+\.old$
+\.bak$
+~$
+^#
+\.shar$
+\.tar$
+\.tgz$
+\.tar\.gz$
+\.zip$
+_uu$
+\.swp$
Added: branches/upstream/libnet-dns-async-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/META.yml?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/META.yml (added)
+++ branches/upstream/libnet-dns-async-perl/current/META.yml Sun Mar 9 20:09:52 2008
@@ -1,0 +1,14 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Net-DNS-Async
+version: 1.06
+version_from: lib/Net/DNS/Async.pm
+installdirs: site
+requires:
+ IO::Select: 0
+ Net::DNS: 0
+ Storable: 0
+ Test::More: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libnet-dns-async-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/Makefile.PL?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/Makefile.PL (added)
+++ branches/upstream/libnet-dns-async-perl/current/Makefile.PL Sun Mar 9 20:09:52 2008
@@ -1,0 +1,32 @@
+use 5.006;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'Net::DNS::Async',
+ 'VERSION_FROM' => 'lib/Net/DNS/Async.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => 0,
+ 'Net::DNS' => 0,
+ 'IO::Select' => 0,
+ 'Storable' => 0,
+ },
+ ABSTRACT_FROM => 'lib/Net/DNS/Async.pm',
+ AUTHOR => 'Shevek <cpan at anarres.org>',
+);
+
+sub MY::postamble {
+ my $self = shift;
+ my $old = $self->MM::postamble(@_);
+ chomp($old);
+ my $new = <<'EON';
+
+.PHONY : aux readme
+
+aux : readme
+
+readme : lib/Net/DNS/Async.pm
+ perldoc -t lib/Net/DNS/Async.pm > README
+
+EON
+ return $old . $new;
+}
Added: branches/upstream/libnet-dns-async-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/README?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/README (added)
+++ branches/upstream/libnet-dns-async-perl/current/README Sun Mar 9 20:09:52 2008
@@ -1,0 +1,78 @@
+NAME
+ Net::DNS::Async - Asynchronous DNS helper for high volume applications
+
+SYNOPSIS
+ use Net::DNS::Async;
+
+ my $c = new Net::DNS::Async(QueueSize => 20, Retries => 3);
+
+ for (...) {
+ $c->add(\&callback, @query);
+ }
+ $c->await();
+
+ sub callback {
+ my $response = shift;
+ ...
+ }
+
+DESCRIPTION
+ Net::DNS::Async is a fire-and-forget asynchronous DNS helper. That is,
+ the user application adds DNS questions to the helper, and the callback
+ will be called at some point in the future without further intervention
+ from the user application. The application need not handle selects,
+ timeouts, waiting for a response or any other such issues.
+
+ If the same query is added to the queue more than once, the module may
+ combine the queries; that is, it will perform the query only once, and
+ will call each callback registered for that query in turn, passing the
+ same Net::DNS::Response object to each query. For this reason, you
+ should not modify the Net::DNS::Response object in any way lest you
+ break things horribly for a subsequent callback.
+
+ This module is similar in principle to POE::Component::Client::DNS, but
+ does not require POE.
+
+CONSTRUCTOR
+ The class method new(...) constructs a new helper object. All arguments
+ are optional. The following parameters are recognised as arguments to
+ new():
+
+ QueueSize
+ The size of the query queue. If this is exceeded, further calls to
+ add() will block until some responses are received or time out.
+
+ Retries
+ The number of times to retry a query before giving up.
+
+ Timeout
+ The timeout for an individual query.
+
+METHODS
+ $c->add($callback, @query)
+ Adds a new query for asynchronous handling. The @query arguments are
+ those to Net::DNS::Resolver->bgsend(), q.v. This call will block if
+ the queue is full. When some pending responses are received or
+ timeout events occur, the call will unblock.
+
+ The user callback will be called at some point in the future, with a
+ Net::DNS::Packet object representing the response. If the query
+ timed out after the specified number of retries, the callback will
+ be called with undef.
+
+ $c->await()
+ Flushes the queue, that is, waits for and handles all remaining
+ responses.
+
+BUGS
+ The test suite does not test query timeouts.
+
+SEE ALSO
+ Net::DNS, POE::Component::Client::DNS
+
+COPYRIGHT
+ Copyright (c) 2005-2006 Shevek. All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
Added: branches/upstream/libnet-dns-async-perl/current/lib/Net/DNS/Async.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/lib/Net/DNS/Async.pm?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/lib/Net/DNS/Async.pm (added)
+++ branches/upstream/libnet-dns-async-perl/current/lib/Net/DNS/Async.pm Sun Mar 9 20:09:52 2008
@@ -1,0 +1,291 @@
+package Net::DNS::Async;
+
+use strict;
+use warnings;
+use vars qw($VERSION $_LEVEL);
+use constant {
+ NDS_CALLBACKS => 0,
+ NDS_RESOLVER => 1,
+ NDS_FQUERY => 2,
+ NDS_RETRIES => 3,
+ NDS_SENDTIME => 4,
+ NDS_SOCKET => 5,
+};
+use Net::DNS::Resolver;
+use IO::Select;
+use Time::HiRes;
+use Storable qw(freeze thaw);
+
+$VERSION = '1.06';
+$_LEVEL = 0;
+
+sub new {
+ my $class = shift;
+ my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };
+ $self->{Pending} = [ ];
+ $self->{Queue} = { };
+ $self->{QueueSize} = 20 unless $self->{QueueSize};
+ $self->{Timeout} = 4 unless $self->{Timeout};
+ $self->{Resolver} = new Net::DNS::Resolver();
+ $self->{Selector} = new IO::Select();
+ $self->{Retries} = 3 unless $self->{Retries};
+ return bless $self, $class;
+}
+
+sub add {
+ my ($self, $params, @query) = @_;
+ my ($callback, @ns);
+
+ if (ref($params) eq 'HASH') {
+ @query = @{ $params->{Query} } if exists $params->{Query};
+ $callback = $params->{Callback};
+ @ns = @{ $params->{Nameservers} }
+ if exists $params->{Nameservers};
+ }
+ else {
+ $callback = $params;
+ }
+
+ unless (ref($callback) eq 'CODE') {
+ die "add() requires a CODE reference for a callback";
+ }
+ unless (@query) {
+ die "add() requires a DNS query";
+ }
+
+ my $frozen = freeze(\@query);
+ unless (@ns) {
+ # It's a regular boring query, we can fold it.
+ # I wouldn't like to do this in a multi-threaded environment.
+ for my $data (values %{ $self->{Queue} }) {
+ if ($frozen eq $data->[NDS_FQUERY]) {
+ # Allow the use of slot 0 for custom hacks.
+ unless ($data->[NDS_RESOLVER]) {
+ push(@{ $data->[NDS_CALLBACKS] }, $callback);
+ return;
+ }
+ }
+ }
+ }
+
+ # if ($_LEVEL) { add to Pending } else { recv/send }
+
+ $self->recv(0); # Perform fast case unconditionally.
+ # print "Queue size " . scalar(keys %{ $self->{Queue} });
+ while (scalar(keys %{ $self->{Queue} }) > $self->{QueueSize}) {
+ # I'm fairly sure this can't busy wait since it must
+ # either time out an entry or receive an entry when called
+ # with no arguments.
+ $self->recv();
+ }
+
+ # [ [ $callback ], $frozen, 0, undef, undef ];
+ my $data = [ ];
+ $data->[NDS_CALLBACKS] = [ $callback ];
+ $data->[NDS_RESOLVER] = new Net::DNS::Resolver(
+ nameservers => \@ns
+ ) if @ns;
+ $data->[NDS_FQUERY] = $frozen;
+ $data->[NDS_RETRIES] = 0;
+ $self->send($data);
+}
+
+sub cleanup {
+ my ($self, $data) = @_;
+
+ my $socket = $data->[NDS_SOCKET];
+ if ($socket) {
+ $self->{Selector}->remove($socket);
+ delete $self->{Queue}->{$socket->fileno};
+ $socket->close();
+ }
+}
+
+sub send {
+ my ($self, $data) = @_;
+
+ my @query = @{ thaw($data->[NDS_FQUERY]) };
+ my $resolver = $data->[NDS_RESOLVER] || $self->{Resolver};
+ my $socket = $resolver->bgsend(@query);
+
+ unless ($socket) {
+ die "No socket returned from bgsend()";
+ }
+ unless ($socket->fileno) {
+ die "Socket returned from bgsend() has no fileno";
+ }
+
+ $data->[NDS_SENDTIME] = time();
+ $data->[NDS_SOCKET] = $socket;
+
+ $self->{Queue}->{$socket->fileno} = $data;
+ $self->{Selector}->add($socket);
+}
+
+sub recv {
+ my $self = shift;
+ my $time = shift;
+
+ unless (defined $time) {
+ $time = time();
+ # Find first timer.
+ for (values %{ $self->{Queue} }) {
+ $time = $_->[NDS_SENDTIME] if $_->[NDS_SENDTIME] < $time;
+ }
+ # Add timeout, and compute delay until then.
+ $time = $time + $self->{Timeout} - time();
+ # It could have been a while ago.
+ $time = 0 if $time < 0;
+ }
+
+ my @sockets = $self->{Selector}->can_read($time - time());
+ for my $socket (@sockets) {
+ # If we recursed from the user callback into add(), then
+ # we might have read from and closed this socket.
+ # XXX A neater solution would be to collect all the
+ # callbacks and perform them after this loop has exited.
+ next unless $socket->fileno;
+ $self->{Selector}->remove($socket);
+ my $data = delete $self->{Queue}->{$socket->fileno};
+ unless ($data) {
+ die "No data for socket " . $socket->fileno;
+ }
+ my $response = $self->{Resolver}->bgread($socket);
+ $socket->close();
+ eval {
+ local $_LEVEL = 1;
+ $_->($response) for @{ $data->[NDS_CALLBACKS] };
+ };
+ if ($@) {
+ die "Async died within " . __PACKAGE__ . ": $@";
+ }
+ }
+
+ $time = time();
+ for my $data (values %{ $self->{Queue} }) {
+ if ($data->[NDS_SENDTIME] + $self->{Timeout} < $time) {
+ # It timed out.
+ $self->cleanup($data);
+ if ($self->{Retries} < ++$data->[NDS_RETRIES]) {
+ local $_LEVEL = 1;
+ $_->(undef) for @{ $data->[NDS_CALLBACKS] };
+ }
+ else {
+ $self->send($data);
+ }
+ }
+ }
+}
+
+sub await {
+ my $self = shift;
+ # If we have Pending, we need a better algorithm here.
+ $self->recv while keys %{ $self->{Queue} };
+}
+
+*done = \&await;
+
+=head1 NAME
+
+Net::DNS::Async - Asynchronous DNS helper for high volume applications
+
+=head1 SYNOPSIS
+
+ use Net::DNS::Async;
+
+ my $c = new Net::DNS::Async(QueueSize => 20, Retries => 3);
+
+ for (...) {
+ $c->add(\&callback, @query);
+ }
+ $c->await();
+
+ sub callback {
+ my $response = shift;
+ ...
+ }
+
+=head1 DESCRIPTION
+
+Net::DNS::Async is a fire-and-forget asynchronous DNS helper.
+That is, the user application adds DNS questions to the helper, and
+the callback will be called at some point in the future without
+further intervention from the user application. The application need
+not handle selects, timeouts, waiting for a response or any other
+such issues.
+
+If the same query is added to the queue more than once, the module
+may combine the queries; that is, it will perform the query only
+once, and will call each callback registered for that query in turn,
+passing the same Net::DNS::Response object to each query. For this
+reason, you should not modify the Net::DNS::Response object in any
+way lest you break things horribly for a subsequent callback.
+
+This module is similar in principle to POE::Component::Client::DNS,
+but does not require POE.
+
+=head1 CONSTRUCTOR
+
+The class method new(...) constructs a new helper object. All arguments
+are optional. The following parameters are recognised as arguments
+to new():
+
+=over 4
+
+=item QueueSize
+
+The size of the query queue. If this is exceeded, further calls to
+add() will block until some responses are received or time out.
+
+=item Retries
+
+The number of times to retry a query before giving up.
+
+=item Timeout
+
+The timeout for an individual query.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $c->add($callback, @query)
+
+Adds a new query for asynchronous handling. The @query arguments are
+those to Net::DNS::Resolver->bgsend(), q.v. This call will block
+if the queue is full. When some pending responses are received or
+timeout events occur, the call will unblock.
+
+The user callback will be called at some point in the future, with
+a Net::DNS::Packet object representing the response. If the query
+timed out after the specified number of retries, the callback will
+be called with undef.
+
+=item $c->await()
+
+Flushes the queue, that is, waits for and handles all remaining
+responses.
+
+=back
+
+=head1 BUGS
+
+The test suite does not test query timeouts.
+
+=head1 SEE ALSO
+
+L<Net::DNS>,
+L<POE::Component::Client::DNS>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2006 Shevek. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: branches/upstream/libnet-dns-async-perl/current/t/01_use.t
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/t/01_use.t?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/t/01_use.t (added)
+++ branches/upstream/libnet-dns-async-perl/current/t/01_use.t Sun Mar 9 20:09:52 2008
@@ -1,0 +1,7 @@
+use strict;
+use warnings;
+use blib;
+
+use Test::More tests => 1;
+
+use_ok('Net::DNS::Async');
Added: branches/upstream/libnet-dns-async-perl/current/t/02_resolve.t
URL: http://svn.debian.org/wsvn/branches/upstream/libnet-dns-async-perl/current/t/02_resolve.t?rev=17091&op=file
==============================================================================
--- branches/upstream/libnet-dns-async-perl/current/t/02_resolve.t (added)
+++ branches/upstream/libnet-dns-async-perl/current/t/02_resolve.t Sun Mar 9 20:09:52 2008
@@ -1,0 +1,31 @@
+use strict;
+use warnings;
+use blib;
+use Data::Dumper;
+
+use Test::More tests => 300;
+
+use Net::DNS::Async;
+
+my $c = new Net::DNS::Async();
+for my $i (1..20) {
+ for my $s (qw(google demon yahoo microsoft)) {
+ $c->add(sub { cb($s, $i, @_) }, "www.$s.com", 'A');
+ }
+ $c->add(sub { cb('__nxd__', $i, @_) }, "nx$i.__nxd__.com", 'A');
+}
+$c->done();
+
+sub cb {
+ my ($s, $i, $res) = @_;
+ ok(defined $res, "Received $s $i");
+ my @q = $res->question;
+ my @a = $res->answer;
+ like($q[0]->qname, qr/\.com$/, "Question was a .com");
+ if ($q[0]->qname =~ /__nxd__/) {
+ is($res->header->rcode, "NXDOMAIN", "Got an nxdomain");
+ }
+ else {
+ like($a[0]->string, qr/\bIN\b/, "Got an INET response");
+ }
+}
More information about the Pkg-perl-cvs-commits
mailing list