File Coverage

blib/lib/Net/DNS/TestNS.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Net::DNS::TestNS;
use XML::LibXML;
use IO::File;


use Data::Dumper;
use strict;
use warnings;
use Carp;

require Exporter;


our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.


our @EXPORT_OK = qw (
);

our @EXPORT = qw(

);


use vars qw( $AUTOLOAD
	     $LastRevision
	     $VERSION
	     $errorcondition
	     $TESTNS_DTD
	     $TESTNS_DTD_0
	     $TESTNS_DTD_1_0
);
$VERSION = (qw$LastChangedRevision: 461 $)[1];



use Net::DNS::TestNS::Nameserver;
use Net::DNS;


my $verbose=0;






sub get_dtd {
    return $TESTNS_DTD;
}



sub new {
    my $class = shift;
    my $self = {};
    bless $self,ref $class || $class;
    my ($configfile,$params)=@_;

    $self->{servercount}=0;
    $self->{verbose} = ${$params}{Verbose} || $verbose;
    $self->{validate} = 1;
    $self->{validate} = ${$params}{Validate} if defined ${$params}{Validate};


    if (! $configfile){
	$errorcondition="No config file specified" ;
	return 0;
    }
    if (! -f $configfile){
	$errorcondition="$configfile does not exist" ;
	return 0;
    }

    my $docstring;

    $docstring=$self->_preprocess_input("",$configfile);

    return 0 unless $docstring;

    my $parser=XML::LibXML->new();



    my $doc=$parser->parse_string($docstring);


    my $root=$doc->getDocumentElement;
    my $DTD_version=$root->findvalue('@version');
    my $dtd_str=$TESTNS_DTD_0 if ! $DTD_version;
    $dtd_str=$TESTNS_DTD_1_0 if $DTD_version eq "1.0";
    carp "Could not determine DTD version from configuration file" unless $dtd_str;
    my $dtd= XML::LibXML::Dtd->parse_string($dtd_str);
    $doc->validate($dtd) if  $self->{'validate'};

    print STDERR "Warning version not defined assuming version 0 of the DTD.\n".
      Carp::shortmess ."\n"
	unless 	$DTD_version;

    my $servercount=0;

    foreach my $server ($root->findnodes('server')){
	my %answerdb;

	my $ip=$server->findvalue('@ip');
	$ip =~ s/\s*//g;
	my $port=$server->findvalue('@port');
	print "---------Server $ip ($port) ----------------\n" if $self->{verbose};

	foreach my  $qname  ($server->findnodes('qname')){
	      my $query_name= $qname->findvalue('@name');
	      if ($query_name =~ /\s/){
		  $errorcondition="spaces in queryname are not allowed";
		   return 0;
		   #next;
	      }
	      $query_name.="." if $query_name !~ /\.$/;

	    foreach my  $qtype  ($qname->findnodes('qtype')){
	      my $query_type= $qtype->findvalue('@type');
	       if (exists $answerdb{$query_name}->{$query_type}){
		   $errorcondition= "There is allready data for $query_name,$query_type";
		   return 0;
		   #next;
	       }

	      print "=$query_name,$query_type\n" if $self->{verbose};

	      my $delay= $qtype->findvalue('@delay');
	      $answerdb{$query_name}->{$query_type}->{'delay'}=0;

	      if ($delay=~/^\d+$/){
		  $answerdb{$query_name}->{$query_type}->{'delay'}=$delay ;
	      }

	      if (! $DTD_version){
		  $answerdb{$query_name}->{$query_type}->{'rcode'}=
		      $qtype->findvalue('@rcode');
		  $answerdb{$query_name}->{$query_type}->{'header'}->{"aa"}=
		      $qtype->findvalue('@aa');
		  $answerdb{$query_name}->{$query_type}->{'header'}->{"ad"}=
		      $qtype->findvalue('@ad');
		  $answerdb{$query_name}->{$query_type}->{'header'}->{"ra"}=
		      $qtype->findvalue('@ra');
	      } else {
		  my @header= $qtype->findnodes('header');
		  carp "Other than one header node" if scalar @header != 1;
		  {
		      my @rcode=$header[0]->findnodes('rcode');
		      carp "Other than one rcode node" if scalar @rcode != 1;
		      my $rcode_val=$rcode[0]->findvalue('@value');
		      croak "No rcode found" unless $rcode_val;
		      print "RCODE: $rcode_val\n" if $self->{verbose};
		      $answerdb{$query_name}->{$query_type}->{'rcode'}= $rcode_val;
		  }

		  # Parse the required fields
		  foreach my $headerfield qw( aa  ra ){
		      my @fields=$header[0]->findnodes($headerfield);
		      carp "Only one $headerfield node is allowed" if scalar @fields != 1;
		      my $field_val=$fields[0]->findvalue('@value');
		      croak "No $headerfield value found" unless defined $field_val;
		      print uc($headerfield).": $field_val\n" if $self->{verbose};
		      $answerdb{$query_name}->{$query_type}->{'header'}->{$headerfield}= $field_val;
		  }


		  # Parse the non-required fields
		  foreach my $headerfield qw( ad cd qr rd tc id qdcount ancount nscount adcount){
		      my @fields=$header[0]->findnodes($headerfield);
		      next unless @fields;
		      carp "More than one $headerfield node is allowed" if scalar @fields != 1;
		      my $field_val=$fields[0]->findvalue('@value');
		      print uc($headerfield).": $field_val\n" if $self->{verbose};
		      $answerdb{$query_name}->{$query_type}->{'header'}->{$headerfield}= $field_val;
		  }



	      } # End DTD_VERSION specific parsing.
	      my @raw=$qtype->findnodes('raw');

	      if (@raw){
		  my $rawhex=$raw[0]->findvalue(".");
		  $rawhex =~s/\s*//g;
		  my $packetdata=pack("H*",$rawhex);
		  $answerdb{$query_name}->{$query_type}->{'raw'}=$packetdata;
	      }else{
		  # not @raw, which should be the default for DTD version 0.
		  foreach my $ans ($qtype->findnodes('ans')){
		      my $rr_string=$ans->findvalue(".");
		      $rr_string =~s/\n//g;
		      next if $rr_string =~ /^\s*$/;
		      my $ans_rr= Net::DNS::RR->new( $rr_string );
		      if ($ans_rr){
			  push @{$answerdb{$query_name}->{$query_type}->{'answer'}}, $ans_rr;
		      }else{
			  $errorcondition= " Could not parse $rr_string\n";
			  return 0;
		      }
		  }
		  foreach my $ans ($qtype->findnodes('aut')){
		      my $rr_string=$ans->findvalue(".");
		      next if $rr_string =~ /^\s*$/;
		      $rr_string =~s/\n//g;
		      my $ans_rr= Net::DNS::RR->new( $rr_string );
		      if ($ans_rr){
			  push @{$answerdb{$query_name}->{$query_type}->{'authority'}}, $ans_rr;
		      }else{
			  $errorcondition= " Could not parse $rr_string\n";
			  return 0;
		      }
		  }
		  foreach my $ans ($qtype->findnodes('add')){
		      my $rr_string=$ans->findvalue(".");
		      next if $rr_string =~ /^\s*$/;
		      $rr_string =~s/\n//g;
		      my $ans_rr= Net::DNS::RR->new( $rr_string );
		      if ($ans_rr){
			  push @{$answerdb{$query_name}->{$query_type}->{'additional'}}, $ans_rr;
		      }else{
			  $errorcondition= " Could not parse $rr_string\n";
			  return 0;
		      }
		  }

		  if ( my @opt=($qtype->findnodes('opt'))){
		      my $optrr;


		      my $size=$opt[0]->findvalue('@size');
		      die "Sorry $size should be specified" unless defined $size;

		      my @flag=$opt[0]->findnodes('flag');
		      my $ednsflags=pack("n",0);
		      if (@flag) {
			  my $flagvalue=$flag[0]->findvalue('@value');
			  if ($flagvalue =~ /^\s*\d+\s*$/){
			      $ednsflags=$flagvalue;
			  }elsif($flagvalue =~ /\s*0x(.+)\s*/i){
			      $ednsflags=
				  unpack("n",pack("H*",$1));

			  }else{
			      die "Sorry I could not parse $flagvalue\n";
			  }


			  print "EDNSFLAGS: ". sprintf("0x%04x", $ednsflags) ."\n" if $self->{'verbose'};

		      }else{
                          # Since we only have one option we'll do an
                          # assignment.
			  my @options=$opt[0]->findnodes("options");
			  my $dobit=$options[0]->findvalue('@do');
			  $ednsflags = 0x8000 if $dobit;
		      }

		      $optrr= Net::DNS::RR->new(
						Type         => 'OPT',
						Name         => '',
						Class        => $size,  # Decimal UDPpayload
						ednsflags    => $ednsflags, # first bit set see RFC 3225
						);

		      push @{$answerdb{$query_name}->{$query_type}->{'additional'}}, $optrr;

		  }
	      } # end not @raw

	  }



	  }


	# The XML has been parsed and all info sits in the %answer db..
	# We now construct the reply handler using that.
	my $reply_handler = sub {
	    my ($qname, $qclass, $qtype) = @_;
	    $qname.="." if $qname !~ /\.$/;
	    my ($rcode, @ans, @auth, @add);
	    if ( exists $answerdb{$qname}->{$qtype}){
		$rcode= $answerdb{$qname}->{$qtype}->{'rcode'};
		my $transporthash= {
		    'aa' =>
			$answerdb{$qname}->{$qtype}->
		    {'header'}->{'aa'},
			'ra' =>
			$answerdb{$qname}->{$qtype}->
		    {'header'}->{'ra'},
		    };

		foreach my $headerfield qw(aa qr ad rd tc id cd
					   qdcount ancount nscount arcount ){
		    $transporthash->{$headerfield}= $answerdb{$qname}->{$qtype}->
		    {'header'}->{$headerfield} if defined
		    $answerdb{$qname}->{$qtype}->{'header'}->{$headerfield} ;
		}

		print "Sleeping for " . $answerdb{$qname}->{$qtype}->{'delay'}
		. " seconds "
		    if $self->{verbose} && $answerdb{$qname}->{$qtype}->{'delay'};

		sleep ($answerdb{$qname}->{$qtype}->{'delay'});

		if (defined($answerdb{$qname}->{$qtype}->{'raw'})){
		    $transporthash->{'raw'}=$answerdb{$qname}->{$qtype}->{'raw'};
		}


		return ($rcode, $answerdb{$qname}->{$qtype}->{'answer'},
			$answerdb{$qname}->{$qtype}->{'authority'},
			$answerdb{$qname}->{$qtype}->{'additional'},
			$transporthash);

	    }

	    return ("SERVFAIL");
	};
	print "Setting up server for: $ip,$port\n" if $self->{verbose};


	my $ns;
	$ns= Net::DNS::TestNS::Nameserver->new(
				       LocalPort	   => $port,
				       LocalAddr           => $ip,
				       ReplyHandler => $reply_handler,
				       Verbose	   => $self->{verbose},
				       );


	if (! $ns ){
	    $errorcondition="Could not create Nameserver object";
	    return 0;
	}

	$self->{'serverinstance'}->[$servercount]->{'server'}=$ns;
	$self->{'serverinstance'}->[$servercount]->{'_child_pid'}="_not_running";
	$servercount++;
    } #end looping over all servers.



    $self->{'servercount'}=$servercount;
    #
    #  Now dynamically set up the reply handler.
    #
    #
    return bless $self, $class;

}



