1use strict; use warnings; 2package Tie::DNS; 3$Tie::DNS::VERSION = '1.151560'; 4use Carp; 5use Socket; 6use Net::DNS; 7 8my $NEW_NETDNS = 0; 9if (Net::DNS->version >= 0.69) { 10 $NEW_NETDNS = 1; 11} 12 13my %config_rec_defaults = ( 14 'AAAA' => 'address', 15 'AFSDB' => 'subtype', 16 'A' => 'address', 17 'CNAME' => 'cname', 18 'EID' => 'rdlength', 19 'HINFO' => 'cpu', 20 'ISDN' => 'address', 21 'LOC' => 'version', 22 'MB' => 'madname', 23 'MG' => 'mgmname', 24 'MINFO' => 'rmailbx', 25 'MR' => 'newname', 26 'MX' => 'exchange', 27 'NAPTR' => 'order', 28 'NIMLOC' => 'rdlength', 29 'NSAP' => 'idp', 30 'NS' => 'nsdname', 31 'NULL' => 'rdlength', 32 'PTR' => 'ptrdname', 33 'PX' => 'preference', 34 'RP' => 'mbox', 35 'RT' => 'intermediate', 36 'SOA' => 'mname', 37 'SRV' => 'target', 38 'TXT' => 'txtdata' 39); 40 41my %config_type = ( 42 'AAAA' => ['address','ttl'], 43 'AFSDB' => ['subtype','ttl'], 44 'A' => ['address','ttl'], 45 'CNAME' => ['cname','ttl'], 46 'EID' => ['rdlength','rdata','ttl'], 47 'HINFO' => ['cpu','os','ttl'], 48 'ISDN' => ['address','subaddress','ttl'], 49 'LOC' => [ 50 'version','size','horiz_pre','vert_pre', 51 'latitude','longitude','latlon','altitude', 'ttl' 52 ], 53 'MB' => ['madname','ttl'], 54 'MG' => ['mgmname','ttl'], 55 'MINFO' => ['rmailbx','emailbx','ttl'], 56 'MR' => ['newname','ttl'], 57 'MX' => ['exchange','preference'], 58 'NAPTR' => [ 59 'order','preference','flags','service', 60 'regexp','replacement','ttl' 61 ], 62 'NIMLOC' => ['rdlength','rdata','ttl'], 63 'NSAP' => [ 64 'idp','dsp','afi','idi','dfi','aa', 65 'rsvd','rd','area','id','sel','ttl' 66 ], 67 'NS' => ['nsdname','ttl'], 68 'NULL' => ['rdlength','rdata','ttl'], 69 'PTR' => ['ptrdname','ttl'], 70 'PX' => ['preference','map822','mapx400','ttl'], 71 'RP' => ['mbox','txtdname','ttl'], 72 'RT' => ['intermediate','preference','ttl'], 73 'SOA' => [ 74 'mname','rname','serial','refresh', 75 'retry','expire','minimum','ttl' 76 ], 77 'SRV' => ['target','port','weight','priority','ttl'], 78 'TXT' => ['txtdata','ttl'] 79); 80 81sub TIEHASH { 82 my $class = shift; 83 my $args = shift; 84 85 if (defined $args) { 86 die 'Bad argument format' unless ref $args eq 'HASH'; 87 } else { 88 $args = {}; 89 } 90 91 my $self = {}; 92 bless $self, $class; 93 94 $self->{'dns'} = Net::DNS::Resolver->new(%{($args->{resolver_args} || {})}); 95 96 $self->args($args); 97 98 return $self; 99} 100 101sub STORE { 102 my $self = shift; 103 my $key = shift; 104 my $value = shift; 105 106 my $root_server = $self->get_root_server 107 or die 'Dynamic update attempted but no (or bad) domain specified.'; 108 109 my $update = Net::DNS::Update->new($self->_get_arg('domain')); 110 my $update_string = sprintf('%s. %s %s %s', 111 $key, $self->{'ttl'}, $self->{'lookup_type'}, $value); 112 $update->push('update', rr_add($update_string)); 113 114 my $res = Net::DNS::Resolver->new(%{($self->args->{resolver_args} || {})}); 115 $res->nameservers($root_server); 116 my $reply = $res->send($update); 117 if (defined $reply) { 118 if ($reply->header->rcode eq 'NOERROR') { 119 return $value; 120 } else { 121 $self->{'errstring'} = $self->{'dns'}->errorstring; 122 return 0; 123 } 124 } else { 125 $self->{'errstring'} = $self->{'dns'}->errorstring; 126 return 0; 127 } 128} 129 130sub args { 131 my $self = shift; 132 my $args = shift; 133 $self->{'args'} = $args; 134 $self->_process_args; 135} 136 137sub FETCH { 138 my $self = shift; 139 my $lookup = shift; 140 141 if ( $lookup =~ /^\d+\.\d+\.\d+\.\d+$/ ) { 142 return $self->do_reverse_lookup($lookup); 143 } else { 144 return $self->do_forward_lookup($lookup); 145 } 146} 147 148sub FIRSTKEY { 149 my $self = shift; 150 my @full_zone = $self->{'dns'}->axfr($self->{'root_name_server'}); 151 if (scalar(@full_zone) == 0) { 152 $self->{'errstring'} = $self->{'dns'}->errorstring; 153 return 0; 154 } 155 156 my @zone; 157 foreach my $rr (@full_zone) { 158 push @zone, $rr if $rr->type eq 'A'; 159 } 160 my $rr = shift @zone; 161 $self->{'zone'} = \@zone; 162 return $rr->name; 163} 164 165sub NEXTKEY { 166 my $self = shift; 167 my @zone = @{$self->{'zone'}}; 168 if (scalar(@zone) == 0) { 169 return 0; 170 } 171 my $rr = shift(@zone); 172 $self->{'zone'} = \@zone; 173 return $rr->name; 174} 175 176sub CLEAR { 177 my $self = shift; 178 179 # die ('dynamic DNS updates are not yet available.'); 180} 181 182sub DELETE { 183 my $self = shift; 184 die 'Tie::DNS: DELETE function not implemented'; 185} 186 187sub DESTROY { 188 my $self = shift; 189 190 #There isn't any real Net::DNS requirement to call anything when 191 #we go bye-bye, so we'll just go bye-bye quietly. 192} 193 194sub _process_args { 195 my $self = shift; 196 197 if (defined $self->_get_arg('domain')) { #find the root name 198 #server for this domain 199 $self->{'root_name_server'} = $self->get_root_server; 200 $self->{'dns'}->nameservers($self->{'root_name_server'}); 201 } 202 203 if (defined $self->_get_arg('multiple')) { #multiple return 204 #objects 205 #I don't think there's any setup required for this. 206 } 207 208 if (defined $self->_get_arg('all_fields')) { #all fields 209 #I don't think there's any setup for this one either. 210 } 211 212 if (defined $self->_get_arg('type')) { 213 if ( !defined($config_type{$self->_get_arg('type')})) { 214 die 'Bad record type: ' . $self->_get_arg('type'); 215 } 216 $self->{'lookup_type'} = $self->_get_arg('type'); 217 } else { 218 $self->{'lookup_type'} = 'A'; 219 } 220 221 if (defined $self->_get_arg('ttl')) { 222 $self->{'ttl'} = $self->_get_arg('ttl'); 223 } else { 224 $self->{'ttl'} = 86400; 225 } 226 227 if (my $cache_param = $self->_get_arg('cache')) { 228 eval { require Tie::Cache; }; 229 unless ($@) { 230 tie my %cache, 'Tie::Cache', $cache_param; 231 $self->{cache} = \%cache; 232 } 233 } else { 234 delete $self->{'cache'}; 235 } 236} 237 238sub get_root_server { 239 my $self = shift; 240 my $query = $self->{'dns'}->query($self->_get_arg('domain'), 'SOA'); 241 if ($query) { 242 foreach my $rr ($query->answer) { 243 print "Root: $rr->mname\n"; 244 return $rr->mname; 245 } 246 } else { 247 die 'Domain specified, but unable to get SOA record: ' 248 . $self->{'dns'}->errorstring; 249 } 250} 251 252sub _get_arg { 253 my $self = shift; 254 my $arg_name = shift; 255 return 0 unless defined $self->{'args'}; 256 257 return $self->{'args'}{$arg_name}; 258} 259 260sub do_reverse_lookup { 261 my $self = shift; 262 my $lookup = shift; 263 264 my $query = $self->{'dns'}->search($lookup); 265 my @retvals; 266 if ($query) { 267 foreach my $rr ($query->answer) { 268 next unless $rr->type eq 'PTR'; 269 push @retvals, $rr->ptrdname; 270 } 271 } else { 272 $self->{'errstring'} = $self->{'dns'}->errorstring; 273 return 0; 274 } 275 if (defined $self->_get_arg('multiple')) { 276 return \@retvals; 277 } else { 278 return shift @retvals; 279 } 280} 281 282sub do_forward_lookup { 283 my $self = shift; 284 my $lookup = shift; 285 my @things = $self->_lookup_to_thing($lookup); 286 if (defined $self->_get_arg('multiple')) { 287 return \@things; 288 } else { 289 return shift @things; 290 } 291} 292 293sub _lookup_to_thing { 294 my $self = shift; 295 my $lookup = shift; 296 297 my $ttl = 0; 298 my $now = time(); 299 my $cache = $self->{cache}; 300 301 if ($cache and my $old = $cache->{$lookup}) { 302 my ($expire, $ret) = @$old; 303 if ($now > $expire) { 304 delete $cache->{$lookup}; 305 } else { 306 return @$ret; 307 } 308 } 309 310 my $query = $self->{'dns'}->search($lookup, $self->{'lookup_type'}); 311 312 my @retvals; 313 if ($query) { 314 foreach my $rr ($query->answer) { 315 $ttl ||= $rr->{ttl}; 316 next unless $rr->type eq $self->{'lookup_type'}; 317 if (defined $self->_get_arg('all_fields')) { 318 my %fields; 319 foreach my $field (@{$config_type{$self->{'lookup_type'}}}) { 320 if ($NEW_NETDNS and $field eq 'address') { 321 $fields{$field} = inet_ntoa($rr->{$field}); 322 } else { 323 $fields{$field} = $rr->{$field}; 324 } 325 } 326 push @retvals,\%fields; 327 } else { 328 if ( $NEW_NETDNS and 329 $config_rec_defaults{$self->{'lookup_type'}} 330 eq 'address') { 331 push @retvals, 332 inet_ntoa( 333 $rr->{ 334 $config_rec_defaults{ 335 $self->{'lookup_type'} 336 } 337 } 338 ); 339 } else { 340 push 341 @retvals, 342 $rr->{$config_rec_defaults{$self->{'lookup_type'}}}; 343 } 344 } 345 } 346 } else { 347 $self->{'errstring'} = $self->{'dns'}->errorstring; 348 } 349 350 if ($cache) { 351 $cache->{$lookup} = [$now + $ttl, \@retvals]; 352 } 353 @retvals; 354} 355 356sub error { 357 my $self = shift; 358 return $self->{'errstring'}; 359} 360 3611; 362__END__ 363 364=head1 NAME 365 366Tie::DNS - Tie interface to Net::DNS 367 368=head1 SYNOPSIS 369 370 use Tie::DNS; 371 372 tie my %dns, 'Tie::DNS'; 373 374 print "$dns{'foo.bar.com'}\n"; 375 376 print "$dns{'208.180.41.1'}\n"; 377 378=head1 DESCRIPTION 379 380Net::DNS is a very complete, extensive and well-written module. 381It's completeness, however, makes many comman cases uses a bit 382wordy, code-wise. Tie::DNS is meant to make common DNS operations 383trivial, and more complex DNS operations easier. 384 385=head1 EXAMPLES 386 387=head2 Forward lookup 388 389See Above. 390 391=head2 Zone transfer 392 393Get all of the A records from 'foo.com'. (Sorry foo.com if 394everyone hits your name server testing this module. :-) 395 396 tie my %dns, 'Tie::DNS', {Domain => 'foo.com'}; 397 398 while (my ($name, $ip) = each %dns) { 399 print "$name = $ip\n"; 400 } 401 402This obviously requires that your host has zone transfer 403privileges with a name server hosting that zone. The 404zone transfer is initiated with the first each, keys or 405values operation. The tie operation does a SOA query 406to find the name server for the cited zone. 407 408=head2 Fetching multiple records 409 410Pass the configuration parameter of 'multiple' to any Perl true 411value, and all FETCH values from Tie::DNS will be an array 412reference of records. 413 414 tie my %dns, 'Tie::DNS', {multiple => 'true'}; 415 416 my $ip_ref = $dns{'cnn.com'}; 417 foreach (@{$ip_ref}) { 418 print "Address: $_\n"; 419 } 420 421=head2 Fetching records of type besides 'A' 422 423Pass the configuration parameter of 'type' to one of the 424Net::DNS supported record types causes all FETCHes to 425get records of that type. 426 427 tie my %dns, 'Tie::DNS', { 428 multiple => 'true', 429 type => 'SOA' 430 }; 431 432 my $ip_ref = $dns{'cnn.com'}; 433 foreach (@{$ip_ref}) { 434 print "primary nameserver: $_\n"; 435 } 436 437Here are the most popular types supported: 438 439 CNAME - Returns the records canonical name. 440 A - Returns the records address field. 441 TXT - Returns the descriptive text. 442 MX - Returns name of this mail exchange. 443 NS - Returns the domain name of the nameserver. 444 PTR - Returns the domain name associated with this record. 445 SOA - Returns the domain name of the original or 446 nameserver for this zone. 447 448 (The descriptions are right out of the Net::DNS POD.) 449 450See Net::DNS documentation for further information about these 451types and a comprehensive list of all available types. 452 453=head2 Fetching all of the fields associated with a given record type. 454 455 tie my %dns, 'Tie::DNS', {type => 'SOA', all_fields => 'true'}; 456 457 my $dns_ref = $dns{'cnn.com'}; 458 foreach my $field (keys %{$dns_ref}) { 459 print "$field = " . ${$dns_ref}{$field} . "\n"; 460 } 461 462This code fragment will print all of the SOA fields associated 463with cnn.com. 464 465=head2 Caching 466 467The argument 'cache' will cause the DNS results to be cached. The default 468is no caching. The 'cache' argument is passed through to L<Tie::Cache>. 469If L<Tie::Cache> cannot be loaded, caching will be disabled. Entries 470whose DNS TTL has expired will be re-queried automatically. 471 472 tie my %dns, 'Tie::DNS', {cache => 100}; 473 print "$dns{'cnn.com'}\n"; 474 print "$dns{'cnn.com'}\n"; ## cached! 475 476=head2 Getting all/different fields associated with a record 477 478 tie my %dns, 'Tie::DNS', {all_fields => 'true'}; 479 my $dns_ref = $dns{'cnn.com'}; 480 print $dns_ref->{'ttl'}, "\n"; 481 482=head2 Passing arguments to Net::DNS::Resolver->new() 483 484 tie my %from_localhost, 'Tie::DNS', { 485 resolver_args => { 486 nameservers => ['127.0.0.1'] 487 } 488 }; 489 print "$from_localhost{'test.local'}\n"; 490 491You can pass arbitrary arguments to the Net::DNS::Resolver constructor by 492setting the C<resolver_args> argument. In the example above, an alternative 493nameserver is used instead of the default one. 494 495=head2 Changing various arguments to the tie on the fly 496 497 tie my %dns, 'Tie::DNS', {type => 'SOA'}; 498 print "$dns{'cnn.com'}\n"; 499 500 tied(%dns)->args({type => 'A'}); 501 print "$dns{'cnn.com'}\n"; 502 503This code fragment first does an SOA query for cnn.com, and then 504changes the default mode to A queries, and displays that. 505 506=head2 Simple Dynamic Updates 507 508Assign into the hash, key DNS name, value IP address, to add a record 509to the zone in the domain argument. For instance: 510 511 tie my %dns, 'Tie::DNS', { 512 domain => 'realms.lan', 513 multiple => 'true' 514 }; 515 516 $dns{'food.realms.lan.'} = '131.22.40.1'; 517 518 foreach (@{$dns{'food'}}) { 519 print " $_\n"; 520 } 521 522=head2 Methods 523 524=head3 error 525 526Returns the last error, either from Tie::DNS or Net::DNS 527 528=head3 get_root_server 529 530Returns the root name server. 531 532=head3 do_forward_lookup 533 534Returns the results of a forward lookup. 535 536=head3 do_reverse_lookup 537 538Returns the results of a reverse lookup. 539 540=head3 args 541 542Change various arguments to the tie on the fly. 543 544=head1 TODO 545 546This release supports the basic functionality of 547Net::DNS. The 1.0 release will support the following: 548 549Different access methods for forward and reverse lookups. 550 551The 2.0 release will strive to support DNS security options. 552 553=head1 AUTHOR 554 555Dana M. Diederich <dana@realms.org> 556 557=head1 ACKNOWLEDGMENTS 558 559kevin Brintnall <kbrint@rufus.net> for Caching patch 560Alvar Freude <alvar@a-blast.org> for arguments to resolver patch 561Greg Myran <gmyran@drchico.net> for fixes for Net::DNS >= 0.69 562 563=head1 BUGS 564 565in-addr.arpa zone transfers aren't yet supported. 566 567Patches, flames, opinions, enhancement ideas are all welcome. 568 569=head1 COPYRIGHT 570Copyright (c) 2009,2013,2015 Dana M. Diederich. All Rights Reserved. 571This module is free software. It may be used, redistributed 572and/or modified under the terms of the Perl Artistic License 573 (see http://www.perl.com/perl/misc/Artistic.html) 574 575=cut 576