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


line stmt bran cond sub pod time code
1             package Net::DNS::TestNS;
2 3     3   120319 use XML::LibXML;
  0            
  0            
3             use IO::File;
4              
5              
6             use Data::Dumper;
7             use strict;
8             use warnings;
9             use Carp;
10              
11             require Exporter;
12              
13              
14             our @ISA = qw(Exporter);
15              
16             # Items to export into callers namespace by default. Note: do not export
17             # names by default without a very good reason. Use EXPORT_OK instead.
18             # Do not simply export all your public functions/methods/constants.
19              
20              
21             our @EXPORT_OK = qw (
22             );
23              
24             our @EXPORT = qw(
25              
26             );
27              
28              
29             use vars qw( $AUTOLOAD
30             $LastRevision
31             $VERSION
32             $errorcondition
33             $TESTNS_DTD
34             $TESTNS_DTD_0
35             $TESTNS_DTD_1_0
36             );
37             $VERSION = (qw$LastChangedRevision: 461 $)[1];
38            
39            
40            
41             use Net::DNS::TestNS::Nameserver;
42             use Net::DNS;
43              
44            
45             my $verbose=0;
46              
47              
48              
49              
50              
51              
52             sub get_dtd {
53             return $TESTNS_DTD;
54             }
55              
56              
57            
58             sub new {
59             my $class = shift;
60             my $self = {};
61             bless $self,ref $class || $class;
62             my ($configfile,$params)=@_;
63              
64             $self->{servercount}=0;
65             $self->{verbose} = ${$params}{Verbose} || $verbose;
66             $self->{validate} = 1;
67             $self->{validate} = ${$params}{Validate} if defined ${$params}{Validate};
68              
69              
70             if (! $configfile){
71             $errorcondition="No config file specified" ;
72             return 0;
73             }
74             if (! -f $configfile){
75             $errorcondition="$configfile does not exist" ;
76             return 0;
77             }
78            
79             my $docstring;
80            
81             $docstring=$self->_preprocess_input("",$configfile);
82            
83             return 0 unless $docstring;
84            
85             my $parser=XML::LibXML->new();
86              
87              
88              
89             my $doc=$parser->parse_string($docstring);
90              
91              
92             my $root=$doc->getDocumentElement;
93             my $DTD_version=$root->findvalue('@version');
94             my $dtd_str=$TESTNS_DTD_0 if ! $DTD_version;
95             $dtd_str=$TESTNS_DTD_1_0 if $DTD_version eq "1.0";
96             carp "Could not determine DTD version from configuration file" unless $dtd_str;
97             my $dtd= XML::LibXML::Dtd->parse_string($dtd_str);
98             $doc->validate($dtd) if $self->{'validate'};
99              
100             print STDERR "Warning version not defined assuming version 0 of the DTD.\n".
101             Carp::shortmess ."\n"
102             unless $DTD_version;
103              
104             my $servercount=0;
105              
106             foreach my $server ($root->findnodes('server')){
107             my %answerdb;
108              
109             my $ip=$server->findvalue('@ip');
110             $ip =~ s/\s*//g;
111             my $port=$server->findvalue('@port');
112             print "---------Server $ip ($port) ----------------\n" if $self->{verbose};
113              
114             foreach my $qname ($server->findnodes('qname')){
115             my $query_name= $qname->findvalue('@name');
116             if ($query_name =~ /\s/){
117             $errorcondition="spaces in queryname are not allowed";
118             return 0;
119             #next;
120             }
121             $query_name.="." if $query_name !~ /\.$/;
122            
123             foreach my $qtype ($qname->findnodes('qtype')){
124             my $query_type= $qtype->findvalue('@type');
125             if (exists $answerdb{$query_name}->{$query_type}){
126             $errorcondition= "There is allready data for $query_name,$query_type";
127             return 0;
128             #next;
129             }
130            
131             print "=$query_name,$query_type\n" if $self->{verbose};
132              
133             my $delay= $qtype->findvalue('@delay');
134             $answerdb{$query_name}->{$query_type}->{'delay'}=0;
135            
136             if ($delay=~/^\d+$/){
137             $answerdb{$query_name}->{$query_type}->{'delay'}=$delay ;
138             }
139            
140             if (! $DTD_version){
141             $answerdb{$query_name}->{$query_type}->{'rcode'}=
142             $qtype->findvalue('@rcode');
143             $answerdb{$query_name}->{$query_type}->{'header'}->{"aa"}=
144             $qtype->findvalue('@aa');
145             $answerdb{$query_name}->{$query_type}->{'header'}->{"ad"}=
146             $qtype->findvalue('@ad');
147             $answerdb{$query_name}->{$query_type}->{'header'}->{"ra"}=
148             $qtype->findvalue('@ra');
149             } else {
150             my @header= $qtype->findnodes('header');
151             carp "Other than one header node" if scalar @header != 1;
152             {
153             my @rcode=$header[0]->findnodes('rcode');
154             carp "Other than one rcode node" if scalar @rcode != 1;
155             my $rcode_val=$rcode[0]->findvalue('@value');
156             croak "No rcode found" unless $rcode_val;
157             print "RCODE: $rcode_val\n" if $self->{verbose};
158             $answerdb{$query_name}->{$query_type}->{'rcode'}= $rcode_val;
159             }
160            
161             # Parse the required fields
162             foreach my $headerfield qw( aa ra ){
163             my @fields=$header[0]->findnodes($headerfield);
164             carp "Only one $headerfield node is allowed" if scalar @fields != 1;
165             my $field_val=$fields[0]->findvalue('@value');
166             croak "No $headerfield value found" unless defined $field_val;
167             print uc($headerfield).": $field_val\n" if $self->{verbose};
168             $answerdb{$query_name}->{$query_type}->{'header'}->{$headerfield}= $field_val;
169             }
170            
171            
172             # Parse the non-required fields
173             foreach my $headerfield qw( ad cd qr rd tc id qdcount ancount nscount adcount){
174             my @fields=$header[0]->findnodes($headerfield);
175             next unless @fields;
176             carp "More than one $headerfield node is allowed" if scalar @fields != 1;
177             my $field_val=$fields[0]->findvalue('@value');
178             print uc($headerfield).": $field_val\n" if $self->{verbose};
179             $answerdb{$query_name}->{$query_type}->{'header'}->{$headerfield}= $field_val;
180             }
181              
182              
183              
184             } # End DTD_VERSION specific parsing.
185             my @raw=$qtype->findnodes('raw');
186              
187             if (@raw){
188             my $rawhex=$raw[0]->findvalue(".");
189             $rawhex =~s/\s*//g;
190             my $packetdata=pack("H*",$rawhex);
191             $answerdb{$query_name}->{$query_type}->{'raw'}=$packetdata;
192             }else{
193             # not @raw, which should be the default for DTD version 0.
194             foreach my $ans ($qtype->findnodes('ans')){
195             my $rr_string=$ans->findvalue(".");
196             $rr_string =~s/\n//g;
197             next if $rr_string =~ /^\s*$/;
198             my $ans_rr= Net::DNS::RR->new( $rr_string );
199             if ($ans_rr){
200             push @{$answerdb{$query_name}->{$query_type}->{'answer'}}, $ans_rr;
201             }else{
202             $errorcondition= " Could not parse $rr_string\n";
203             return 0;
204             }
205             }
206             foreach my $ans ($qtype->findnodes('aut')){
207             my $rr_string=$ans->findvalue(".");
208             next if $rr_string =~ /^\s*$/;
209             $rr_string =~s/\n//g;
210             my $ans_rr= Net::DNS::RR->new( $rr_string );
211             if ($ans_rr){
212             push @{$answerdb{$query_name}->{$query_type}->{'authority'}}, $ans_rr;
213             }else{
214             $errorcondition= " Could not parse $rr_string\n";
215             return 0;
216             }
217             }
218             foreach my $ans ($qtype->findnodes('add')){
219             my $rr_string=$ans->findvalue(".");
220             next if $rr_string =~ /^\s*$/;
221             $rr_string =~s/\n//g;
222             my $ans_rr= Net::DNS::RR->new( $rr_string );
223             if ($ans_rr){
224             push @{$answerdb{$query_name}->{$query_type}->{'additional'}}, $ans_rr;
225             }else{
226             $errorcondition= " Could not parse $rr_string\n";
227             return 0;
228             }
229             }
230              
231             if ( my @opt=($qtype->findnodes('opt'))){
232             my $optrr;
233            
234            
235             my $size=$opt[0]->findvalue('@size');
236             die "Sorry $size should be specified" unless defined $size;
237              
238             my @flag=$opt[0]->findnodes('flag');
239             my $ednsflags=pack("n",0);
240             if (@flag) {
241             my $flagvalue=$flag[0]->findvalue('@value');
242             if ($flagvalue =~ /^\s*\d+\s*$/){
243             $ednsflags=$flagvalue;
244             }elsif($flagvalue =~ /\s*0x(.+)\s*/i){
245             $ednsflags=
246             unpack("n",pack("H*",$1));
247              
248             }else{
249             die "Sorry I could not parse $flagvalue\n";
250             }
251              
252              
253             print "EDNSFLAGS: ". sprintf("0x%04x", $ednsflags) ."\n" if $self->{'verbose'};
254            
255             }else{
256             # Since we only have one option we'll do an
257             # assignment.
258             my @options=$opt[0]->findnodes("options");
259             my $dobit=$options[0]->findvalue('@do');
260             $ednsflags = 0x8000 if $dobit;
261             }
262            
263             $optrr= Net::DNS::RR->new(
264             Type => 'OPT',
265             Name => '',
266             Class => $size, # Decimal UDPpayload
267             ednsflags => $ednsflags, # first bit set see RFC 3225
268             );
269              
270             push @{$answerdb{$query_name}->{$query_type}->{'additional'}}, $optrr;
271              
272             }
273             } # end not @raw
274              
275             }
276            
277            
278            
279             }
280            
281            
282             # The XML has been parsed and all info sits in the %answer db..
283             # We now construct the reply handler using that.
284             my $reply_handler = sub {
285             my ($qname, $qclass, $qtype) = @_;
286             $qname.="." if $qname !~ /\.$/;
287             my ($rcode, @ans, @auth, @add);
288             if ( exists $answerdb{$qname}->{$qtype}){
289             $rcode= $answerdb{$qname}->{$qtype}->{'rcode'};
290             my $transporthash= {
291             'aa' =>
292             $answerdb{$qname}->{$qtype}->
293             {'header'}->{'aa'},
294             'ra' =>
295             $answerdb{$qname}->{$qtype}->
296             {'header'}->{'ra'},
297             };
298            
299             foreach my $headerfield qw(aa qr ad rd tc id cd
300             qdcount ancount nscount arcount ){
301             $transporthash->{$headerfield}= $answerdb{$qname}->{$qtype}->
302             {'header'}->{$headerfield} if defined
303             $answerdb{$qname}->{$qtype}->{'header'}->{$headerfield} ;
304             }
305            
306             print "Sleeping for " . $answerdb{$qname}->{$qtype}->{'delay'}
307             . " seconds "
308             if $self->{verbose} && $answerdb{$qname}->{$qtype}->{'delay'};
309            
310             sleep ($answerdb{$qname}->{$qtype}->{'delay'});
311            
312             if (defined($answerdb{$qname}->{$qtype}->{'raw'})){
313             $transporthash->{'raw'}=$answerdb{$qname}->{$qtype}->{'raw'};
314             }
315            
316            
317             return ($rcode, $answerdb{$qname}->{$qtype}->{'answer'},
318             $answerdb{$qname}->{$qtype}->{'authority'},
319             $answerdb{$qname}->{$qtype}->{'additional'},
320             $transporthash);
321            
322             }
323            
324             return ("SERVFAIL");
325             };
326             print "Setting up server for: $ip,$port\n" if $self->{verbose};
327              
328              
329             my $ns;
330             $ns= Net::DNS::TestNS::Nameserver->new(
331             LocalPort => $port,
332             LocalAddr => $ip,
333             ReplyHandler => $reply_handler,
334             Verbose => $self->{verbose},
335             );
336            
337              
338             if (! $ns ){
339             $errorcondition="Could not create Nameserver object";
340             return 0;
341             }
342              
343             $self->{'serverinstance'}->[$servercount]->{'server'}=$ns;
344             $self->{'serverinstance'}->[$servercount]->{'_child_pid'}="_not_running";
345             $servercount++;
346             } #end looping over all servers.
347            
348              
349              
350             $self->{'servercount'}=$servercount;
351             #
352             # Now dynamically set up the reply handler.
353             #
354             #
355             return bless $self, $class;
356              
357             }
358              
359              
360              
361             sub run {
362             my $self=shift;
363             my $servercount=0;
364            
365             while ( $servercount < $self->{'servercount'} ){
366            
367             if ($self->{'serverinstance'}->[$servercount]->{'_child_pid'} ne
368             "_not_running" ){
369             print "This instance allready has a server running\n";
370             return ;
371             }
372            
373            
374             my $pid;
375             FORK: {
376             no strict 'subs'; # EAGAIN
377             if ($pid=fork) {# assign result of fork to $pid,
378             # see if it is non-zero.
379             # Parent process here
380             # Child pid is in $pid
381             print "Child Process: ".$pid."\n" if $self->{verbose};
382             $self->{'serverinstance'}->[$servercount]->{'_child_pid'}=$pid;
383            
384             } elsif (defined($pid)) {
385             # Child process here
386             #parent process pid is available with getppid
387             # exec will transfer control to the child process,
388             # and will finish (exit) when the tar is done.
389              
390             #Verbose level is set during construction.. The verbose method
391             # may have been called afterward.
392              
393             $self->{'serverinstance'}->[$servercount]->{'server'}->{"Verbose"}=$self->verbose;
394             $self->{'serverinstance'}->[$servercount]->{'server'}->main_loop;
395             } elsif ($! == EAGAIN) {
396             # EAGAIN is the supposedly recoverable fork error
397             sleep 5;
398             redo FORK;
399             }else {
400             #weird fork error
401             die "Can't fork: $!\n";
402             }
403             }
404            
405             $servercount++;
406             }
407             1;
408            
409             }
410            
411              
412             sub _preprocess_input {
413             my $self=shift;
414             my $outstring=shift;
415             my $filename=shift;
416             my $infile=new IO::File;
417             if ($infile->open("< $filename")) {
418             while (<$infile>){
419             if (/^(.*)()(.*)$/){
420             my $newfile=$3;
421             print "including $newfile\n" if $self->{verbose};
422             $outstring= $outstring. $1;
423             $outstring=$self->_preprocess_input($outstring,$newfile);
424             return 0 unless $outstring;
425             $outstring= $outstring. $4;
426             }else{
427             $outstring= $outstring. $_;
428             }
429             }
430             }else{
431             $errorcondition= "Could not open $filename during preporcessing";
432             return 0;
433             }
434             return $outstring;
435             }
436              
437              
438             sub verbose {
439             my $self=shift;
440             my $argument=shift;
441             $self->{verbose}=$argument if defined($argument);
442             return $self->{verbose};
443             }
444              
445             sub stop {
446             my $self=shift;
447             $self->medea(@_);
448             }
449              
450              
451              
452              
453             sub medea {
454             my $self=shift;
455              
456             my $servercount=0;
457            
458             while ( $servercount < $self->{'servercount'} ){
459            
460             if ($self->{'serverinstance'}->[$servercount]->{'_child_pid'} ne
461             '_not_running'){
462             if ( kill(15, $self->{'serverinstance'}->[$servercount]->{'_child_pid'}) != 1 ){
463             die "UNABLE TO KILL CHILDREN. KILL ".$self->{'serverinstance'}->[$servercount]->{'_child_pid'}." BY HAND";
464             }
465              
466             print "Killed ".$self->{'serverinstance'}->[$servercount]->{"_child_pid"}."\n" if $self->{verbose};
467             $self->{'serverinstance'}->[$servercount]->{"_child_pid"}="_not_running";
468              
469             } else {
470             # The child is not running...
471             }
472             $servercount++;
473             }
474             }
475            
476             sub DESTROY {
477             # Time for Greek Drama
478             # All children should be killed...
479             #
480             my $self=shift;
481             $self->medea;
482             }
483              
484              
485              
486              
487             sub AUTOLOAD {
488             my ($self) = @_;
489              
490             my $name = $AUTOLOAD;
491             $name =~ s/.*://;
492              
493             Carp::croak "$name: no such method" unless exists $self->{$name};
494            
495             no strict q/refs/;
496            
497             # AUTOLOADER sets and reads existing variables.
498             *{$AUTOLOAD} = sub {
499             my ($self, $new_val) = @_;
500            
501             if (defined $new_val) {
502             $self->{"$name"} = $new_val;
503             }
504            
505             return $self->{"$name"};
506             };
507            
508             goto &{$AUTOLOAD};
509             }
510              
511              
512              
513              
514              
515              
516             BEGIN {
517             $TESTNS_DTD_0='
518            
519              
520              
521            
522            
523            
524            
525              
526            
527            
528            
529              
530            
531              
532            
533            
534            
535            
536            
537            
538            
539            
540            
541            
542            
543            
544             ';
545              
546              
547             # Note: generateDTDpod.pl asumes the DTD is stored as $TESNS_DTD and
548             # has a rather "loose" way to determine the begin and the end of the
549             # string. Start: if (s/\$TESTNS_DTD=\'//){ End: if (s/\'\;//){
550              
551             $TESTNS_DTD='
552              
553            
554            
555            
556            
557            
558              
559            
560            
561              
562            
563            
564            
565              
566            
567            
568            
569              
570            
571            
572            
573              
574              
575            
576            
577              
578            
579            
580              
581            
582            
583              
584            
585            
586            
587            
588            
589            
590              
591            
592             ((question?,ans*,aut*,add*,opt?)
593             |raw)
594             )>
595              
596            
597            
598              
599              
600              
601            
602             ad?, cd?, qr?,rd?,tc?,id?,
603             qdcount?,ancount?,nscount?,arcount?)>
604              
605            
606            
607            
608            
609            
610            
611            
612            
613            
614            
615            
616            
617            
618              
619            
620            
621            
622            
623            
624            
625              
626            
627            
628            
629            
630            
631            
632            
633            
634            
635            
636              
637            
638            
639            
640            
641            
642              
643            
644            
645            
646            
647            
648            
649            
650            
651            
652              
653            
654            
655              
656            
657            
658            
659            
660            
661            
662              
663            
664            
665              
666            
667            
668              
669            
670            
671            
672            
673            
674            
675            
676            
677            
678              
679              
680            
681            
682              
683              
684             ';
685              
686             $TESTNS_DTD_1_0=$TESTNS_DTD;
687              
688             } #END BEGIN
689              
690              
691              
692              
693              
694              
695              
696              
697             =head1 NAME
698              
699             Net::DNS::TestNS - Perl extension for simulating simple Nameservers
700              
701             =head1 SYNOPSIS
702              
703             use Net::DNS::TestNS;
704            
705              
706             =head1 ABSTRACT
707              
708             Class for setting up "simple DNS" servers.
709              
710             =head1 DESCRIPTION
711              
712             Class to setup a number of nameservers that respond to specific DNS
713             queries (QNAME,QTYPE) by prespecified answers. This class is to be
714             used in test suites where you want to have servers to show predefined
715             behavior.
716              
717             If the server will do a lookup based on QNAME,QTYPE and return the
718             specified data. If there is no QNAME, QTYPE match the server will
719             return a SERVFAIL.
720              
721             A log will be written to STDERR it contains time, IP/PORT, QNAME,
722             QTYPE, RCODE
723              
724             =head2 Configuration file
725              
726             The class uses an XML file to read its configuration. The DTD is documented
727             in L.
728              
729              
730             The setup is split in a number of servers, each with a unique IP/port
731             number, each server has 1 or more QNAMEs it will respond to. Each
732             QNAME can have QTYPEs specified.
733              
734             For each QNAME,QTYPE an answer needs to be specified, response code
735             and header bits can be tweaked through the qtype attributes.
736              
737             The content of the packet can be specified through ans, aut and add
738             elements, each specifying one RR record to end up in the answer,
739             authority or additional section.
740              
741             The optional 'delay' attribute in the QTYPE element specifies how many
742             seconds the server should wait until an answer is returned.
743              
744              
745             If the query does not match against data specified in the
746             configuration a SERVFAIL is returned.
747              
748             =head2 new
749              
750              
751             my $server=Net::DNS::TestNS->new($configfile, {
752             Verbose => 1,
753             Validate => 1,
754             });
755              
756              
757              
758             Read the configuration files and bind to ports. One can use anywhere inside the configuration file to include
760             other XML configuration fragments.
761              
762             The second optional argument is hash that contains customization parameters.
763             Verbose boolean Makes the code more verbose.
764             Validate boolean Turns on XML validation based
765             on the DTD
766             The parser is flexible with
767             respect to the ordering
768             of some of the XML elements.
769             The DTD is not.
770             Validation is on by default.
771              
772              
773              
774             new returns the object reference on success and 0 on failure. On
775             failure the class variable $Net::DNS::TestNS::errorcondition is set.
776              
777              
778              
779             =head2 verbose
780              
781             $self->verbose(1);
782              
783             Sets verbosity at run time.
784              
785             =head2 run
786            
787             Spawns off the servers and process the data.
788            
789             =head2 medea
790              
791             Cleanup function that kills all the children spawned by the
792             instance. Also known by its alias 'stop'.
793              
794             =head1 Configuration file example
795              
796              
797            
798            
799            
800            
801            
802            
803            
804            
805            
806            
807            
808            
809            
810            
811            
812            
813            
814             bla.foo. 3600 IN TXT "TEXT"
815            
816            
817             bla.foo. 3600 IN TXT "Other text"
818            
819            
820            
821            
822            
823            
824            
825            
826            
827            
828            
829            
830            
831            
832            
833            
834            
835             07 74726967676572
836             03 666f6f
837             00
838            
839             00 01
840            
841             00 01
842            
843            
844              
845             c0 0c
846             00 01
847             00 01
848             00 00 00 05
849             00 04
850             0a 00 00 01
851            
852            
853            
854            
855            
856            
857              
858              
859             =head1 Known Deficiencies and TODO
860              
861             The module is based on Net::DNS::Nameserver. There is no way to
862             distinguish if the query came over TCP or UDP; besides UDP truncation
863             is not available in Net::DNS::Nameserver.
864              
865             Earlier versions of this script used a different DTD that had no
866             version number. The script only validates against version 1.0 of the
867             DTD but parses the old files.
868              
869              
870             ==head1 ALSO SEE
871             L, L, L
872              
873             =head1 AUTHOR
874              
875             Olaf Kolkman, Eolaf@net-dns.org
876              
877              
878             =head1 COPYRIGHT AND LICENSE
879              
880             Copyright (c) 2003-2005 RIPE NCC. Author Olaf M. Kolkman
881              
882             All Rights Reserved
883              
884             Permission to use, copy, modify, and distribute this software and its
885             documentation for any purpose and without fee is hereby granted,
886             provided that the above copyright notice appear in all copies and that
887             both that copyright notice and this permission notice appear in
888             supporting documentation, and that the name of the author not be
889             used in advertising or publicity pertaining to distribution of the
890             software without specific, written prior permission.
891              
892              
893             THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
894             ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
895             AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
896             DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
897             AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
898             OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
899              
900              
901             =cut
902              
903              
904              
905             1;
906             __END__