sub run {
    my $self=shift;
    my $servercount=0;

    while ( $servercount <  $self->{'servercount'} ){

	if ($self->{'serverinstance'}->[$servercount]->{'_child_pid'} ne
	    "_not_running" ){
	    print "This instance allready has a server running\n";
	    return ;
	}


	my $pid;
      FORK: {
	  no strict 'subs';  # EAGAIN
	  if ($pid=fork) {# assign result of fork to $pid,
	      # see if it is non-zero.
	      # Parent process here
	      # Child pid is in $pid
	      print "Child Process: ".$pid."\n" if $self->{verbose};
	      $self->{'serverinstance'}->[$servercount]->{'_child_pid'}=$pid;

	  } elsif (defined($pid)) {
	      # Child process here
	      #parent process pid is available with getppid
	      # exec will transfer control to the child process,
	      # and will finish (exit) when the tar is done.

	      #Verbose level is set during construction.. The verbose method
	      # may have been called afterward.

	      $self->{'serverinstance'}->[$servercount]->{'server'}->{"Verbose"}=$self->verbose;
	      $self->{'serverinstance'}->[$servercount]->{'server'}->main_loop;
	  } elsif ($! == EAGAIN) {
	      # EAGAIN is the supposedly recoverable fork error
	      sleep 5;
	      redo FORK;
	  }else {
	      #weird fork error
	      die "Can't fork: $!\n";
	  }
      }

	$servercount++;
    }
    1;

}


