Mercurial Mercurial > hg > dnsvi / comparison
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | file | latest | revisions | annotate | diff | comparison | raw | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
lib/DNS/Vi.pm
branchdeb
changeset 53 908e41fe9b30
parent 33 7d0fac2ec585
child 60 34d98030d4c0
equal deleted inserted replaced
52:5040471ee5ab 53:908e41fe9b30 
     1 package DNS::Vi;
 
     1 package DNS::Vi;
 
     2 use 5.010;
 
     2 use 5.010;
 
     3 use strict;
 
     3 use strict;
 
     4 use warnings;
 
     4 use warnings;
 
     5 use if $ENV{DEBUG}//''  eq 'dnsvi' => 'Smart::Comments';
 
     5 use if $ENV{DEBUG} // '' eq 'dnsvi' => 'Smart::Comments';
 
     6 use Digest::SHA qw(sha512_hex);
 
     6 use Digest::SHA qw(sha512_hex);
 
     7 use File::Temp;
 
     7 use File::Temp;
 
     8 use base 'Exporter';
 
     8 use base 'Exporter';
 
     9 no if $^V ge v5.16.0 => (warnings => 'experimental');
 
     9 no if $^V ge v5.16.0 => (warnings => 'experimental');
 
       
    10 
    10 #no if $warnings::Offset{'experimental'} => (warnings => 'experimental');
 
    11 #no if $warnings::Offset{'experimental'} => (warnings => 'experimental');
 
    11 
    12 
    12 our @EXPORT = qw(ttl2h h2ttl parse delta nice edit update show);
 
    13 our @EXPORT    = qw(ttl2h h2ttl parse delta nice edit update show);
 
    13 our @EXPORT_OK = ();
 
    14 our @EXPORT_OK = ();
 
    14 
    15 
    15 sub parse {
 
    16 sub parse {
 
    16     my %arg =  %{pop @_} if ref $_[-1] eq 'HASH';
 
    17     my %arg   = %{ pop @_ } if ref $_[-1] eq 'HASH';
 
    17     my $data = shift;
 
    18     my $data  = shift;
 
    18     my @lines = split /\n/, $data;
 
    19     my @lines = split /\n/, $data;
 
    19 
    20 
    20     my @zone;
 
    21     my @zone;
 
    21     my ($origin, $ttl, $last_label, $soa_seen);
 
    22     my ($origin, $ttl, $last_label, $soa_seen);
 
    22 
    23 
    43                     : $last_label,
 
    44                     : $last_label,
 
    44                       ttl => h2ttl($+{ttl} // $ttl),
 
    45                       ttl => h2ttl($+{ttl} // $ttl),
 
    45                       rrtype => uc $+{rrtype},
 
    46                       rrtype => uc $+{rrtype},
 
    46                       data   => $+{data},
 
    47                       data   => $+{data},
 
    47                 );
 
    48                 );
 
    48 		next if $rrset{rrtype} ~~ $arg{-skip};
 
    49                 next if $rrset{rrtype} ~~ $arg{-skip};
 
    49 
    50 
    50                 if ($rrset{rrtype} eq 'SOA') {
 
    51                 if ($rrset{rrtype} eq 'SOA') {
 
    51                     next if $soa_seen;
 
    52                     next if $soa_seen;
 
    52                     $soa_seen = 1;
 
    53                     $soa_seen = 1;
 
    53                 }
 
    54                 }
 
    69                         $rrset{data} =~ s{^\S+\s+\K(\S+[^.])(?=\s)}{$1.$origin};
 
    70                         $rrset{data} =~ s{^\S+\s+\K(\S+[^.])(?=\s)}{$1.$origin};
 
    70                     }
 
    71                     }
 
    71 
    72 
    72                     # bei einigen RRs müssen wir die Daten korrigieren
 
    73                     # bei einigen RRs müssen wir die Daten korrigieren
 
    73                     when ([qw/CNAME MX NS PTR SOA/]) {
 
    74                     when ([qw/CNAME MX NS PTR SOA/]) {
 
    74 			$rrset{data} =~ s/\@/$origin/g;
 
    75                         $rrset{data} =~ s/\@/$origin/g;
 
    75                         $rrset{data} .= ".$origin"
 
    76                         $rrset{data} .= ".$origin"
 
    76                           unless substr($rrset{data}, -1) eq '.';
 
    77                           unless substr($rrset{data}, -1) eq '.';
 
    77                     }
 
    78                     }
 
    78                 }
 
    79                 }
 
    79                 my $id = sha512_hex(join "\0", sort %rrset);
 
    80                 my $id = sha512_hex(join "\0", sort %rrset);
 
   121 
   122 
   122     return $out // $ttl;
 
   123     return $out // $ttl;
 
   123 }
 
   124 }
 
   124 
   125 
   125 {
 
   126 {
 
   126     my %order = map { state $n = 0; $_ => ++$n } qw(SOA NS TXT MX A AAAA);
 
   127     my %order = map { state $n = 0; $_ => ++$n } qw(SOA NS TXT MX A AAAA SSHFP);
 
   127 sub nice {
 
   128 
   128 
   129     sub nice {
 
   129     # get a list of { id => $id, rrset => \%rrset }
 
   130 
   130     my @zone =
 
   131         # get a list of { id => $id, rrset => \%rrset }
 
   131       sort {
 
   132 	# we do a schwartz transformation here
 
   132         length $a->{label} <=> length $b->{label}
 
   133 	# [ reverse LABEL, RRSET ]
 
   133           or $a->{label} cmp $b->{label}
 
   134         my @zone = map { $_->[1] }
 
   134 	  or ($order{$a->{rrtype}}//99) <=> ($order{$b->{rrtype}}//99)
 
   135           sort {
 
   135       } map { $_->{rrset} } @_;
 
   136 	      $a->[0] cmp $b->[0]
 
   136 
   137               or length $a->[1]{label} <=> length $b->[1]{label}
 
   137     my @out;
 
   138               or ($order{ $a->[1]{rrtype} } // 99) <=> ($order{ $b->[1]{rrtype} } // 99)
 
   138     my $origin = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{label};
 
   139           }
 
   139     my $ttl    = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{ttl};
 
   140           map { [scalar reverse($_->{label}), $_] } map { $_->{rrset} } @_;
 
   140     my $len1 = (sort { $a <=> $b } map { index $_->{label}, '.' } @zone)[-1];
 
   141 
   141     my $len2 = (sort { $a <=> $b } map { length $_->{rrtype} } @zone)[-1];
 
   142         my @out;
 
   142     push @out, "\$ORIGIN $origin", "\$TTL " . ttl2h($ttl);
 
   143         my $origin = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{label};
 
   143 
   144         my $ttl    = (grep { $_->{rrtype} eq 'SOA' } @zone)[0]->{ttl};
 
   144     my $print = sub {
 
   145         my $len1 =
 
   145         my %r = %{ +shift };
 
   146           (sort { $a <=> $b } map { index $_->{label}, '.' } @zone)[-1];
 
   146         state $last_label;
 
   147         my $len2 = (sort { $a <=> $b } map { length $_->{rrtype} } @zone)[-1];
 
   147 
   148         push @out, "\$ORIGIN $origin", "\$TTL " . ttl2h($ttl);
 
   148         $r{label} = '@' if $r{label} eq $origin;
 
   149 
   149         $r{label} =~ s{\.\Q$origin\E$}{};
 
   150         my $print = sub {
 
   150         $r{data} =~ s{\.\Q$origin\E$}{} if $r{rrtype} ~~ [qw(CNAME MX SOA PTR)];
 
   151             my %r = %{ +shift };
 
   151 	$r{data} =~ s{\Q$origin\E$}{\@} if $r{rrtype} ~~ [qw(CNAME MX)];
 
   152             state $last_label;
 
   152         $r{ttl} = $r{ttl} == $ttl ? '' : ttl2h($r{ttl});
 
   153 
   153         $r{label} = do {
 
   154             $r{label} = '@' if $r{label} eq $origin;
 
   154             if (defined $last_label and $r{label} eq $last_label) { '' }
 
   155             $r{label} =~ s{\.\Q$origin\E$}{};
 
   155             else { $last_label = $r{label} }
 
   156             $r{data} =~ s{\.\Q$origin\E$}{}
 
       
   157               if $r{rrtype} ~~ [qw(CNAME MX SOA PTR)];
 
       
   158             $r{data} =~ s{\Q$origin\E$}{\@} if $r{rrtype} ~~ [qw(CNAME MX)];
 
       
   159             $r{ttl} = $r{ttl} == $ttl ? '' : ttl2h($r{ttl});
 
       
   160             $r{label} = do {
 
       
   161                 if (defined $last_label and $r{label} eq $last_label) { '' }
 
       
   162                 else { $last_label = $r{label} }
 
       
   163             };
 
       
   164 
       
   165             return sprintf '%-*s %6s %-*s    %s',
 
       
   166               $len1 => $r{label},
 
       
   167               $r{ttl},
 
       
   168               $len2 => $r{rrtype},
 
       
   169               $r{data};
 
   156         };
 
   170         };
 
   157 
   171         push @out, '; do NOT EDIT the SOA records SERIAL number!';
 
   158         return sprintf '%-*s %6s %-*s    %s',
 
   172         push @out, $print->($_) foreach @zone;
 
   159           $len1 => $r{label},
 
   173         return join "\n", @out, '';
 
   160           $r{ttl},
 
   174     }
 
   161           $len2 => $r{rrtype},
 
   175 }
 
   162           $r{data};
 
   176 
   163     };
 
       
   164     push @out, '; do NOT EDIT the SOA records SERIAL number!';
 
       
   165     push @out, $print->($_) foreach @zone;
 
       
   166     return join "\n", @out, '';
 
       
   167 }
 
       
   168 }
 
       
   169 sub delta {
 
   177 sub delta {
 
   170     my ($zone1, $zone2) = @_;
 
   178     my ($zone1, $zone2) = @_;
 
   171     my %zone1 = map { $_->{id}, $_->{rrset} } @$zone1;
 
   179     my %zone1 = map { $_->{id}, $_->{rrset} } @$zone1;
 
   172     my %zone2 = map { $_->{id}, $_->{rrset} } @$zone2;
 
   180     my %zone2 = map { $_->{id}, $_->{rrset} } @$zone2;
 
   173     my @keys1 = keys %zone1;
 
   181     my @keys1 = keys %zone1;
 
   181 
   189 
   182     return (\@add, \@del);
 
   190     return (\@add, \@del);
 
   183 }
 
   191 }
 
   184 
   192 
   185 sub edit {
 
   193 sub edit {
 
   186     my %arg = %{pop @_} if ref $_[-1] eq 'HASH';
 
   194     my %arg = %{ pop @_ } if ref $_[-1] eq 'HASH';
 
   187     my @zone = @_;
 
   195     my @zone = @_;
 
   188 
   196 
   189     my $tmp = File::Temp->new();
 
   197     my $tmp = File::Temp->new();
 
   190     $tmp->print(nice @zone);
 
   198     $tmp->print(nice @zone);
 
   191     $tmp->flush();
 
   199     $tmp->flush();
 
   192     system $arg{-editor} => $tmp->filename;
 
   200     system $arg{-editor} => $tmp->filename;
 
   193     $tmp->seek(0, 0);
 
   201     $tmp->seek(0, 0);
 
   194     ${$arg{-backup}} = $tmp if $arg{-backup};
 
   202     ${ $arg{-backup} } = $tmp if $arg{-backup};
 
   195     return parse(do { local $/ = undef; <$tmp>}, {-skip => $arg{-skip}});
 
   203     return parse(do { local $/ = undef; <$tmp> }, { -skip => $arg{-skip} });
 
   196 }
 
   204 }
 
   197 
   205 
   198 sub show {
 
   206 sub show {
 
   199     my ($add, $del) = @_;
 
   207     my ($add, $del) = @_;
 
   200     my @out = (
 
   208     my @out = ((map { " - $_ " } @$del), (map { " + $_ " } @$add),);
 
   201 	(map { " - $_ " } @$del),
 
       
   202 	(map { " + $_ " } @$add),
 
       
   203     );
 
       
   204     return @out;
 
   209     return @out;
 
   205 }
 
   210 }
 
   206 
   211 
   207 sub update {
 
   212 sub update {
 
   208     my %arg = %{pop @_} if ref $_[-1] eq 'HASH';
 
   213     my %arg = %{ pop @_ } if ref $_[-1] eq 'HASH';
 
   209     my ($zone1, $add, $del) = @_;
 
   214     my ($zone1, $add, $del) = @_;
 
   210 
   215 
   211     my $orig_soa =
 
   216     my $orig_soa =
 
   212       (grep { $_->{rrtype} eq 'SOA' } map { $_->{rrset} } @$zone1)[0];
 
   217       (grep { $_->{rrtype} eq 'SOA' } map { $_->{rrset} } @$zone1)[0];
 
   213 
   218 
   240 sub save {
 
   245 sub save {
 
   241     my ($zone, $file) = @_;
 
   246     my ($zone, $file) = @_;
 
   242     open(my $fh, '>', $file) or die "Can't open >$file: $!\n";
 
   247     open(my $fh, '>', $file) or die "Can't open >$file: $!\n";
 
   243     print $fh nice @$zone;
 
   248     print $fh nice @$zone;
 
   244     close($fh);
 
   249     close($fh);
 
   245     
   250 
   246 }
 
   251 }
 
   247 
   252 
   248 1;
 
   253 1;
dnsvi