# $Id: 11-escapedchars.t 382 2005-06-15 13:01:08Z olaf $		 -*-perl-*-

use Test::More; 
use strict;

use Net::DNS qw(name2labels) ;
use Net::DNS::Packet qw(dn_expand);

# Perl 5.005 actually produces a warning during the run of the script
if ( $] < 5.006 ){
    diag ("\n\n\nWith this version of perl Net::DNS may give unpredictable results when dealing with\n".
	  "labels with non ascii or escaped data in them.\n".
	  "For instance domain names such as olaf\\.kolkman.net-dns.org\n".
	  "or \\255\\255.example.com\n\n\n");
    plan skip_all => "Escaping does not work with perl version $]" ;
}
else
{ 
    plan tests => 141;
}
#
# We test al sorts of escaped non-ascii characters. 
# This is all to be protocol conform... so to speak.

#
# The collection of tests is somewhat of a hodgepodge that tried to
# assess sensitivity to combinations of characters that the regular
# expressions and perl itself are sensitive to. (like \\\\\.\..)
# Development versions of the code tried to split a domain name in
# invidual labels by a regular expression. It made no sense to remove
# the more ackward tests as they have to pass anyway ...

my $message="Using the ";
$message.= $Net::DNS::HAVE_XS? " XS compiled ":" perl implemented ";
$message.="dn_expand function ";
diag ($message);


my $had_xs=$Net::DNS::HAVE_XS; 

my ($in,$out);

# Note that in perl the \\ in a presentation format can only be achieved
# through \\\\ .

# The hex codes are the names in wireformat:
# length octet. content octets, length octet, content , NULL octet



# Below are test combos, 1st and 2nd array elements are
# representations of the name. The output of the perl functions should
# yield the 2nd presentation (eg \037 gets presented as % )

# The 3rd element is a label count.
# The 4th element represents the number of octets per label
# The 5th element is a hexdump of the domain name in wireformat

# The optional 6th element is a boolean instructing to use the perl
# based dn_expand.  This because the conversion between the native
# dn_expand output to a perl varialbe provides some problems.


my @testcombos=(
 	[
	 'bla\255.foo.org', 
	 'bla\255.foo.org',
	 3,
	 [4,3,3],
#Wire:            4 b l a 0xff 3 f o o 3 o r g 0		  
	 "04626c61ff03666f6f036f726700" 
	],

	[
	 'bla.f\xa9oo.org', 
	 'bla.f\169oo.org',
	 3,
	 [3,4,3] ,
#Wire:            3 b l a 4 f 0xa9 o o 3 o r g 0		  
	 "03626c610466a96f6f036f726700" 		 
	],   # Note hex to decimal
	['bla.fo\.o.org',
	 'bla.fo\.o.org',
	 3,
	 [3,4,3],
#Wire:            3 b l a 4 f o . o 3 o r g 0		  
	 "03626c6104666f2e6f036f726700"
	],
	
	['bla\0000.foo.org',
	 'bla\0000.foo.org',
	 3,
	 [5,3,3],
#Wire:            5 b l a 0x00 0 3 f o o 3 o r g 0		  
	 "05626c61003003666f6f036f726700"  ,
	],
	
	['bla.fo\o.org',
	 'bla.foo.org',
	 3,
	 [3,3,3],
#Wire:            3 b l a 3 f o o 3 o r g 0   ignoring backslash on input	  
	 "03626c6103666f6f036f726700",
	],
	#drops the \
	['bla(*.foo.org',
	 'bla\(*.foo.org',
	 3,
	 [5,3,3],

#Wire:            5 b l a ( * 3 f o o 3 o r g 0		  
	 "05626c61282a03666f6f036f726700" 
	],
	
	[' .bla.foo.org',
	 '\032.bla.foo.org',
	 4,
	 [1,3,3,3],
	 "012003626c6103666f6f036f726700",
	],
	
	['\\\\a.foo',
	 '\\\\a.foo',
	 2,
	 [2,3],
#Wire:            2 \ a  3 f o o 0		  
	 "025c6103666f6f00"
	],


	['\\\\.foo',
	 '\\\\.foo',
	 2,
	 [1,3],
#Wire:            1 \   3 f o o 0		  
	 "015c03666f6f00",
	],
	
	['a\\..foo',
	 'a\\..foo',
	 2, 
	 [2,3],
#Wire:            2 a  . 3 f o o 0		  
	 "02612e03666f6f00"
	],

	['a\\.foo.org',
	 'a\\.foo.org',
	 2, [5,3],
#Wire:            5 a . f o o 3 o r g 0		  
	 "05612e666f6f036f726700" ,
	],
	
	['\..foo.org',
	 '\..foo.org',
	 3,
	 [1,3,3],		 

#Wire:            1  . 3 f o o 3 o r g 0		  
	 "012e03666f6f036f726700" ,
	],

        [
	 '\046.\046',
	 '\..\.',
	 2,
	 [1,1],
	 '012e012e00',
	 ],

	[ # all non \w characters :-) 
	  '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\032.\033\034\035\036\037\038\039\040\041\042\043\044\045\046\047\048.\058\059\060\061\062\063\064\065.\091\092\093\094\095\096.\123\124\125\126\127\128\129',
	  '\000\001\002\003\004\005\006\007\008\009\010\011\012\013\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\032.!\"#\$%&\'\(\)*+,-\./0.:\;<=>?\@A.[\\\\]^_`.{|}~\127\128\129',
	  5,
	  [33,16,8,6,7],
	  "21000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f20102122232425262728292a2b2c2d2e2f30083a3b3c3d3e3f4041065b5c5d5e5f60077b7c7d7e7f808100",
	],

);