sub _preprocess_input {
    my $self=shift;
    my $outstring=shift;
    my $filename=shift;
    my $infile=new IO::File;
	if ($infile->open("< $filename")) {
	    while (<$infile>){
		if (/^(.*)()(.*)$/){
		    my $newfile=$3;
		    print "including $newfile\n" if $self->{verbose};
		    $outstring= $outstring. $1;
		    $outstring=$self->_preprocess_input($outstring,$newfile);
		    return 0 unless $outstring;
		    $outstring= $outstring. $4;
		}else{
		    $outstring= $outstring. $_;
		}
	    }
	}else{
	    $errorcondition= "Could not open $filename during preporcessing";
	    return 0;
	}
    return $outstring;
}


sub verbose {
    my $self=shift;
    my $argument=shift;
    $self->{verbose}=$argument if defined($argument);
    return $self->{verbose};
}

sub stop {
    my $self=shift;
    $self->medea(@_);
}




sub medea {
    my $self=shift;

    my $servercount=0;

    while ( $servercount <  $self->{'servercount'} ){

	if ($self->{'serverinstance'}->[$servercount]->{'_child_pid'} ne
	    '_not_running'){
	    if (  kill(15, $self->{'serverinstance'}->[$servercount]->{'_child_pid'}) != 1 ){
		die "UNABLE TO KILL CHILDREN. KILL ".$self->{'serverinstance'}->[$servercount]->{'_child_pid'}." BY HAND";
	    }

	    print "Killed ".$self->{'serverinstance'}->[$servercount]->{"_child_pid"}."\n" if $self->{verbose};
	    $self->{'serverinstance'}->[$servercount]->{"_child_pid"}="_not_running";

	} else {
	    # The child is not running...
	}
	$servercount++;
    }
}

