--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/DNS/Vi.pm	Thu May 22 23:34:23 2014 +0200
@@ -0,0 +1,175 @@
+use 5.010;
+use strict;
+use warnings;
+use if $ENV{DEBUG}//''  eq 'vidns' => 'Smart::Comments';
+use Digest::SHA qw(sha512_hex);
+
+use base 'Exporter';
+
+our @EXPORT = qw(ttl2h h2ttl parse delta);
+our @EXPORT_OK = ();
+
+sub parse {
+    my $data = join '', @_;
+    my @lines = split /\n/, $data;
+
+    my @zone;
+    my ($origin, $ttl, $last_label, $soa_seen);
+
+    foreach (@lines) {
+        s{;.*$}{};
+        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+(?<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},
+                );
+
+                if ($rrset{rrtype} eq 'SOA') {
+                    next if $soa_seen;
+                    $soa_seen = 1;
+                }
+
+                # 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};
+
+                        # fix the nameserver name
+                        $rrset{data} =~ s{^(\S+[^.])(?=\s)}{$1.$origin};
+
+                        # fix the hostmaster address
+                        $rrset{data} =~ s{^\S+\s+\K(\S+[^.])(?=\s)}{$1.$origin};
+                    }
+
+                    # bei einigen RRs müssen wir die Daten korrigieren
+                    when ([qw/MX NS PTR/]) {
+                        $rrset{data} .= ".$origin"
+                          unless substr($rrset{data}, -1) eq '.';
+                    }
+                }
+                my $id = sha512_hex(sort %rrset);
+                push @zone, { id => $id, rrset => \%rrset };
+            }
+        }
+    }
+
+    # list of {
+    #	id => $id,
+    #	rrset => { label => …, ttl => …, rrtype => …, data => … }
+    # }
+    ### @zone
+    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 }
+    my @zone =
+      sort {
+        length $a->{label} <=> length $b->{label}
+          or $a->{label}
+          cmp $b->{label}
+      } map { $_->{rrset} } @_;
+
+    my @out;
+    my $origin = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{label};
+    my $ttl    = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{ttl};
+    my $l1 = (sort map { index $_->{label}, '.' } @zone)[-1];
+    my $l2 = (sort 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(MX SOA PTR)];
+        $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',
+          $l1 => $r{label},
+          $r{ttl},
+          $l2 => $r{rrtype},
+          $r{data};
+    };
+    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 (\@add, \@del);
+}
+
+1;