1 use 5.010;

     2 use strict;

     3 use warnings;

     4 use if $ENV{DEBUG}//''  eq 'vidns' => 'Smart::Comments';

     5 use Digest::SHA qw(sha512_hex);

     6 

     7 use base 'Exporter';

     8 

     9 our @EXPORT = qw(ttl2h h2ttl parse delta);

    10 our @EXPORT_OK = ();

    11 

    12 sub parse {

    13     my $data = join '', @_;

    14     my @lines = split /\n/, $data;

    15 

    16     my @zone;

    17     my ($origin, $ttl, $last_label, $soa_seen);

    18 

    19     foreach (@lines) {

    20         s{;.*$}{};

    21         given ($_) {

    22             when (m{^\s*$})                { next }

    23             when (m{^\s*\$ORIGIN\s+(\S+)}) { $origin = $1 }

    24             when (m{^\s*\$TTL\s+(\S+)})    { $ttl = $1 }

    25             when (

    26                 m{^(?<label>\S+)?

    27 		    \s+(?<ttl>\d[\dwdmhs]*(?=\s+))?

    28 		    \s+(?:(?:IN|ANY)\s+)?(?<rrtype>[a-z]\S*(?=\s+))

    29 		    \s+(?<data>.*)

    30 		  }ix

    31               )

    32             {

    33                 my %rrset = (

    34                     label => $last_label =

    35                       defined $+{label}

    36                     ? $+{label} eq '@'

    37                           ? $origin

    38                           : $+{label}

    39                     : $last_label,

    40                       ttl => h2ttl($+{ttl} // $ttl),

    41                       rrtype => uc $+{rrtype},

    42                       data   => $+{data},

    43                 );

    44 

    45                 if ($rrset{rrtype} eq 'SOA') {

    46                     next if $soa_seen;

    47                     $soa_seen = 1;

    48                 }

    49 

    50                 # label ergänzen, wenn nicht FQDN

    51                 $rrset{label} .= ".$origin"

    52                   unless substr($rrset{label}, -1) eq '.';

    53 

    54                 given ($rrset{rrtype}) {

    55 

    56                     # origin steht im SOA

    57                     when ('SOA') {

    58                         $origin = $rrset{label};

    59 

    60                         # fix the nameserver name

    61                         $rrset{data} =~ s{^(\S+[^.])(?=\s)}{$1.$origin};

    62 

    63                         # fix the hostmaster address

    64                         $rrset{data} =~ s{^\S+\s+\K(\S+[^.])(?=\s)}{$1.$origin};

    65                     }

    66 

    67                     # bei einigen RRs müssen wir die Daten korrigieren

    68                     when ([qw/MX NS PTR/]) {

    69                         $rrset{data} .= ".$origin"

    70                           unless substr($rrset{data}, -1) eq '.';

    71                     }

    72                 }

    73                 my $id = sha512_hex(sort %rrset);

    74                 push @zone, { id => $id, rrset => \%rrset };

    75             }

    76         }

    77     }

    78 

    79     # list of {

    80     #	id => $id,

    81     #	rrset => { label => …, ttl => …, rrtype => …, data => … }

    82     # }

    83     ### @zone

    84     return @zone;

    85 }

    86 

    87 sub ttl2h {

    88     my $seconds = shift;

    89     my @out;

    90     my @units = ([w => 604800], [d => 86400], [h => 3600], [m => 60], [s => 1]);

    91 

    92     foreach (@units) {

    93         my $x = int($seconds / $_->[1]);

    94         push @out, "$x$_->[0]" if $x;

    95         $seconds %= $_->[1] or last;

    96     }

    97 

    98     return join '', @out;

    99 }

   100 

   101 sub h2ttl {

   102     my $ttl = shift;

   103     my $out;

   104     my %factor = (

   105         w => 604800,

   106         d => 86400,

   107         h => 3600,

   108         m => 60,

   109         s => 1,

   110     );

   111 

   112     while ($ttl =~ m{(\d+)([wdhms])}g) {

   113         $out += $1 * $factor{$2};

   114     }

   115 

   116     return $out // $ttl;

   117 }

   118 

   119 sub nice {

   120 

   121     # get a list of { id => $id, rrset => \%rrset }

   122     my @zone =

   123       sort {

   124         length $a->{label} <=> length $b->{label}

   125           or $a->{label}

   126           cmp $b->{label}

   127       } map { $_->{rrset} } @_;

   128 

   129     my @out;

   130     my $origin = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{label};

   131     my $ttl    = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{ttl};

   132     my $l1 = (sort map { index $_->{label}, '.' } @zone)[-1];

   133     my $l2 = (sort map { length $_->{rrtype} } @zone)[-1];

   134     push @out, "\$ORIGIN $origin", "\$TTL " . ttl2h($ttl);

   135 

   136     my $print = sub {

   137         my %r = %{ +shift };

   138         state $last_label;

   139 

   140         $r{label} = '@' if $r{label} eq $origin;

   141         $r{label} =~ s{\.\Q$origin\E$}{};

   142         $r{data} =~ s{\.\Q$origin\E$}{} if $r{rrtype} ~~ [qw(MX SOA PTR)];

   143         $r{ttl} = $r{ttl} == $ttl ? '' : ttl2h($r{ttl});

   144         $r{label} = do {

   145             if (defined $last_label and $r{label} eq $last_label) { '' }

   146             else { $last_label = $r{label} }

   147         };

   148 

   149         return sprintf '%-*s %6s %-*s    %s',

   150           $l1 => $r{label},

   151           $r{ttl},

   152           $l2 => $r{rrtype},

   153           $r{data};

   154     };

   155     push @out, $print->($_) foreach @zone;

   156     return join "\n", @out;

   157 }

   158 

   159 sub delta {

   160     my ($zone1, $zone2) = @_;

   161     my %zone1 = map { $_->{id}, $_->{rrset} } @$zone1;

   162     my %zone2 = map { $_->{id}, $_->{rrset} } @$zone2;

   163     my @keys1 = keys %zone1;

   164     my @keys2 = keys %zone2;

   165     delete @zone1{@keys2};

   166     delete @zone2{@keys1};

   167 

   168     my (@add, @del);

   169     push @add, "@{$_}{qw/label ttl rrtype data/}" foreach values %zone2;

   170     push @del, "@{$_}{qw/label ttl rrtype data/}" foreach values %zone1;

   171 

   172     return (\@add, \@del);

   173 }

   174 

   175 1;