<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Functions for managing BIND 4 and 8/9 records files
use strict;
use warnings;
no warnings 'redefine';

# Globals from Webmin or bind8-lib.pl
our (%config, %text, %in);
our $module_config_directory;
our $bind_version;
our $ipv6revzone = $config{'ipv6_mode'} ? "ip6.arpa" : "ip6.int";

# read_zone_file(file, origin, [previous], [only-soa], [no-chroot])
# Reads a DNS zone file and returns a data structure of records. The origin
# must be a domain without the trailing dot, or just .
sub read_zone_file
{
my ($file, $line, @tok, @lnum, @coms,
      @rv, $origin, @inc, @oset, $comment);
$origin = $_[1];
if (&amp;has_ndc() == 2) {
	# Flush the zone file
	&amp;backquote_command(
		$config{'rndc_cmd'}.
		($config{'rndc_conf'} ? " -c $config{'rndc_conf'}" : "").
		" sync ".quotemeta($origin)." 2&gt;&amp;1 &lt;/dev/null");
	}
if ($origin ne ".") {
	# Remove trailing dots in origin name, as they are added automatically
	# in the code below.
	$origin =~ s/\.*$//;
	}
$file = &amp;absolute_path($_[0]);
my $rootfile = $_[4] ? $file : &amp;make_chroot($file);
my $FILE;
if (&amp;is_raw_format_records($rootfile)) {
	# Convert from raw format first
	&amp;has_command("named-compilezone") ||
		&amp;error("Zone file $rootfile is in raw format, but the ".
		       "named-compilezone command is not installed");
	open($FILE, "named-compilezone -f raw -F text -o - $origin $rootfile |");
	}
else {
	# Can read text format records directly
	open($FILE, "&lt;", $rootfile);
	}
my $lnum = 0;
my ($gotsoa, $aftersoa) = (0, 0);
while($line = &lt;$FILE&gt;) {
	my ($glen, $merged_2, $merge);
	$glen = 0;
	# strip comments (# is not a valid comment separator here!)
	$line =~ s/\r|\n//g;
	# parsing splited into separate cases to fasten it
	if ($line =~ /;/ &amp;&amp;
	    ($line =~ /[^\\]/ &amp;&amp;
	     $line =~ /^((?:[^;\"]+|\"\"|(?:\"(?:[^\"]*)\"))*);(.*)/) ||
	    ($line =~ /[^\"]/ &amp;&amp;
	     $line =~ /^((?:[^;\\]|\\.)*);(.*)/) ||
	     # expresion below is the most general, but very slow 
	     # if ";" is quoted somewhere
	     $line =~ /^((?:(?:[^;\"\\]|\\.)+|(?:\"(?:[^\"\\]|\\.)*\"))*);(.*)/) {
		$comment = $2;
		$line = $1;
		if ($line =~ /^[^"]*"[^"]*$/) {
			# Line has only one ", meaning that a ; in the middle
			# of a quoted string broke it! Fix up
			$line .= ";".$comment;
			$comment = "";
			}
		}
	else { 
		$comment = "";
		}

	# split line into tokens
	my $oset = 0;
	while(1) {
		$merge = 1;
		my $base_oset = 0;
		if ($line =~ /^(\s*)\"((?:[^\"\\]|\\.)*)\"(.*)/ ||
		    $line =~ /^(\s*)((?:[^\s\(\)\"\\]|\\.)+)(.*)/ ||
		    ($merge = 0) || $line =~ /^(\s*)([\(\)])(.*)/) {
			if ($glen == 0) {
				$oset += length($1);
				}
			else {
				$glen += length($1);
				}
			$glen += length($2);
			$merged_2 .= $2;
			$line = $3;
			if (!$merge || $line =~ /^([\s\(\)]|$)/) {
				push(@tok, $merged_2); push(@lnum, $lnum);
				push(@oset, $oset);
				push(@coms, $comment); $comment = "";

				# Check if we have the SOA
				if (uc($merged_2) eq "SOA") {
					$gotsoa = 1;
					}
				elsif ($gotsoa) {
					$aftersoa++;
					}

				$merged_2 = "";
				$oset += $glen;
				$glen = 0;
				}
			}
		else { last; }
		}
	$lnum++;

	# Check if we have a complete SOA record
	if ($aftersoa &gt; 10 &amp;&amp; $_[3]) {
		last;
		}
	}
close($FILE);

# parse into data structures
my $i = 0; my $num = 0;
while($i &lt; @tok) {
	if ($tok[$i] =~ /^\$origin$/i) {
		# $ORIGIN directive (may be relative or absolute)
		if ($tok[$i+1] =~ /^(\S*)\.$/) {
			$origin = $1 ? $1 : ".";
			}
		elsif ($origin eq ".") { $origin = $tok[$i+1]; }
		else { $origin = "$tok[$i+1].$origin"; }
		$i += 2;
		}
	elsif ($tok[$i] =~ /^\$include$/i) {
		# including another file
		if ($lnum[$i+1] == $lnum[$i+2]) {
			# $INCLUDE zonefile origin
			my $inc_origin;
			if ($tok[$i+2] =~ /^(\S+)\.$/) {
				$inc_origin = $1 ? $1 : ".";
				}
			elsif ($origin eq ".") { $inc_origin = $tok[$i+2]; }
			else { $inc_origin = "$tok[$i+2].$origin"; }
			@inc = &amp;read_zone_file($tok[$i+1], $inc_origin,
					       @rv ? $rv[$#rv] : undef);
			$i += 3;
			}
		else {
			# $INCLUDE zonefile
			@inc = &amp;read_zone_file($tok[$i+1], $origin,
					       @rv ? $rv[$#rv] : undef);
			$i += 2;
			}
		foreach my $j (@inc) { $j-&gt;{'num'} = $num++; }
		push(@rv, @inc);
		}
	elsif ($tok[$i] =~ /^\$generate$/i) {
		# a generate directive .. add it as a special record
		my $gen = { 'file' =&gt; $file,
			    'rootfile' =&gt; $rootfile,
			    'comment' =&gt; $coms[$i],
			    'line' =&gt; $lnum[$i],
			    'num' =&gt; $num++,
			    'type' =&gt; '' };
		my @gv;
		while($lnum[++$i] == $gen-&gt;{'line'}) {
			push(@gv, $tok[$i]);
			}
		$gen-&gt;{'generate'} = \@gv;
		push(@rv, $gen);
		}
	elsif ($tok[$i] =~ /^\$ttl$/i) {
		# a ttl directive
		$i++;
		my $defttl = { 'file' =&gt; $file,
			       'rootfile' =&gt; $rootfile,
		      	       'line' =&gt; $lnum[$i],
		               'num' =&gt; $num++,
		       	       'defttl' =&gt; $tok[$i++],
			       'type' =&gt; '' };
		push(@rv, $defttl);
		}
	elsif ($tok[$i] =~ /^\$(\S+)/i) {
		# some other special directive
		my $ln = $lnum[$i];
		while($lnum[$i] == $ln) {
			$i++;
			}
		}
	else {
		# A DNS record line
		my(%dir, @values, $l);
		$dir{'line'} = $lnum[$i];
		$dir{'file'} = $file;
		$dir{'rootfile'} = $rootfile;
		$dir{'comment'} = $coms[$i];
		if ($tok[$i] =~ /^(in|hs)$/i &amp;&amp; $oset[$i] &gt; 0) {
			# starting with a class
			$dir{'class'} = uc($tok[$i]);
			$i++;
			}
		elsif ($tok[$i] =~ /^\d/ &amp;&amp; $tok[$i] !~ /in-addr/i &amp;&amp;
		       $oset[$i] &gt; 0 &amp;&amp; $tok[$i+1] =~ /^(in|hs)$/i) {
			# starting with a TTL and class
			$dir{'ttl'} = $tok[$i];
			$dir{'class'} = uc($tok[$i+1]);
			$i += 2;
			}
		elsif ($tok[$i+1] =~ /^(in|hs)$/i) {
			# starting with a name and class
			$dir{'name'} = $tok[$i];
			$dir{'class'} = uc($tok[$i+1]);
			$i += 2;
			}
		elsif ($oset[$i] &gt; 0 &amp;&amp; $tok[$i] =~ /^\d+/) {
			# starting with just a ttl
			$dir{'ttl'} = $tok[$i];
			$dir{'class'} = "IN";
			$i++;
			}
		elsif ($oset[$i] &gt; 0) {
			# starting with nothing
			$dir{'class'} = "IN";
			}
		elsif ($tok[$i+1] =~ /^\d/ &amp;&amp; $tok[$i+2] =~ /^(in|hs)$/i) {
			# starting with a name, ttl and class
			$dir{'name'} = $tok[$i];
			$dir{'ttl'} = $tok[$i+1];
			$dir{'class'} = uc($tok[$i+2]);
			$i += 3;
			}
                elsif ($tok[$i+1] =~ /^\d/) {
                        # starting with a name and ttl
                        $dir{'name'} = $tok[$i];
                        $dir{'ttl'} = $tok[$i+1];
                        $dir{'class'} = "IN";
                        $i += 2;
                        }
		else {
			# starting with a name
			$dir{'name'} = $tok[$i];
			$dir{'class'} = "IN";
			$i++;
			}
		if (!defined($dir{'name'}) || $dir{'name'} eq '') {
			my $prv;
			# Name comes from previous record
			for(my $p=$#rv; $p&gt;=0; $p--) {
				$prv = $rv[$p];
				last if ($prv-&gt;{'name'});
				}
			$prv ||= $_[2];
			$prv || &amp;error(&amp;text('efirst', $lnum[$i]+1, $file));
			$dir{'name'} = $prv-&gt;{'name'};
			$dir{'realname'} = $prv-&gt;{'realname'};
			}
		else {
			$dir{'realname'} = $dir{'name'};
			}
		$dir{'type'} = uc($tok[$i++]);

		# read values until end of line, unless a ( is found, in which
		# case read till the )
		$l = $lnum[$i];
		while($i &lt; @tok &amp;&amp; $lnum[$i] == $l) {
			if ($tok[$i] eq "(") {
				my $olnum = $lnum[$i];
				while($tok[++$i] ne ")") {
					push(@values, $tok[$i]);
					if ($i &gt;= @tok) {
						&amp;error("No ending ) found for ".
						       "( starting at $olnum");
						}
					}
				$i++; # skip )
				last;
				}
			push(@values, $tok[$i++]);
			}
		$dir{'values'} = \@values;
		$dir{'eline'} = $lnum[$i-1];

		# Work out canonical form, and maybe use it
		my $canon = $dir{'name'};
		if ($canon eq "@") {
			$canon = $origin eq "." ? "." : "$origin.";
			}
		elsif ($canon !~ /\.$/) {
			$canon .= $origin eq "." ? "." : ".$origin.";
			}
		if (!$config{'short_names'}) {
			$dir{'name'} = $canon;
			}
		$dir{'canon'} = $canon;
		$dir{'num'} = $num++;

		# If this is an SPF record .. adjust the class
		my $spf;
		if ($dir{'type'} eq 'TXT' &amp;&amp;
		    !$config{'spf_record'} &amp;&amp;
		    ($spf=&amp;parse_spf(@{$dir{'values'}}))) {
			if (!$spf-&gt;{'other'} || !@{$spf-&gt;{'other'}}) {
				$dir{'type'} = 'SPF';
				}
			}

		# If this is a DMARC record .. adjust the class
		my $dmarc;
		if ($dir{'type'} eq 'TXT' &amp;&amp;
                    ($dmarc=&amp;parse_dmarc(@{$dir{'values'}}))) {
                        if (!$dmarc-&gt;{'other'} || !@{$dmarc-&gt;{'other'}}) {
                                $dir{'type'} = 'DMARC';
                                }
                        }

		push(@rv, \%dir);

		# Stop processing if this was an SOA record
		if ($dir{'type'} eq 'SOA' &amp;&amp; $_[3]) {
			last;
			}
		}
	}
return @rv;
}

# create_record(file, name, ttl, class, type, values, comment)
# Add a new record of some type to some zone file
sub create_record
{
my $fn = &amp;make_chroot(&amp;absolute_path($_[0]));
&amp;is_raw_format_records($fn) &amp;&amp; &amp;error("Raw format zone files cannot be edited");
my $lref = &amp;read_file_lines($fn);
push(@$lref, &amp;make_record(@_[1..$#_]));
&amp;flush_file_lines($fn);
}

# modify_record(file, &amp;old, name, ttl, class, type, values, comment)
# Updates an existing record in some zone file
sub modify_record
{
my $fn = &amp;make_chroot(&amp;absolute_path($_[0]));
&amp;is_raw_format_records($fn) &amp;&amp; &amp;error("Raw format zone files cannot be edited");
my $lref = &amp;read_file_lines($fn);
my $lines = $_[1]-&gt;{'eline'} - $_[1]-&gt;{'line'} + 1;
splice(@$lref, $_[1]-&gt;{'line'}, $lines, &amp;make_record(@_[2..$#_]));
&amp;flush_file_lines($fn);
}

# delete_record(file, &amp;old)
# Deletes a record in some zone file
sub delete_record
{
my $fn = &amp;make_chroot(&amp;absolute_path($_[0]));
&amp;is_raw_format_records($fn) &amp;&amp; &amp;error("Raw format zone files cannot be edited");
my $lref = &amp;read_file_lines($fn);
my $lines = $_[1]-&gt;{'eline'} - $_[1]-&gt;{'line'} + 1;
splice(@$lref, $_[1]-&gt;{'line'}, $lines);
&amp;flush_file_lines($fn);
}

# create_generator(file, range, lhs, type, rhs, [comment])
# Add a new $generate line to some zone file
sub create_generator
{
my $f = &amp;make_chroot(&amp;absolute_path($_[0]));
my $lref = &amp;read_file_lines($f);
push(@$lref, join(" ", '$generate', @_[1..4]).
	     ($_[5] ? " ;$_[5]" : ""));
&amp;flush_file_lines($f);
}

# modify_generator(file, &amp;old, range, lhs, type, rhs, [comment])
# Updates an existing $generate line in some zone file
sub modify_generator
{
my $f = &amp;make_chroot(&amp;absolute_path($_[0]));
my $lref = &amp;read_file_lines($f);
$lref-&gt;[$_[1]-&gt;{'line'}] = join(" ", '$generate', @_[2..5]).
			   ($_[6] ? " ;$_[6]" : "");
&amp;flush_file_lines($f);
}

# delete_generator(file, &amp;old)
# Deletes a $generate line in some zone file
sub delete_generator
{
my $f = &amp;make_chroot(&amp;absolute_path($_[0]));
my $lref = &amp;read_file_lines($f);
splice(@$lref, $_[1]-&gt;{'line'}, 1);
&amp;flush_file_lines($f);
}

# create_defttl(file, value)
# Adds a $ttl line to a records file
sub create_defttl
{
my $f = &amp;make_chroot(&amp;absolute_path($_[0]));
my $lref = &amp;read_file_lines($f);
splice(@$lref, 0, 0, "\$ttl $_[1]");
&amp;flush_file_lines($f);
}

# modify_defttl(file, &amp;old, value)
# Updates the $ttl line with a new value
sub modify_defttl
{
my $f = &amp;make_chroot(&amp;absolute_path($_[0]));
my $lref = &amp;read_file_lines($f);
$lref-&gt;[$_[1]-&gt;{'line'}] = "\$ttl $_[2]";
&amp;flush_file_lines($f);
}

# delete_defttl(file, &amp;old)
# Removes the $ttl line from a records file
sub delete_defttl
{
my $f = &amp;make_chroot(&amp;absolute_path($_[0]));
my $lref = &amp;read_file_lines($f);
splice(@$lref, $_[1]-&gt;{'line'}, 1);
&amp;flush_file_lines($f);
}

# make_record(name, ttl, class, type, values, comment)
# Returns a string for some zone record
sub make_record
{
my ($name, $ttl, $cls, $type, $values, $cmt) = @_;
$type = $type eq "SPF" &amp;&amp; !$config{'spf_record'} ? "TXT" :
        $type eq "DMARC" ? "TXT" : $type;
return $name . ($ttl ? "\t".$ttl : "") . "\t" . $cls . "\t" . $type ."\t" .
       $values . ($cmt ? "\t;$cmt" : "");
}

# bump_soa_record(file, &amp;records)
# Increase the serial number in some SOA record by 1
sub bump_soa_record
{
my($r, $v, $vals);
for(my $i=0; $i&lt;@{$_[1]}; $i++) {
	$r = $_[1]-&gt;[$i];
	if ($r-&gt;{'type'} eq "SOA") {
		$v = $r-&gt;{'values'};
		# already set serial if no acl allow it to update or update
		# is disabled
		my $serial = $v-&gt;[2];
		if ($config{'updserial_on'}) {
			# automatically handle serial numbers ?
			$serial = &amp;compute_serial($v-&gt;[2]);
			}
		$vals = "$v-&gt;[0] $v-&gt;[1] (\n\t\t\t$serial\n\t\t\t$v-&gt;[3]\n".
			"\t\t\t$v-&gt;[4]\n\t\t\t$v-&gt;[5]\n\t\t\t$v-&gt;[6] )";
		&amp;modify_record($r-&gt;{'file'}, $r, $r-&gt;{'realname'}, $r-&gt;{'ttl'},
				$r-&gt;{'class'}, $r-&gt;{'type'}, $vals);
		}
	}
}

# date_serial()
# Returns a string like YYYYMMDD
sub date_serial
{
my $now = time();
my @tm = localtime($now);
return sprintf "%4.4d%2.2d%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
}

# get_zone_defaults(&amp;hash)
sub get_zone_defaults
{
if (!&amp;read_file("$module_config_directory/zonedef", $_[0])) {
	$_[0]-&gt;{'refresh'} = 10800; $_[0]-&gt;{'retry'} = 3600;
	$_[0]-&gt;{'expiry'} = 604800; $_[0]-&gt;{'minimum'} = 38400;
	$_[0]-&gt;{'refunit'} = ""; $_[0]-&gt;{'retunit'} = "";
	$_[0]-&gt;{'expunit'} = ""; $_[0]-&gt;{'minunit'} = "";
	}
else {
	$_[0]-&gt;{'refunit'} = $1 if ($_[0]-&gt;{'refresh'} =~ s/([^0-9])$//);
	$_[0]-&gt;{'retunit'} = $1 if ($_[0]-&gt;{'retry'} =~ s/([^0-9])$//);
	$_[0]-&gt;{'expunit'} = $1 if ($_[0]-&gt;{'expiry'} =~ s/([^0-9])$//);
	$_[0]-&gt;{'minunit'} = $1 if ($_[0]-&gt;{'minimum'} =~ s/([^0-9])$//);
	}
}

# save_zone_defaults(&amp;array)
sub save_zone_defaults
{
&amp;write_file("$module_config_directory/zonedef", $_[0]);
}

# allowed_zone_file(&amp;access, file)
sub allowed_zone_file
{
return 0 if ($_[1] =~ /\.\./);
return 0 if (-l $_[1] &amp;&amp; !&amp;allowed_zone_file($_[0], readlink($_[1])));
my $l = length($_[0]-&gt;{'dir'});
return length($_[1]) &gt; $l &amp;&amp; substr($_[1], 0, $l) eq $_[0]-&gt;{'dir'};
}

# sort_records(list)
sub sort_records
{
return @_ if (!@_);
my $s = $in{'sort'} ? $in{'sort'} : $config{'records_order'};
if ($s == 1) {
	# Sort by name
	if ($_[0]-&gt;{'type'} eq "PTR") {
		my @rv = sort ptr_sort_func @_; 
		return @rv;
		}
	else {
		my @rv = sort { $a-&gt;{'name'} cmp $b-&gt;{'name'} } @_;
		return @rv;
		}
	}
elsif ($s == 2) {
	# Sort by value
	if ($_[0]-&gt;{'type'} eq "A") {
		my @rv = sort ip_sort_func @_;
		return @rv;
		}
	elsif ($_[0]-&gt;{'type'} eq "MX") {
		my @rv = sort { $a-&gt;{'values'}-&gt;[1] cmp $b-&gt;{'values'}-&gt;[1] } @_;
		return @rv;
		}
	else {
		my @rv = sort { $a-&gt;{'values'}-&gt;[0] cmp $b-&gt;{'values'}-&gt;[0] } @_;
		return @rv;
		}
	}
elsif ($s == 3) {
	# Sort by IP address or by value if there is no IP
	if ($_[0]-&gt;{'type'} eq "A") {
		my @rv = sort ip_sort_func @_;
		return @rv;
		}
	elsif ($_[0]-&gt;{'type'} eq "PTR") {
		my @rv = sort ptr_sort_func @_;
		return @rv;
		}
	elsif ($_[0]-&gt;{'type'} eq "MX") {
		my @rv = sort { $a-&gt;{'values'}-&gt;[1] cmp $b-&gt;{'values'}-&gt;[1] } @_;
		return @rv;
		}
	else {
		my @rv = sort { $a-&gt;{'values'}-&gt;[0] cmp $b-&gt;{'values'}-&gt;[0] } @_;
		return @rv;
		}
	}
elsif ($s == 4) {
	# Sort by comment
	my @rv = sort { $b-&gt;{'comment'} cmp $a-&gt;{'comment'} } @_;
	return @rv;
	}
elsif ($s == 5) {
	# Sort by type
	my @rv = sort { $a-&gt;{'type'} cmp $b-&gt;{'type'} } @_;
	return @rv;
	}
else {
	return @_;
	}
}

sub ptr_sort_func
{
$a-&gt;{'name'} =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/;
my ($a1, $a2, $a3, $a4) = ($1, $2, $3, $4);
$b-&gt;{'name'} =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/;
return	$a4 &lt; $4 ? -1 :
	$a4 &gt; $4 ? 1 :
	$a3 &lt; $3 ? -1 :
	$a3 &gt; $3 ? 1 :
	$a2 &lt; $2 ? -1 :
	$a2 &gt; $2 ? 1 :
	$a1 &lt; $1 ? -1 :
	$a1 &gt; $1 ? 1 : 0;
}

sub ip_sort_func
{
$a-&gt;{'values'}-&gt;[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/;
my ($a1, $a2, $a3, $a4) = ($1, $2, $3, $4);
$b-&gt;{'values'}-&gt;[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/;
return	$a1 &lt; $1 ? -1 :
	$a1 &gt; $1 ? 1 :
	$a2 &lt; $2 ? -1 :
	$a2 &gt; $2 ? 1 :
	$a3 &lt; $3 ? -1 :
	$a3 &gt; $3 ? 1 :
	$a4 &lt; $4 ? -1 :
	$a4 &gt; $4 ? 1 : 0;
}

# arpa_to_ip(name)
# Converts an address like 4.3.2.1.in-addr.arpa. to 1.2.3.4
sub arpa_to_ip
{
if ($_[0] =~ /^([\d\-\.\/]+)\.in-addr\.arpa/i) {
	return join('.',reverse(split(/\./, $1)));
	}
return $_[0];
}

# ip_to_arpa(address)
# Converts an IP address like 1.2.3.4 to 4.3.2.1.in-addr.arpa.
sub ip_to_arpa
{
if ($_[0] =~ /^([\d\-\.\/]+)$/) {
	return join('.',reverse(split(/\./,$1))).".in-addr.arpa.";
	}
return $_[0];
}

# ip6int_to_net(name)
# Converts an address like a.b.c.d.4.3.2.1.ip6.int. to 1234:dcba::
sub ip6int_to_net
{
my $n;
my $addr = $_[0];
if ($addr =~ /^([\da-f]\.)+$ipv6revzone/i) {
	$addr =~ s/\.$ipv6revzone/\./i;
	$addr = reverse(split(/\./, $addr));
	$addr =~ s/([\w]{4})/$1:/g;
	$n = ($addr =~ s/([\w])/$1/g) * 4;
	$addr =~ s/(\w+)$/$+0000/;
	$addr =~ s/([\w]{4})0+$/$1:/;
	$addr =~ s/$/:/;
	$addr =~ s/:0{1,3}/:/g;
	if ($n &gt; 112) {
		$addr =~ s/::$//;
		$addr =~ s/(:0)+:/::/;
		}
	if ($n &lt; 128) {
		return $addr."/$n";
		}
	return $addr
	}
return $_[0];
}

# net_to_ip6int(address, [bits])
# Converts an IPv6 address like 1234:dcba:: to a.b.c.d.4.3.2.1.ip6.int.
sub net_to_ip6int
{
my $addr = lc($_[0]);
my $n = $_[1] ? $_[1] &gt;&gt; 2 : 0;
if (&amp;check_ip6address($addr)) {
	$addr = reverse(split(/\:/, &amp;expandall_ip6($addr)));
	$addr =~ s/(\w)/$1\./g;
	if ($n &gt; 0) {
		$addr = substr($addr, -2 * $n, 2 * $n);
	}
	$addr = $addr.$ipv6revzone.".";
	}
return $addr;
}

our $uscore = $config{'allow_underscore'} ? "_" : "";
our $star = $config{'allow_wild'} ? "\\*" : "";

# valdnsname(name, wild, origin)
sub valdnsname
{
my($fqdn);
$fqdn = $_[0] !~ /\.$/ ? "$_[0].$_[2]." : $_[0];
if (length($fqdn) &gt; 255) {
	&amp;error(&amp;text('edit_efqdn', $fqdn));
	}
if ($_[0] =~ /[^\.]{64}/) {
	# no label longer than 63 chars
	&amp;error(&amp;text('edit_elabel', $_[0]));
	}
return ((($_[1] &amp;&amp; $config{'allow_wild'})
	 ? (($_[0] =~ /^[\*A-Za-z0-9\-\.$uscore]+$/)
	   &amp;&amp; ($_[0] !~ /.\*/ || $bind_version &gt;= 9) # "*" can be only the first
						    # char, for bind 8
	   &amp;&amp; ($_[0] !~ /\*[^\.]/))	# a "." must always follow "*"
	 : ($_[0] =~ /^[\A-Za-z0-9\-\.$uscore]+$/))
	&amp;&amp; ($_[0] !~ /\.\./)		# no ".." inside
	&amp;&amp; ($_[0] !~ /^\../)		# no "." at the beginning
	&amp;&amp; ($_[0] !~ /^\-/)		# no "-" at the beginning
	&amp;&amp; ($_[0] !~ /\-$/)		# no "-" at the end
	&amp;&amp; ($_[0] !~ /\.\-/)		# no ".-" inside
	&amp;&amp; ($_[0] !~ /\-\./)		# no "-." inside
	&amp;&amp; ($_[0] !~ /\.[0-9]+\.$/));	# last label in FQDN may not be
					# purely numeric
}

# valemail(email)
sub valemail
{
return $_[0] eq "." ||
       $_[0] =~ /^[A-Za-z0-9\.\-]+$/ ||
       $_[0] =~ /(\S*)\@(\S*)/ &amp;&amp; 
       &amp;valdnsname($2, 0, ".") &amp;&amp; 
       $1 =~ /[a-z][\w\-\.$uscore]+/i;
}

# absolute_path(path)
# If a path does not start with a /, prepend the base directory
sub absolute_path
{
if ($_[0] =~ /^([a-zA-Z]:)?\//) { return $_[0]; }
return &amp;base_directory()."/".$_[0];
}

# parse_spf(text, ...)
# If some text looks like an SPF TXT record, return a parsed hash ref
sub parse_spf
{
my $txt = join(" ", @_);
if ($txt =~ /^v=spf1/) {
	my @w = split(/\s+/, $txt);
	my $spf = { };
	foreach my $w (@w) {
		$w = lc($w);
		if ($w eq "a" || $w eq "mx" || $w eq "ptr") {
			$spf-&gt;{$w} = 1;
			}
		elsif ($w =~ /^(a|mx|ip4|ip6|ptr|include|exists):(\S+)$/) {
			push(@{$spf-&gt;{"$1:"}}, $2);
			}
		elsif ($w eq "-all") {
			$spf-&gt;{'all'} = 3;
			}
		elsif ($w eq "~all") {
			$spf-&gt;{'all'} = 2;
			}
		elsif ($w eq "?all") {
			$spf-&gt;{'all'} = 1;
			}
		elsif ($w eq "+all" || $w eq "all") {
			$spf-&gt;{'all'} = 0;
			}
		elsif ($w eq "v=spf1") {
			# Ignore this
			}
		elsif ($w =~ /^(redirect|exp)=(\S+)$/) {
			# Modifier for domain redirect or expansion
			$spf-&gt;{$1} = $2;
			}
		else {
			push(@{$spf-&gt;{'other'}}, $w);
			}
		}
	return $spf;
	}
return undef;
}

# join_spf(&amp;spf)
# Converts an SPF record structure to a string, designed to be inserted into
# quotes in a TXT record. If it is longer than 255 bytes, it will be split
# into multiple quoted strings.
sub join_spf
{
my ($spf) = @_;
my @rv = ( "v=spf1" );
foreach my $s ("a", "mx", "ptr") {
	push(@rv, $s) if ($spf-&gt;{$s});
	}
foreach my $s ("a", "mx", "ip4", "ip6", "ptr", "include", "exists") {
	if ($spf-&gt;{"$s:"}) {
		foreach my $v (@{$spf-&gt;{"$s:"}}) {
			push(@rv, "$s:$v");
			}
		}
	}
if ($spf-&gt;{'other'}) {
	push(@rv, @{$spf-&gt;{'other'}});
	}
foreach my $m ("redirect", "exp") {
	if ($spf-&gt;{$m}) {
		push(@rv, $m."=".$spf-&gt;{$m});
		}
	}
if ($spf-&gt;{'all'} == 3) { push(@rv, "-all"); }
elsif ($spf-&gt;{'all'} == 2) { push(@rv, "~all"); }
elsif ($spf-&gt;{'all'} == 1) { push(@rv, "?all"); }
elsif ($spf-&gt;{'all'} eq '0') { push(@rv, "all"); }
my @rvwords;
my $rvword = "";
while(@rv) {
	my $w = shift(@rv);
	if (length($rvword)+length($w)+1 &gt;= 255) {
		$rvword .= " ";
		push(@rvwords, $rvword);
		$rvword = "";
		}
	$rvword .= " " if ($rvword);
	$rvword .= $w;
	}
push(@rvwords, $rvword);
return join("\" \"", @rvwords);
}

# parse_dmarc(text, ...)
# If some text looks like an DMARC TXT record, return a parsed hash ref
sub parse_dmarc
{
my $txt = join(" ", @_);
if ($txt =~ /^v=dmarc1/i) {
	my @w = split(/;\s*/, $txt);
	my $dmarc = { };
	foreach my $w (@w) {
		$w = lc($w);
		if ($w =~ /^(v|pct|ruf|rua|p|sp|adkim|aspf)=(\S+)$/i) {
			$dmarc-&gt;{$1} = $2;
			}
		else {
			push(@{$dmarc-&gt;{'other'}}, $w);
			}
		}
	return $dmarc;
	}
return undef;
}

# join_dmarc(&amp;dmarc)
# Converts a DMARC record structure to a string, designed to be inserted into
# quotes in a TXT record. If it is longer than 255 bytes, it will be split
# into multiple quoted strings.
sub join_dmarc
{
my ($dmarc) = @_;
my @rv = ( "v=DMARC1" );
foreach my $s ("pct", "ruf", "rua", "p", "sp", "adkim", "aspf") {
	if ($dmarc-&gt;{$s} &amp;&amp; $dmarc-&gt;{$s} ne '') {
		push(@rv, $s."=".$dmarc-&gt;{$s});
		}
	}
if ($dmarc-&gt;{'other'}) {
	push(@rv, @{$dmarc-&gt;{'other'}});
	}
my @rvwords;
my $rvword = "";
while(@rv) {
	my $w = shift(@rv);
	if (length($rvword)+length($w)+1 &gt;= 255) {
		push(@rvwords, $rvword);
		$rvword = "";
		}
	$rvword .= "; " if ($rvword);
	$rvword .= $w;
	}
push(@rvwords, $rvword);
return join("\" \"", @rvwords);
}

# join_record_values(&amp;record)
# Given the values for a record, joins them into a space-separated string
# with quoting if needed
sub join_record_values
{
my ($r) = @_;
if ($r-&gt;{'type'} eq 'SOA') {
	# Multiliple lines, with brackets
	my $v = $r-&gt;{'values'};
	return "$v-&gt;[0] $v-&gt;[1] (\n\t\t\t$v-&gt;[2]\n\t\t\t$v-&gt;[3]\n".
	       "\t\t\t$v-&gt;[4]\n\t\t\t$v-&gt;[5]\n\t\t\t$v-&gt;[6] )";
	}
else {
	# All one one line
	my @rv;
	foreach my $v (@{$r-&gt;{'values'}}) {
		push(@rv, $v =~ /\s|;/ ? "\"$v\"" : $v);
		}
	return join(" ", @rv);
	}
}

# compute_serial(old)
# Given an old serial number, returns a new one using the configured method
sub compute_serial
{
my ($old) = @_;
if ($config{'soa_style'} == 1 &amp;&amp; $old =~ /^(\d{8})(\d\d)$/) {
	if ($1 &gt;= &amp;date_serial()) {
		if ($2 &gt;= 99) {
			# Have to roll over to next day
			return sprintf "%d%2.2d", $1+1, $config{'soa_start'};
			}
		else {
			# Just increment within this day
			return sprintf "%d%2.2d", $1, $2+1;
			}
		}
	else {
		# A new day has come
		return &amp;date_serial().sprintf("%2.2d", $config{'soa_start'});
		}
	}
elsif ($config{'soa_style'} == 2) {
	# Unix time
	my $rv = time();
	while($rv &lt;= $old) {
		$rv = $old + 1;
		}
	return $rv;
	}
else {
	# Incrementing number
	return $old+1;
	}
}

# convert_to_absolute(short, origin)
# Make a short name like foo a fully qualified name like foo.domain.com.
sub convert_to_absolute
{
my ($name, $origin) = @_;
if ($name eq $origin ||
    $name =~ /\.\Q$origin\E$/) {
	# Name already ends in domain name - add . automatically, so we don't
	# re-append the domain name.
	$name .= ".";
	}
my $rv = $name eq "" ? "$origin." :
	    $name eq "@" ? "$origin." :
	    $name !~ /\.$/ ? "$name.$origin." : $name;
$rv =~ s/\.+$/\./;
return $rv;
}

# get_zone_file(&amp;zone|&amp;zonename, [absolute])
# Returns the relative-to-chroot path to a domain's zone file.
# If absolute is 1, the path is made absolute. If 2, it is also un-chrooted
sub get_zone_file
{
my ($z, $abs) = @_;
$abs ||= 0;
my $fn;
if ($z-&gt;{'members'}) {
	my $file = &amp;find("file", $z-&gt;{'members'});
	return undef if (!$file);
	$fn = $file-&gt;{'values'}-&gt;[0];
	}
else {
	$fn = $z-&gt;{'file'};
	}
if ($abs) {
	$fn = &amp;absolute_path($fn);
	}
if ($abs == 2) {
	$fn = &amp;make_chroot($fn);
	}
return $fn;
}

# get_dnskey_record(&amp;zone|&amp;zonename, [&amp;records])
# Returns the DNSKEY record(s) for some domain, or undef if none
sub get_dnskey_record
{
my ($z, $recs) = @_;
my $dom = $z-&gt;{'members'} ? $z-&gt;{'values'}-&gt;[0] : $z-&gt;{'name'};
my @rv;
if ($dom) {
	if (!$recs) {
		# Need to get zone file and thus records
		my $fn = &amp;get_zone_file($z);
		$recs = [ &amp;read_zone_file($fn, $dom) ];
		}
	# Find the record
	foreach my $r (@$recs) {
		if ($r-&gt;{'type'} eq 'DNSKEY' &amp;&amp;
		    $r-&gt;{'name'} eq $dom.'.') {
			push(@rv, $r);
			}
		}
	}
return wantarray ? @rv : $rv[0];
}

# record_id(&amp;r)
# Returns a unique ID string for a record, based on the name and value
sub record_id
{
my ($r) = @_;
return $r-&gt;{'name'}."/".$r-&gt;{'type'}.
       (uc($r-&gt;{'type'}) eq 'SOA' || !$r-&gt;{'values'} ? '' :
		'/'.join('/', @{$r-&gt;{'values'}}));
}

# find_record_by_id(&amp;recs, id, index)
# Find a record by ID and possibly index
sub find_record_by_id
{
my ($recs, $id, $num) = @_;
my @rv = grep { &amp;record_id($_) eq $id } @$recs;
if (!@rv) {
	return undef;
	}
elsif (@rv == 1) {
	return $rv[0];
	}
else {
	# Multiple matches .. find the one with the right index
	@rv = grep { $_-&gt;{'num'} == $num } @rv;
	return @rv ? $rv[0] : undef;
	}
}

# get_dnskey_rrset(&amp;zone, [&amp;records])
# Returns the DNSKEY recordset for some domain, or an empty array if none 
sub get_dnskey_rrset
{
	my ($z, $recs) = @_;
	my @rv = ();
	my $dom = $z-&gt;{'members'} ? $z-&gt;{'values'}-&gt;[0] : $z-&gt;{'name'};
	if (!$recs) {
		# Need to get zone file and thus records
		my $fn = &amp;get_zone_file($z);
		$recs = [ &amp;read_zone_file($fn, $dom) ];
	}
	# Find the record
	foreach my $r (@$recs) {
		if ($r-&gt;{'type'} eq 'DNSKEY' &amp;&amp;
			$r-&gt;{'name'} eq $dom.'.') {
				push(@rv, $r);
		}
	}
	return @rv;
}

# is_raw_format_records(file)
# Checks if a zone file is in BIND's new raw or text format
sub is_raw_format_records
{
my ($file) = @_;
open(my $RAW, "&lt;", $file) || return 0;
my $buf;
read($RAW, $buf, 3);
close($RAW);
return $buf eq "\0\0\0";
}

1;

</pre></body></html>