1package Net::DNS::Domain; 2 3use strict; 4use warnings; 5 6our $VERSION = (qw$Id: Domain.pm 1841 2021-06-23 20:34:28Z willem $)[2]; 7 8 9=head1 NAME 10 11Net::DNS::Domain - DNS domains 12 13=head1 SYNOPSIS 14 15 use Net::DNS::Domain; 16 17 $domain = Net::DNS::Domain->new('example.com'); 18 $name = $domain->name; 19 20=head1 DESCRIPTION 21 22The Net::DNS::Domain module implements a class of abstract DNS 23domain objects with associated class and instance methods. 24 25Each domain object instance represents a single DNS domain which 26has a fixed identity throughout its lifetime. 27 28Internally, the primary representation is a (possibly empty) list 29of ASCII domain name labels, and optional link to an origin domain 30object topologically closer to the DNS root. 31 32The computational expense of Unicode character-set conversion is 33partially mitigated by use of caches. 34 35=cut 36 37 38use integer; 39use Carp; 40 41 42use constant ASCII => ref eval { 43 require Encode; 44 Encode::find_encoding('ascii'); 45}; 46 47use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] 48 Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); 49}; 50 51use constant LIBIDN2 => defined eval { require Net::LibIDN2 }; 52use constant IDN2FLAG => LIBIDN2 ? &Net::LibIDN2::IDN2_NFC_INPUT + &Net::LibIDN2::IDN2_NONTRANSITIONAL : 0; 53use constant LIBIDN => LIBIDN2 ? undef : defined eval { require Net::LibIDN }; 54 55# perlcc: address of encoding objects must be determined at runtime 56my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: 57my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. 58 59 60=head1 METHODS 61 62=head2 new 63 64 $object = Net::DNS::Domain->new('example.com'); 65 66Creates a domain object which represents the DNS domain specified 67by the character string argument. The argument consists of a 68sequence of labels delimited by dots. 69 70A character preceded by \ represents itself, without any special 71interpretation. 72 73Arbitrary 8-bit codes can be represented by \ followed by exactly 74three decimal digits. 75Character code points are ASCII, irrespective of the character 76coding scheme employed by the underlying platform. 77 78Argument string literals should be delimited by single quotes to 79avoid escape sequences being interpreted as octal character codes 80by the Perl compiler. 81 82The character string presentation format follows the conventions 83for zone files described in RFC1035. 84 85Users should be aware that non-ASCII domain names will be transcoded 86to NFC before encoding, which is an irreversible process. 87 88=cut 89 90my ( %escape, %unescape ); ## precalculated ASCII escape tables 91 92our $ORIGIN; 93my ( $cache1, $cache2, $limit ) = ( {}, {}, 100 ); 94 95sub new { 96 my ( $class, $s ) = @_; 97 croak 'domain identifier undefined' unless defined $s; 98 99 my $index = join '', $s, $class, $ORIGIN || ''; # cache key 100 my $cache = $$cache1{$index} ||= $$cache2{$index}; # two layer cache 101 return $cache if defined $cache; 102 103 ( $cache1, $cache2, $limit ) = ( {}, $cache1, 500 ) unless $limit--; # recycle cache 104 105 my $self = bless {}, $class; 106 107 $s =~ s/\\\\/\\092/g; # disguise escaped escape 108 $s =~ s/\\\./\\046/g; # disguise escaped dot 109 110 my $label = $self->{label} = ( $s eq '@' ) ? [] : [split /\056/, _encode_utf8($s)]; 111 112 foreach (@$label) { 113 croak qq(empty label in "$s") unless length; 114 115 if ( LIBIDN2 && UTF8 && /[^\000-\177]/ ) { 116 my $rc = 0; 117 $_ = Net::LibIDN2::idn2_to_ascii_8( $_, IDN2FLAG, $rc ); 118 croak Net::LibIDN2::idn2_strerror($rc) unless $_; 119 } 120 121 if ( LIBIDN && UTF8 && /[^\000-\177]/ ) { 122 $_ = Net::LibIDN::idn_to_ascii( $_, 'utf-8' ); 123 croak 'name contains disallowed character' unless $_; 124 } 125 126 s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes 127 s/\134(.)/$1/g; # restore character escapes 128 croak qq(label too long in "$s") if length > 63; 129 } 130 131 $$cache1{$index} = $self; # cache object reference 132 133 return $self if $s =~ /\.$/; # fully qualified name 134 $self->{origin} = $ORIGIN || return $self; # dynamically scoped $ORIGIN 135 return $self; 136} 137 138 139=head2 name 140 141 $name = $domain->name; 142 143Returns the domain name as a character string corresponding to the 144"common interpretation" to which RFC1034, 3.1, paragraph 9 alludes. 145 146Character escape sequences are used to represent a dot inside a 147domain name label and the escape character itself. 148 149Any non-printable code point is represented using the appropriate 150numerical escape sequence. 151 152=cut 153 154sub name { 155 my ($self) = @_; 156 157 return $self->{name} if defined $self->{name}; 158 return unless defined wantarray; 159 160 my @label = shift->_wire; 161 return $self->{name} = '.' unless scalar @label; 162 163 for (@label) { 164 s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; 165 } 166 167 return $self->{name} = _decode_ascii( join chr(46), @label ); 168} 169 170 171=head2 fqdn 172 173 @fqdn = $domain->fqdn; 174 175Returns a character string containing the fully qualified domain 176name, including the trailing dot. 177 178=cut 179 180sub fqdn { 181 my $name = &name; 182 return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot 183} 184 185 186=head2 xname 187 188 $xname = $domain->xname; 189 190Interprets an extended name containing Unicode domain name labels 191encoded as Punycode A-labels. 192 193If decoding is not possible, the ACE encoded name is returned. 194 195=cut 196 197sub xname { 198 my $name = &name; 199 200 if ( LIBIDN2 && UTF8 && $name =~ /xn--/i ) { 201 my $self = shift; 202 return $self->{xname} if defined $self->{xname}; 203 my $u8 = Net::LibIDN2::idn2_to_unicode_88($name); 204 return $self->{xname} = $u8 ? $utf8->decode($u8) : $name; 205 } 206 207 if ( LIBIDN && UTF8 && $name =~ /xn--/i ) { 208 my $self = shift; 209 return $self->{xname} if defined $self->{xname}; 210 return $self->{xname} = $utf8->decode( Net::LibIDN::idn_to_unicode $name, 'utf-8' ); 211 } 212 return $name; 213} 214 215 216=head2 label 217 218 @label = $domain->label; 219 220Identifies the domain by means of a list of domain labels. 221 222=cut 223 224sub label { 225 my @label = shift->_wire; 226 for (@label) { 227 s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; 228 _decode_ascii($_); 229 } 230 return @label; 231} 232 233 234=head2 string 235 236 $string = $object->string; 237 238Returns a character string containing the fully qualified domain 239name as it appears in a zone file. 240 241Characters which are recognised by RFC1035 zone file syntax are 242represented by the appropriate escape sequence. 243 244=cut 245 246sub string { 247 my $name = &name; 248 return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot 249} 250 251 252=head2 origin 253 254 $create = Net::DNS::Domain->origin( $ORIGIN ); 255 $result = &$create( sub{ Net::DNS::RR->new( 'mx MX 10 a' ); } ); 256 $expect = Net::DNS::RR->new( "mx.$ORIGIN. MX 10 a.$ORIGIN." ); 257 258Class method which returns a reference to a subroutine wrapper 259which executes a given constructor in a dynamically scoped context 260where relative names become descendents of the specified $ORIGIN. 261 262=cut 263 264my $placebo = sub { my $constructor = shift; &$constructor; }; 265 266sub origin { 267 my ( $class, $name ) = @_; 268 my $domain = defined $name ? Net::DNS::Domain->new($name) : return $placebo; 269 270 return sub { # closure w.r.t. $domain 271 my $constructor = shift; 272 local $ORIGIN = $domain; # dynamically scoped $ORIGIN 273 &$constructor; 274 } 275} 276 277 278######################################## 279 280sub _decode_ascii { ## ASCII to perl internal encoding 281 local $_ = shift; 282 283 # partial transliteration for non-ASCII character encodings 284 tr 285 [\040-\176\000-\377] 286 [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; 287 288 my $z = length($_) - length($_); # pre-5.18 taint workaround 289 return ASCII ? substr( $ascii->decode($_), $z ) : $_; 290} 291 292 293sub _encode_utf8 { ## perl internal encoding to UTF8 294 local $_ = shift; 295 296 # partial transliteration for non-ASCII character encodings 297 tr 298 [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~\000-\377] 299 [\040-\176\077] unless ASCII; 300 301 my $z = length($_) - length($_); # pre-5.18 taint workaround 302 return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; 303} 304 305 306sub _wire { 307 my $self = shift; 308 309 my $label = $self->{label}; 310 my $origin = $self->{origin}; 311 return ( @$label, $origin ? $origin->_wire : () ); 312} 313 314 315%escape = eval { ## precalculated ASCII escape table 316 my %table = map { ( chr($_) => chr($_) ) } ( 0 .. 127 ); 317 318 foreach my $n ( 0 .. 32, 34, 92, 127 .. 255 ) { # \ddd 319 my $codepoint = sprintf( '%03u', $n ); 320 321 # transliteration for non-ASCII character encodings 322 $codepoint =~ tr [0-9] [\060-\071]; 323 324 $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; 325 } 326 327 foreach my $n ( 40, 41, 46, 59 ) { # character escape 328 $table{chr($n)} = pack( 'C2', 92, $n ); 329 } 330 331 return %table; 332}; 333 334 335%unescape = eval { ## precalculated numeric escape table 336 my %table; 337 338 foreach my $n ( 0 .. 255 ) { 339 my $key = sprintf( '%03u', $n ); 340 341 # transliteration for non-ASCII character encodings 342 $key =~ tr [0-9] [\060-\071]; 343 344 $table{$key} = pack 'C', $n; 345 } 346 $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape 347 348 return %table; 349}; 350 351 3521; 353__END__ 354 355 356######################################## 357 358=head1 BUGS 359 360Coding strategy is intended to avoid creating unnecessary argument 361lists and stack frames. This improves efficiency at the expense of 362code readability. 363 364Platform specific character coding features are conditionally 365compiled into the code. 366 367 368=head1 COPYRIGHT 369 370Copyright (c)2009-2011,2017 Dick Franks. 371 372All rights reserved. 373 374 375=head1 LICENSE 376 377Permission to use, copy, modify, and distribute this software and its 378documentation for any purpose and without fee is hereby granted, provided 379that the above copyright notice appear in all copies and that both that 380copyright notice and this permission notice appear in supporting 381documentation, and that the name of the author not be used in advertising 382or publicity pertaining to distribution of the software without specific 383prior written permission. 384 385THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 386IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 387FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 388THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 389LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 390FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 391DEALINGS IN THE SOFTWARE. 392 393 394=head1 SEE ALSO 395 396L<perl>, L<Net::DNS>, L<Net::LibIDN2>, RFC1034, RFC1035, RFC5891, Unicode TR#16 397 398=cut 399 400