--- a/lib/DNS/Vi.pm Thu Jul 14 10:30:58 2016 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,317 +0,0 @@
-package DNS::Vi;
-use 5.0101;
-use strict;
-use warnings;
-use if $ENV{DEBUG} // '' eq 'dnsvi' => 'Smart::Comments';
-use Digest::SHA qw(sha512_hex);
-use File::Temp;
-use Net::DNS;
-use Term::ReadKey;
-use base 'Exporter';
-use if $] >= 5.020, experimental => 'smartmatch';
-
-our @EXPORT = qw(ttl2h h2ttl parse delta nice edit update show get_key
- get_auth_info);
-our @EXPORT_OK = ();
-
-# the sort order for the records of the same label
-my %ORDER = map { state $n = 0; $_ => ++$n } qw(SOA NS TXT MX A AAAA SSHFP);
-
-sub h2ttl(_);
-
-# input $arg - hash with options
-# $data - a long string with the zone data
-sub parse {
- my %arg = %{ pop @_ } if ref $_[-1] eq ref {};
- my $data = shift;
- my @lines = split /\n/, $data;
-
- my @zone;
- my ($origin, $ttl, $last_label, $soa_seen);
-
- $_ = '';
- foreach (@lines) {
- # simplificated comment remover
- # after the comment character no '"' is allowed!
-# s{^\s*;.*$}{}; # strip comment lines
-# s{\s*;[^"]*$}{}; # strip trailing comments
-
- # see https://regex101.com/r/cG6fK3/2
- s{\s*(?:;)(?:(?:[^"]|"[^"]*")*$)}{};
- state $line;
- if (my $range = /(.*)\(\s*$/ .. /(.*)\)\s*/) {
- $line .= defined $1 ? $1 : $_;
- next unless $range =~ /E0$/;
- }
- if (defined $line) {
- $_ = $line; # accumulated continuation line
- $line = undef;
- }
- s{\s*$}{}; # strip off trailing spaces
- given ($_) {
- when (m{^\s*$}) { next }
- when (m{^\s*\$ORIGIN\s+(\S+)}) { $origin = $1 }
- when (m{^\s*\$TTL\s+(\S+)}) { $ttl = $1 }
- when (
- m{^(?:(?<label>\S+)(?=\s))?
- (?:\s+(?<ttl>\d[\dwdmhs]*(?=\s+)))?
- (?:\s+(?:(?:IN|ANY)\s+)?(?<rrtype>[a-z]\S*(?=\s+)))
- \s+(?<data>.*)
- }ix
- )
- {
- my %rrset = (
- label => $last_label =
- defined $+{label}
- ? $+{label} eq '@'
- ? $origin
- : $+{label}
- : $last_label,
- ttl => h2ttl($+{ttl} // $ttl),
- rrtype => uc $+{rrtype},
- data => $+{data},
- );
- next if $rrset{rrtype} ~~ $arg{-skip};
-
- if ($rrset{rrtype} eq 'SOA') {
- next if $soa_seen++;
- }
-
- # label ergänzen, wenn nicht FQDN
- $rrset{label} .= ".$origin"
- unless substr($rrset{label}, -1) eq '.';
-
- given ($rrset{rrtype}) {
-
- # origin steht im SOA
- when ('SOA') {
- $origin = $rrset{label};
- my ($primary, $hostmaster, $serial, $refresh, $retry,
- $expire, $minttl)
- = split ' ', $rrset{data};
-
- $_ .= ".$origin" foreach grep !/\.$/ => $primary,
- $hostmaster;
-
- $rrset{data} = join ' ',
- $primary, $hostmaster, $serial,
- map { h2ttl } $refresh, $retry, $expire, $minttl;
- }
-
- # bei einigen RRs müssen wir die Daten korrigieren
- when ([qw/CNAME MX NS PTR SOA/]) {
- $rrset{data} =~ s/\@/$origin/g;
- $rrset{data} .= ".$origin"
- unless substr($rrset{data}, -1) eq '.';
- }
- }
- my $id = sha512_hex(join "\0",
- map { $_ => $rrset{$_} } sort keys %rrset);
- push @zone, { id => $id, rrset => \%rrset };
- ### x: $zone[-1]
- }
- }
- }
-
- return @zone;
-}
-
-sub ttl2h {
- my $seconds = shift;
- my @out;
- my @units = ([w => 604800], [d => 86400], [h => 3600], [m => 60], [s => 1]);
-
- foreach (@units) {
- my $x = int($seconds / $_->[1]);
- push @out, "$x$_->[0]" if $x;
- $seconds %= $_->[1] or last;
- }
-
- return join '', @out;
-}
-
-sub h2ttl(_) {
- my $ttl = shift;
- my $out;
- my %factor = (
- w => 604800,
- d => 86400,
- h => 3600,
- m => 60,
- s => 1,
- );
-
- while ($ttl =~ m{(\d+)([wdhms])}g) {
- $out += $1 * $factor{$2};
- }
-
- return $out // $ttl;
-}
-
-sub nice {
-
- # get a list of { id => $id, rrset => \%rrset }
- # we do a schwartz transformation here
- # [ reverse LABEL, RRSET ]
- my @zone = map { $_->[1] }
- sort {
- $a->[0] cmp $b->[0]
- or length $a->[1]{label} <=> length $b->[1]{label}
- or ($ORDER{ $a->[1]{rrtype} } // 99)
- <=> ($ORDER{ $b->[1]{rrtype} } // 99)
- }
- map { [scalar reverse($_->{label}), $_] } map { $_->{rrset} } @_;
-
- my @out;
- my $origin = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{label};
- my $ttl = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{ttl};
- my $len1 =
- (sort { $a <=> $b } map { index $_->{label}, '.' } @zone)[-1];
- my $len2 = (sort { $a <=> $b } map { length $_->{rrtype} } @zone)[-1];
- push @out, "\$ORIGIN $origin", "\$TTL " . ttl2h($ttl);
-
- my $print = sub {
- my %r = %{ +shift };
- state $last_label;
-
- $r{label} = '@' if $r{label} eq $origin;
- $r{label} =~ s{\.\Q$origin\E$}{};
- $r{data} =~ s{\.\Q$origin\E$}{}
- if $r{rrtype} ~~ [qw(CNAME MX SOA PTR)];
- $r{data} =~ s{\Q$origin\E$}{\@} if $r{rrtype} ~~ [qw(CNAME MX)];
- $r{ttl} = $r{ttl} == $ttl ? '' : ttl2h($r{ttl});
- $r{label} = do {
- if (defined $last_label and $r{label} eq $last_label) { '' }
- else { $last_label = $r{label} }
- };
-
- return sprintf '%-*s %6s %-*s %s',
- $len1 => $r{label},
- $r{ttl},
- $len2 => $r{rrtype},
- $r{data};
- };
- push @out, '; IF YOU EDIT the SOA record, INCREASE the serial number too!';
- push @out, $print->($_) foreach @zone;
- return join "\n", @out, '';
-}
-
-sub delta {
- my ($zone1, $zone2) = @_;
- my %zone1 = map { $_->{id}, $_->{rrset} } @$zone1;
- my %zone2 = map { $_->{id}, $_->{rrset} } @$zone2;
- my @keys1 = keys %zone1;
- my @keys2 = keys %zone2;
- delete @zone1{@keys2};
- delete @zone2{@keys1};
-
- my (@add, @del);
- push @add, "@{$_}{qw/label ttl rrtype data/}" foreach values %zone2;
- push @del, "@{$_}{qw/label ttl rrtype data/}" foreach values %zone1;
-
- return () if (!@add and !@del);
- return (add => \@add, del => \@del);
-}
-
-sub edit {
- my %arg = %{ pop @_ } if ref $_[-1] eq ref {};
- my @zone = @_;
-
- # first make a backup copy
- my $tmp = File::Temp->new();
- $tmp->print(nice @zone);
- $tmp->say('; vim:tw=0:');
- $tmp->flush();
-
- system $arg{-editor} => $tmp->filename;
- $tmp->seek(0, 0);
- ${ $arg{-backup} } = $tmp if $arg{-backup};
- return parse(do { local $/ = undef; <$tmp> }, { -skip => $arg{-skip} });
-}
-
-sub show {
- my ($add, $del) = @_;
- my @out = ((map { " - $_ " } @$del), (map { " + $_ " } @$add));
- return @out;
-}
-
-sub update {
- my %arg = %{ pop @_ } if ref $_[-1] eq ref {};
- my ($zone1, $add, $del) = @_;
-
- my $orig_soa =
- (grep { $_->{rrtype} eq 'SOA' } map { $_->{rrset} } @$zone1)[0];
-
- my @cmds = (
- $arg{-local} ? () : "server $arg{-server}",
- "prereq yxrrset @{$orig_soa}{qw{label rrtype data}}",
- (map { "update delete $_" } @$del),
- (map { "update add $_" } @$add),
- 'send',
- 'answer',
- );
- if ($arg{-dry}) {
- return say join "\n", '', @cmds, '' if $arg{-dry};
- }
- my @nsupdate = (
- 'nsupdate',
- defined $arg{-debug} ? ('-d') : (),
- defined $arg{-key} ? (-k => $arg{-key}) : (),
- defined $arg{-local} ? ('-l') : (),
- );
-
- open(my $nsupdate, '|-') or do {
- exec @nsupdate;
- die "Can't exec @nsupdate: $!\n";
- };
- say $nsupdate join "\n", @cmds;
- close($nsupdate);
- say "nsupdate returned $?";
- return $? ? undef : 1;
-}
-
-sub save {
- my ($zone, $file) = @_;
- open(my $fh, '>', $file) or die "Can't open >$file: $!\n";
- print $fh nice @$zone;
- close($fh);
-
-}
-
-sub get_key {
- ReadMode 'cbreak';
- local $/ = \1;
- my $x = <STDIN>;
- ReadMode 'restore';
- print "\n";
- return $x;
-}
-
-sub get_auth_info {
- my $name = shift;
- my $server = shift;
- my %auth = (zone => undef, master => undef);
- state $resolver = Net::DNS::Resolver->new(
- defined $server ? (nameservers => [$server]) : ()
- );
- my $response = $resolver->send($name, 'SOA')
- or die $resolver->errorstring, "\n";
-
- # use Data::Dumper;
- # die Dumper $response;
-
- if (my @soa = grep { $_->type eq 'SOA' } $response->answer,
- $response->authority)
- {
- die "got multiple soa records\n" if @soa > 1;
- my $soa = $soa[0];
- return (
- name => $soa->name,
- mname => $soa->mname,
- );
- }
-
- return $response->authority;
-}
-
-1;