foreach my $testinput (@testcombos){
	# test back and forth

	my @labels=name2labels( $testinput->[0]);


#	is (labels2name(@labels), $testinput->[1],"consistent name2labels labels2name for ". $testinput->[0]);


	# test number of labels
	is (@labels,$testinput->[2],"consistent labelcount ($testinput->[2])");
	# test number of elements within label.
	my $i=0;
	# Test length of each individual label
	while ($i<$testinput->[2]){
		is (length $labels[$i], $testinput->[3]->[$i],
		    "labellength for label $i equals ".$testinput->[3]->[$i]);
		$i++;
	}

	my $wire=Net::DNS::RR->_name2wire($testinput->[0]); 

	my $wireinhex=unpack("H*",$wire);
	is( $wireinhex,$testinput->[4], "Wireinhex for ".$testinput->[0] );
	# And now call DN_EXPAND
	my ($name,$offset);

	my $had_xs=$Net::DNS::HAVE_XS;

      SKIP: {
	    skip "No dn_expand_xs available", 1 unless $had_xs;
	    ($name,$offset)=dn_expand(\$wire,0);    
	    is ($name,$testinput->[1],"DN_EXPAND (xs) consistent");
	    
	    
	}
	
	$Net::DNS::HAVE_XS=0;
	($name,$offset)=dn_expand(\$wire,0);    
	is ($name,$testinput->[1],"DN_EXPAND (pp) consistent");
	$Net::DNS::HAVE_XS=$had_xs;
	
	
	
	
	
    }

 PERL_DN_EXPAND: { 
	if  ($had_xs  && !$Net::DNS::DN_EXPAND_ESCAPES ){
		diag ("\ndisabling XS based dns_expand for a moment.");
		$Net::DNS::HAVE_XS=0 ;
	}

#;; QUESTION SECTION
#;\\.eg.secret-wg.org.		IN	TXT
#
#;; ANSWER SECTION:
#\\.eg.secret-wg.org.	10	IN	TXT	"WildCard Match"
#
#;; AUTHORITY SECTION:
#eg.secret-wg.org.	600	IN	NS	ns.eg.secret-wg.org.
#
#;; ADDITIONAL SECTION:
#ns.eg.secret-wg.org.	600	IN	A	10.0.53.208
#

	my $UUencodedPacket='
c8 d5 85 00 00 01 00 01  00 01 00 01 02 5c 5c 02 
65 67 09 73 65 63 72 65  74 2d 77 67 03 6f 72 67 
00 00 10 00 01 c0 0c 00  10 00 01 00 00 00 0a 00 
0f 0e 57 69 6c 64 43 61  72 64 20 4d 61 74 63 68 
c0 0f 00 02 00 01 00 00  02 58 00 05 02 6e 73 c0 
0f c0 4c 00 01 00 01 00  00 02 58 00 04 0a 00 35 
d0                 
';
	
	$UUencodedPacket =~ s/\s*//g;
	my $packetdata = pack('H*',$UUencodedPacket);
	my $packet     = Net::DNS::Packet->new(\$packetdata);
	is( ($packet->answer)[0]->name,'\\\\\\\\.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\\\.eg.secret-wg.org");



# Now testing for the real esotheric stuff.
# domain names can contain NULL and space characters (on the wire)
# these should be properly expanded

# This only works if the dn_expand_XS()  is NOT used.

# The UUencoded packet contains a captured packet with this content:

#;; QUESTION SECTION:
#;\000.n\032ll.eg.secret-wg.org.	IN	TXT

#;; ANSWER SECTION:
#\000.n ll.eg.secret-wg.org. 0	IN	TXT	"NULL byte ownername"
#      ^ SPACE !!!
#;; AUTHORITY SECTION:
#eg.secret-wg.org.	600	IN	NS	ns.eg.secret-wg.org.

#;; ADDITIONAL SECTION:
#ns.eg.secret-wg.org.	600	IN	A	10.0.53.208

	$UUencodedPacket ='
 a6 58 85 00 00 01 00 01  00 01 00 01 01 00 04 6e  
 20 6c 6c 02 65 67 09 73  65 63 72 65 74 2d 77 67  
 03 6f 72 67 00 00 10 00  01 c0 0c 00 10 00 01 00  
 00 00 00 00 14 13 4e 55  4c 4c 20 62 79 74 65 20  
 6f 77 6e 65 72 6e 61 6d  65 c0 13 00 02 00 01 00  
 00 02 58 00 05 02 6e 73  c0 13 c0 55 00 01 00 01  
 00 00 02 58 00 04 0a 00  35 d0                    
';
	
	$UUencodedPacket =~ s/\s*//g;
	$packetdata = pack('H*',$UUencodedPacket);
	$packet     = Net::DNS::Packet->new(\$packetdata);
	is( ($packet->answer)[0]->name,'\000.n\\032ll.eg.secret-wg.org',"Correctly dealt with NULL bytes in domain names");
	
	
	
	


#slightly modified \\ .eg.secret-wg.org instead of \\\\.eg.secret-wg.org
#  That is escaped backslash space
	$UUencodedPacket='
c8 d5 85 00 00 01 00 01  00 01 00 01 02 5c 20 02 
65 67 09 73 65 63 72 65  74 2d 77 67 03 6f 72 67 
00 00 10 00 01 c0 0c 00  10 00 01 00 00 00 0a 00 
0f 0e 57 69 6c 64 43 61  72 64 20 4d 61 74 63 68 
c0 0f 00 02 00 01 00 00  02 58 00 05 02 6e 73 c0 
0f c0 4c 00 01 00 01 00  00 02 58 00 04 0a 00 35 
d0                 
';

	$UUencodedPacket =~ s/\s*//g;
	$packetdata = pack('H*',$UUencodedPacket);
	$packet     = Net::DNS::Packet->new(\$packetdata);




	is( ($packet->answer)[0]->name,'\\\\\\032.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\e.eg.secret-wg.org");
	if ( $had_xs && !$Net::DNS::HAVE_XS ){
		diag("\nContinuing to use the XS based dn_expand()\n") ;
		$Net::DNS::HAVE_XS=1;
		
	}
}

	
	
	
	
	
#slightly modified \\e.eg.secret-wg.org instead of \\\\.eg.secret-wg.org
	my $UUencodedPacket='
c8 d5 85 00 00 01 00 01  00 01 00 01 02 5c 65 02 
65 67 09 73 65 63 72 65  74 2d 77 67 03 6f 72 67 
00 00 10 00 01 c0 0c 00  10 00 01 00 00 00 0a 00 
0f 0e 57 69 6c 64 43 61  72 64 20 4d 61 74 63 68 
c0 0f 00 02 00 01 00 00  02 58 00 05 02 6e 73 c0 
0f c0 4c 00 01 00 01 00  00 02 58 00 04 0a 00 35 
d0                 
';

	$UUencodedPacket =~ s/\s*//g;
	my $packetdata = pack('H*',$UUencodedPacket);
	my $packet     = Net::DNS::Packet->new(\$packetdata);




	is( ($packet->answer)[0]->name,'\\\\e.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\e.eg.secret-wg.org");




#slightly modified \\\..eg.secret-wg.org instead of \\e.eg.secret-wg.org
	$UUencodedPacket='
c8 d5 85 00 00 01 00 01  00 01 00 01 02 5c 65 02 
65 67 09 73 65 63 72 65  74 2d 77 67 03 6f 72 67 
00 00 10 00 01 c0 0c 00  10 00 01 00 00 00 0a 00 
0f 0e 57 69 6c 64 43 61  72 64 20 4d 61 74 63 68 
c0 0f 00 02 00 01 00 00  02 58 00 05 02 6e 73 c0 
0f c0 4c 00 01 00 01 00  00 02 58 00 04 0a 00 35 
d0                 
';

	$UUencodedPacket =~ s/\s*//g;
	$packetdata = pack('H*',$UUencodedPacket);
	$packet     = Net::DNS::Packet->new(\$packetdata);



	$UUencodedPacket =~ s/\s*//g;
	$packetdata = pack('H*',$UUencodedPacket);
	$packet     = Net::DNS::Packet->new(\$packetdata);
	is( ($packet->answer)[0]->name,'\\\\e.eg.secret-wg.org',"Correctly dealt escaped backslash from wireformat \\\..eg.secret-wg.org");



	my $testrr=Net::DNS::RR->new(
		name => '\\e.eg.secret-wg.org',
		type         => 'TXT',
		txtdata      => '"WildCard Match"',
		ttl          =>  10,
		class        => "IN",
	);












	my $class = "IN"; 
	my $ttl = 43200; 
	my $name = 'def0au&lt.example.com'; 



	my @rrs = ( 
		{ #[0] 
			name => '\..bla\..example.com', 
			type => 'A', 
			address => '10.0.0.1', 
		}, { #[2]
			name => $name,
			type => 'AFSDB', 
			subtype => 1, 
			hostname =>'afsdb-hostname.example.com', 
		   }, 
		{ #[3]
			name => '\\.funny.example.com',
			type         => 'CNAME',
			cname        => 'cname-cn\244ame.example.com',
		}, 
		{   #[4]
			name => $name,
			type         => 'DNAME',
			dname        => 'dn\222ame.example.com',
		},
		{	#[9]
			name => $name,
			type         => 'MINFO',
			rmailbx      => 'minfo\.rmailbx.example.com',
			emailbx      => 'minfo\007emailbx.example.com',
		}, 

		{	#[13]
			name => $name,
			type         => 'NS',
			nsdname      => '\001ns-nsdname.example.com',
		},

		{	#[19]
			name => $name,
			type         => 'SOA',
			mname        => 'soa-mn\001ame.example.com',
			rname        => 'soa\.rname.example.com',
			serial       => 12345,
			refresh      => 7200,
			retry        => 3600,
			expire       => 2592000,
			minimum      => 86400,
		},
		
	);

#------------------------------------------------------------------------------
# Create the packet.
#------------------------------------------------------------------------------
	undef $packet;
	$packet = Net::DNS::Packet->new($name);
	ok($packet,         'Packet created');

	foreach my $data (@rrs) {
		$packet->push('answer', 
			      Net::DNS::RR->new(
				      ttl  => $ttl,
				      %{$data},
			      )
			     );
	}


#------------------------------------------------------------------------------
# Re-create the packet from data.
#------------------------------------------------------------------------------

	my $data = $packet->data;
	ok($data,            'Packet has data after pushes');

	undef $packet;
	$packet = Net::DNS::Packet->new(\$data);

	ok($packet,          'Packet reconstructed from data');

	my @answer = $packet->answer;

	ok(@answer && @answer == @rrs, 'Packet returned correct answer section');


	while (@answer and @rrs) {
		my $data = shift @rrs;
		my $rr   = shift @answer;
		my $type = $data->{'type'};
		foreach my $meth (keys %{$data}) {
			is($rr->$meth(), $data->{$meth}, "$type - $meth() correct");
		}
		
		my $rr2 = Net::DNS::RR->new($rr->string);
		is($rr2->string, $rr->string,   "$type - Parsing from string works");
	}