ans.pl revision 8c76634f88c5b3169b61505925e10b997ea08e54
#
# Copyright (C) 2004, 2007 Internet Systems Consortium, Inc. ("ISC")
# Copyright (C) 2001 Internet Software Consortium.
#
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES WITH
# REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS. IN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT,
# INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
# LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
# OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
# PERFORMANCE OF THIS SOFTWARE.
# $Id: ans.pl,v 1.6 2007/09/24 04:13:25 marka Exp $
#
# This is the name server from hell. It provides canned
# responses based on pattern matching the queries, and
# can be reprogrammed on-the-fly over a TCP connection.
#
# The server listens for control connections on port 5301.
# A control connection is a TCP stream of lines like
#
# /pattern/
# name ttl type rdata
# name ttl type rdata
# ...
# /pattern/
# name ttl type rdata
# name ttl type rdata
# ...
#
# There can be any number of patterns, each associated
# with any number of response RRs. Each pattern is a
# Perl regular expression.
#
# Each incoming query is converted into a string of the form
# "qname qtype" (the printable query domain name, space,
# printable query type) and matched against each pattern.
#
# The first pattern matching the query is selected, and
# the RR following the pattern line are sent in the
# answer section of the response.
#
# Each new control connection causes the current set of
# patterns and responses to be cleared before adding new
# ones.
#
# The server handles UDP and TCP queries. Zone transfer
# responses work, but must fit in a single 64 k message.
#
$pidf->close or die "cannot close pid file: $!";;
my @answers = ();
sub handle {
my ($buf) = @_;
my $r;
foreach $r (@rules) {
warn "match $qname $qtype == $pattern";
if ("$qname $qtype" =~ /$pattern/) {
my $a;
foreach $a (@{$r->{answer}}) {
$packet->push("answer", $a);
}
last;
}
}
# $packet->print;
}
for (;;) {
$rin = '';
warn "ctl conn";
@rules = ();
chomp $line;
if ($line =~ m!^/(.*)/$!) {
} else {
}
}
$conn->close;
printf "UDP request\n";
for (;;) {
printf "TCP request\n";
last unless $n == 2;
last unless $n == $len;
}
$conn->close;
}
}