File Coverage

blib/lib/Net/DNS/Create.pm
Criterion Covered Total %
statement 66 82 80.4
branch 33 42 78.5
condition 8 14 57.1
subroutine 13 19 68.4
pod 0 9 0.0
total 120 166 72.2


line stmt bran cond sub pod time code
1             # Copyright (c) 2011-2013 David Caldwell, All Rights Reserved.
2              
3             package Net::DNS::Create;
4 3     3   213035 use strict; use warnings;
  3     3   6  
  3         425  
  3         17  
  3         6  
  3         362  
5              
6             our $VERSION='0.10.0';
7              
8             require Exporter;
9             our @ISA = qw(Exporter);
10             our @EXPORT = qw(domain master soa);
11             our @EXPORT_OK = qw(domain master full_host local_host email interval);
12              
13             my $kind;
14             our %config = (default_ttl=>'1h');
15             sub import {
16 3     3   4477 use Data::Dumper;
  3         40115  
  3         2378  
17 6     6   40 my $package = shift;
18 6   50     24 my $import_kind = shift // 'bind';
19              
20             # Tricky junk: If the first thing in our import list is "internal" then we just pass the rest to
21             # Exporter::export_to_level so that our plugins can include us back and import the full_host, email, and
22             # interval utility functions. Otherwise we pass the rest of the import args to the plugin's import so that
23             # conf options pass all the way down. In that case we don't pass anything to Exporter::export_to_level so
24             # that default export happens.
25 6 100       25 if ($import_kind ne 'internal') {
26 3         9 $kind = __PACKAGE__ . "::" . $import_kind;
27 3 100       227 eval "require $kind"; die "$@" if $@;
  3         16481  
28 1         8 $kind->import(@_);
29 1         7 %config = (%config, @_); # Keep around the config for ourselves so we get the default_ttl setting.
30 1         4 @_ = ();
31             }
32 4         710 __PACKAGE__->export_to_level(1, $package, @_);
33             }
34              
35             sub full_host($;$);
36             sub full_host($;$) {
37 51     51 0 78 my ($name,$domain) = @_;
38 51 50       283 $name eq '@' ? (defined $domain ? full_host($domain) : die "Need a domain with @") :
    100          
    100          
    100          
39             $name =~ /\.$/ ? $name : "$name." . (defined $domain ? full_host($domain) : '')
40             }
41              
42             sub local_host($$) {
43 0     0 0 0 my ($fq,$domain) = (full_host(shift), full_host(shift));
44 0 0       0 return '@' if $fq eq $domain;
45 0         0 my $local = $fq;
46 0 0       0 return $local if substr($local, -length($domain)-1, length($domain)+1, '') eq ".$domain";
47 0         0 return $fq;
48             }
49              
50             sub email($) {
51 1     1 0 3 my ($email) = @_;
52 1         6 $email =~ s/@/./g;
53 1         3 full_host($email);
54             }
55              
56             sub interval($) {
57 5 50 33 5 0 75 $_[0] =~ /(\d+)([hmsdw])/ && $1 * { s=>1, m=>60, h=>3600, d=>3600*24, w=>3600*24*7 }->{$2} || $_[0];
58             }
59              
60             sub txt($) {
61 5     5 0 9 my ($t) = @_;
62 5 100       39 return "$t" if length $t < 255;
63 1         2 my @part;
64 1         16 push @part, $1 while ($t =~ s/^(.{255})//);
65 1         7 (@part, $t);
66             }
67              
68 3     3   3205 use Hash::Merge::Simple qw(merge);
  3         2558  
  3         224  
69 3     3   4999 use Net::DNS::RR;
  3         137077  
  3         2752  
70             sub domain($@) {
71 1     1 0 794 my ($domain, @entry_hashes) = @_;
72 1         2 my $entries = {};
73 1         4 for my $e (@entry_hashes) {
74 2         152 $entries = merge($entries, $e);
75             }
76              
77 1         86 my $fq_domain = full_host($domain);
78 1         7 my $ttl = interval($config{default_ttl});
79 1         8 $entries = [ map { my $node = $_;
  18         21076  
80 18         45 my $fqdn = full_host($_,$domain);
81 23         592 map {
82 18         61 my $rr = lc $_;
83 23         47 my $val = $entries->{$node}->{$_};
84 23         82 my %common = (name => $fqdn,
85             ttl => $ttl,
86             type => uc $rr);
87 5         173 $rr eq 'a' || $rr eq 'cname' || $rr eq 'rp' || $rr eq 'soa' ?
88             Net::DNS::RR->new(%common,
89             $rr eq 'a' ? (address => $val) :
90             $rr eq 'cname' ? (cname => full_host($val, $fq_domain)) :
91             #$rr eq 'txt' ? (char_str_list => [txt($val)]) :
92             $rr eq 'rp' ? (mbox => email($val->[0]),
93             txtdname => full_host($val->[1], $fq_domain)) :
94             $rr eq 'soa' ? (mname => full_host($val->{primary_ns}, $domain),
95             rname => $val->{rp_email},
96             serial => $val->{serial} // 0,
97             refresh => interval($val->{refresh}),
98             retry => interval($val->{retry}),
99             expire => interval($val->{expire}),
100             minimum => interval($val->{min_ttl})) :
101             die "can't happen") :
102              
103 1         6 $rr eq 'txt' ? map { Net::DNS::RR->new(%common, char_str_list => [txt($_)]) } sort {$a cmp $b} (ref $val eq 'ARRAY' ? @{$val} : $val) :
  1         6  
  2         1861  
104 2         1607 $rr eq 'mx' ? map { Net::DNS::RR->new(%common, preference => $_, exchange => full_host($val->{$_}, $fq_domain)) } sort(keys %$val) :
105 1         2 $rr eq 'ns' ? map { Net::DNS::RR->new(%common, nsdname => $_) } sort(@$val) :
106             $rr eq 'srv' ? map {
107 23 50 100     272 my $target = $_;
    100 50        
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
108 1   50     16 map {
      50        
109 0         0 Net::DNS::RR->new(%common,
110             priority => $_->{priority} // 0,
111             weight => $_->{weight} // 0,
112             port => $_->{port},
113             target => full_host($target))
114 1 50       7 } sort {$a cmp $b} (ref $val->{$_} eq 'ARRAY' ? @{$val->{$_}} : $val->{$_})
  0         0  
115             } sort(keys %$val) :
116             die uc($rr)." is not supported yet :-("; # Remember to add support for all the backends, too.
117 18         28 } keys %{$entries->{$node}};
118             } keys %$entries ];
119              
120 1         128 $kind->domain($fq_domain, $entries);
121             }
122              
123             sub master {
124 0     0 0   $kind->master(@_);
125             }
126              
127             sub list_files() {
128 3     3   36 no warnings;
  3         8  
  3         504  
129 0     0 0   *domain = *main::domain = \&{"$kind\::domain_list"};
  0            
130 0           *master = *main::master = \&{"$kind\::master_list"};
  0            
131             }
132              
133             sub list_domains() {
134 3     3   19 no warnings;
  3         6  
  3         568  
135 0     0 0   *domain = *main::domain = sub { print "$_[0]\n" };
  0     0      
136 0     0     *master = *main::master = sub {};
  0            
137             }
138              
139              
140             1;
141             __END__