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