# $Id: 11-escapedchars.t 949 2011-10-31 13:58:38Z willem $ -*-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 => 134;
}
#
# 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.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<.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");
}