sub DESTROY {
    # Time for Greek Drama
    # All children should be killed...
    #
    my $self=shift;
    $self->medea;
}




sub AUTOLOAD {
        my ($self) = @_;

        my $name = $AUTOLOAD;
        $name =~ s/.*://;

        Carp::croak "$name: no such method" unless exists $self->{$name};

        no strict q/refs/;

        # AUTOLOADER sets and reads existing variables.
        *{$AUTOLOAD} = sub {
                my ($self, $new_val) = @_;

                if (defined $new_val) {
                        $self->{"$name"} = $new_val;
                }

                return $self->{"$name"};
        };

        goto &{$AUTOLOAD};
}






BEGIN {
    $TESTNS_DTD_0='


























';


# Note: generateDTDpod.pl asumes the DTD is stored as $TESNS_DTD and
# has a rather "loose" way to determine the begin and the end of the
# string.  Start: if (s/\$TESTNS_DTD=\'//){ End: if (s/\'\;//){

    $TESTNS_DTD='








































                   ((question?,ans*,aut*,add*,opt?)
                    |raw)
                   )>







                     ad?, cd?, qr?,rd?,tc?,id?,
                     qdcount?,ancount?,nscount?,arcount?)>
















































































';

    $TESTNS_DTD_1_0=$TESTNS_DTD;

} #END BEGIN








=head1 NAME

Net::DNS::TestNS - Perl extension for simulating simple Nameservers

=head1 SYNOPSIS

use Net::DNS::TestNS;


=head1 ABSTRACT

Class for setting up "simple DNS" servers.

=head1 DESCRIPTION

Class to setup a number of nameservers that respond to specific DNS
queries (QNAME,QTYPE) by prespecified answers. This class is to be
used in test suites where you want to have servers to show predefined
behavior.

If the server will do a lookup based on QNAME,QTYPE and return the
specified data. If there is no QNAME, QTYPE match the server will
return a SERVFAIL.

A log will be written to STDERR it contains time, IP/PORT, QNAME,
QTYPE, RCODE

=head2 Configuration file

The class uses an XML file to read its configuration. The DTD is documented
in L.


The setup is split in a number of servers, each with a unique IP/port
number, each server has 1 or more QNAMEs it will respond to. Each
QNAME can have QTYPEs specified.

For each QNAME,QTYPE an answer needs to be specified, response code
and header bits can be tweaked through the qtype attributes.

The content of the packet can be specified through ans, aut and add
elements, each specifying one RR record to end up in the answer,
authority or additional section.

The optional 'delay' attribute in the QTYPE element specifies how many
seconds the server should wait until an answer is returned.


If the query does not match against data specified in the
configuration a SERVFAIL is returned.

=head2 new


    my $server=Net::DNS::TestNS->new($configfile, {
     Verbose => 1,
        Validate => 1,
    });



Read the configuration files and bind to ports.  One can use  anywhere inside the configuration file to include
other XML configuration fragments.

The second optional argument is hash that contains customization parameters.
    Verbose  boolean     Makes the code more verbose.
    Validate boolean     Turns on XML validation based
                         on the DTD
                         The parser is flexible with
                         respect to the ordering
                         of some of the XML elements.
                         The DTD is not.
                         Validation is on by default.



new returns the object reference on success and 0 on failure. On
failure the class variable $Net::DNS::TestNS::errorcondition is set.



=head2 verbose

    $self->verbose(1);

Sets verbosity at run time.

=head2 run

Spawns off the servers and process the data.

=head2 medea

Cleanup function that kills all the children spawned by the
instance.  Also known by its alias 'stop'.

=head1 Configuration file example



















        bla.foo.  3600 IN TXT "TEXT"


        bla.foo.          3600     IN     TXT     "Other text"

















     07 74726967676572
     03 666f6f
     00

     00 01

     00 01



     c0 0c
     00 01
     00 01
     00 00 00 05
     00 04
     0a 00 00 01








=head1 Known Deficiencies and TODO

The module is based on Net::DNS::Nameserver. There is no way to
distinguish if the query came over TCP or UDP; besides UDP truncation
is not available in Net::DNS::Nameserver.

Earlier versions of this script used a different DTD that had no
version number. The script only validates against version 1.0 of the
DTD but parses the old files.


==head1 ALSO SEE
L, L, L

=head1 AUTHOR

Olaf Kolkman, [e-mail]


=head1 COPYRIGHT AND LICENSE

Copyright (c) 2003-2005  RIPE NCC.  Author Olaf M. Kolkman

All Rights Reserved

Permission to use, copy, modify, and distribute this software and its
documentation for any purpose and without fee is hereby granted,
provided that the above copyright notice appear in all copies and that
both that copyright notice and this permission notice appear in
supporting documentation, and that the name of the author not be
used in advertising or publicity pertaining to distribution of the
software without specific, written prior permission.


THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
AUTHOR BE LIABLE FOR ANY SPECIAL, 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.


=cut



1;
__END__