File Manager - BorneoXploit

Editing: records-lib.pl

# Functions for managing BIND 4 and 8/9 records files
use strict;
use warnings;
no warnings 'redefine';
no warnings 'uninitialized';

# 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 (&has_ndc() == 2) {
	# Flush the zone file
	&backquote_command(
		$config{'rndc_cmd'}.
		($config{'rndc_conf'} ? " -c $config{'rndc_conf'}" : "").
		" sync ".quotemeta($origin)." 2>&1 </dev/null");
	}
if ($origin ne ".") {
	# Remove trailing dots in origin name, as they are added automatically
	# in the code below.
	$origin =~ s/\.*$//;
	}
$file = &absolute_path($_[0]);
my $rootfile = $_[4] ? $file : &make_chroot($file);
my $FILE;
if (&is_raw_format_records($rootfile)) {
	# Convert from raw format first
	my $compilezone = &has_command("named-compilezone");
	$compilezone ||
		&error("Zone file $rootfile is in raw format, but the ".
		       "named-compilezone command is not installed");
	open($FILE, "-|", $compilezone,
	     "-f", "raw", "-F", "text", "-o", "-",
	     $origin, $rootfile);
	}
else {
	# Can read text format records directly
	open($FILE, "<", $rootfile);
	}
my $lnum = 0;
my ($gotsoa, $aftersoa) = (0, 0);
while($line = <$FILE>) {
	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 =~ /;/ &&
	    ($line =~ /[^\\]/ &&
	     $line =~ /^((?:[^;\"]+|\"\"|(?:\"(?:[^\"]*)\"))*);(.*)/) ||
	    ($line =~ /[^\"]/ &&
	     $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 > 10 && $_[3]) {
		last;
		}
	}
close($FILE);

# parse into data structures
my $i = 0;
my $num = 0;
my $currttl = undef;
while($i < @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 = &read_zone_file($tok[$i+1], $inc_origin,
					       @rv ? $rv[$#rv] : undef);
			$i += 3;
			}
		else {
			# $INCLUDE zonefile
			@inc = &read_zone_file($tok[$i+1], $origin,
					       @rv ? $rv[$#rv] : undef);
			$i += 2;
			}
		foreach my $j (@inc) { $j->{'num'} = $num++; }
		push(@rv, @inc);
		}
	elsif ($tok[$i] =~ /^\$generate$/i) {
		# a generate directive .. add it as a special record
		my $gen = { 'file' => $file,
			    'rootfile' => $rootfile,
			    'comment' => $coms[$i],
			    'line' => $lnum[$i],
			    'num' => $num++,
			    'type' => '' };
		my @gv;
		while($lnum[++$i] == $gen->{'line'}) {
			push(@gv, $tok[$i]);
			}
		$gen->{'generate'} = \@gv;
		push(@rv, $gen);
		}
	elsif ($tok[$i] =~ /^\$ttl$/i) {
		# a ttl directive
		$i++;
		my $defttl = { 'file' => $file,
			       'rootfile' => $rootfile,
		      	       'line' => $lnum[$i],
		               'num' => $num++,
		       	       'defttl' => $tok[$i++],
			       'type' => '' };
		push(@rv, $defttl);
		$currttl = $defttl->{'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 && $oset[$i] > 0) {
			# starting with a class
			$dir{'class'} = uc($tok[$i]);
			$i++;
			}
		elsif ($tok[$i] =~ /^\d/ && $tok[$i] !~ /in-addr/i &&
		       $oset[$i] > 0 && $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] > 0 && $tok[$i] =~ /^\d+/) {
			# starting with just a ttl
			$dir{'ttl'} = $tok[$i];
			$dir{'class'} = "IN";
			$i++;
			}
		elsif ($oset[$i] > 0) {
			# starting with nothing
			$dir{'class'} = "IN";
			}
		elsif ($tok[$i+1] =~ /^\d/ && $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>=0; $p--) {
				$prv = $rv[$p];
				last if ($prv->{'name'});
				}
			$prv ||= $_[2];
			$prv || &error(&text('efirst', $lnum[$i]+1, $file));
			$dir{'name'} = $prv->{'name'};
			$dir{'realname'} = $prv->{'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 < @tok && $lnum[$i] == $l) {
			if ($tok[$i] eq "(") {
				my $olnum = $lnum[$i];
				while($tok[++$i] ne ")") {
					push(@values, $tok[$i]);
					if ($i >= @tok) {
						&error("No ending ) found for ".
						       "( at $olnum in $file");
						}
					}
				$i++; # skip )
				last;
				}
			push(@values, $tok[$i++]);
			}
		$dir{'values'} = \@values;
		$dir{'eline'} = $lnum[$i-1];
		$dir{'realttl'} = $dir{'ttl'} || $currttl;

# 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' &&
		    !$config{'spf_record'} &&
		    ($spf=&parse_spf(@{$dir{'values'}}))) {
			if (!$spf->{'other'} || !@{$spf->{'other'}}) {
				$dir{'type'} = 'SPF';
				}
			}

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

push(@rv, \%dir);

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

# files_in_zone_file(file)
# Quickly finds all includes in a zone file
sub files_in_zone_file
{
my ($file) = @_;
my @rv = ( $file );
my $fh;
open($fh, "<", $file);
while(<$fh>) {
	if (/^\$include\s+(\S+)/) {
		my $inc = $1;
		push(@rv, &files_in_zone_file($inc));
		}
	}
close($fh);
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 ($file, @rec) = @_;
my $fn = &make_chroot(&absolute_path($file));
&is_raw_format_records($fn) && &error("Raw format zone files cannot be edited");
my $lref = &read_file_lines($fn);
push(@$lref, &make_record(@rec));
&flush_file_lines($fn);
}

# create_multiple_records(file, &records)
# Create records from structures 
sub create_multiple_records
{
my ($file, $recs) = @_;
my $fn = &make_chroot(&absolute_path($file));
&is_raw_format_records($fn) && &error("Raw format zone files cannot be edited");
my $lref = &read_file_lines($fn);
foreach my $r (@$recs) {
	push(@$lref, &make_record($r->{'name'}, $r->{'ttl'}, $r->{'class'},
			          $r->{'type'}, join(" ", @{$r->{'values'}}),
			          $r->{'comment'}));
	}
&flush_file_lines($fn);
}

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

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

# delete_multiple_records(file, &records)
# Delete many records from the same file at once
sub delete_multiple_records
{
my ($file, $recs) = @_;
my $fn = &make_chroot(&absolute_path($file));
&is_raw_format_records($fn) && &error("Raw format zone files cannot be edited");
my $lref = &read_file_lines($fn);
foreach my $r (sort { $b->{'line'} <=> $a->{'line'} } @$recs) {
	my $lines = $r->{'eline'} - $r->{'line'} + 1;
	splice(@$lref, $r->{'line'}, $lines);
	}
&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 = &make_chroot(&absolute_path($_[0]));
my $lref = &read_file_lines($f);
push(@$lref, join(" ", '$generate', @_[1..4]).
	     ($_[5] ? " ;$_[5]" : ""));
&flush_file_lines($f);
}

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

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

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

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

# delete_defttl(file, &old)
# Removes the $ttl line from a records file
sub delete_defttl
{
my $f = &make_chroot(&absolute_path($_[0]));
my $lref = &read_file_lines($f);
splice(@$lref, $_[1]->{'line'}, 1);
&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" && !$config{'spf_record'} ? "TXT" :
        $type eq "DMARC" ? "TXT" : $type;
return $name.
       (defined($ttl) && $ttl ne "" ? "\t".$ttl : "").
       "\t".$cls.
       "\t".$type.
       "\t".$values.
       (defined($cmt) && $cmt ne "" ? "\t;$cmt" : "");
}

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

# 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(&hash)
sub get_zone_defaults
{
my ($zd) = @_;
if (!&read_file("$module_config_directory/zonedef", $zd)) {
	$zd->{'refresh'} = 3600;
	$zd->{'retry'} = 600;
	$zd->{'expiry'} = 1209600;
	$zd->{'minimum'} = 3600;
	$zd->{'refunit'} = "";
	$zd->{'retunit'} = "";
	$zd->{'expunit'} = "";
	$zd->{'minunit'} = "";
	}
else {
	$zd->{'refunit'} = $1 if ($zd->{'refresh'} =~ s/([^0-9])$//);
	$zd->{'retunit'} = $1 if ($zd->{'retry'} =~ s/([^0-9])$//);
	$zd->{'expunit'} = $1 if ($zd->{'expiry'} =~ s/([^0-9])$//);
	$zd->{'minunit'} = $1 if ($zd->{'minimum'} =~ s/([^0-9])$//);
	}
}

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

# allowed_zone_file(&access, file)
sub allowed_zone_file
{
return 0 if ($_[1] =~ /\.\./);
return 0 if (-l $_[1] && !&allowed_zone_file($_[0], readlink($_[1])));
my $l = length($_[0]->{'dir'});
return length($_[1]) > $l && substr($_[1], 0, $l) eq $_[0]->{'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]->{'type'} eq "PTR") {
		my @rv = sort ptr_sort_func @_; 
		return @rv;
		}
	else {
		my @rv = sort { $a->{'name'} cmp $b->{'name'} } @_;
		return @rv;
		}
	}
elsif ($s == 2) {
	# Sort by value
	if ($_[0]->{'type'} eq "A") {
		my @rv = sort ip_sort_func @_;
		return @rv;
		}
	elsif ($_[0]->{'type'} eq "MX") {
		my @rv = sort { $a->{'values'}->[1] cmp $b->{'values'}->[1] } @_;
		return @rv;
		}
	else {
		my @rv = sort { $a->{'values'}->[0] cmp $b->{'values'}->[0] } @_;
		return @rv;
		}
	}
elsif ($s == 3) {
	# Sort by IP address or by value if there is no IP
	if ($_[0]->{'type'} eq "A") {
		my @rv = sort ip_sort_func @_;
		return @rv;
		}
	elsif ($_[0]->{'type'} eq "PTR") {
		my @rv = sort ptr_sort_func @_;
		return @rv;
		}
	elsif ($_[0]->{'type'} eq "MX") {
		my @rv = sort { $a->{'values'}->[1] cmp $b->{'values'}->[1] } @_;
		return @rv;
		}
	else {
		my @rv = sort { $a->{'values'}->[0] cmp $b->{'values'}->[0] } @_;
		return @rv;
		}
	}
elsif ($s == 4) {
	# Sort by comment
	my @rv = sort { $b->{'comment'} cmp $a->{'comment'} } @_;
	return @rv;
	}
elsif ($s == 5) {
	# Sort by type
	my @rv = sort { $a->{'type'} cmp $b->{'type'} } @_;
	return @rv;
	}
else {
	return @_;
	}
}

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

sub ip_sort_func
{
$a->{'values'}->[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/;
my ($a1, $a2, $a3, $a4) = ($1, $2, $3, $4);
$b->{'values'}->[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/;
return	$a1 < $1 ? -1 :
	$a1 > $1 ? 1 :
	$a2 < $2 ? -1 :
	$a2 > $2 ? 1 :
	$a3 < $3 ? -1 :
	$a3 > $3 ? 1 :
	$a4 < $4 ? -1 :
	$a4 > $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 > 112) {
		$addr =~ s/::$//;
		$addr =~ s/(:0)+:/::/;
		}
	if ($n < 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] >> 2 : 0;
if (&check_ip6address($addr)) {
	$addr = reverse(split(/\:/, &expandall_ip6($addr)));
	$addr =~ s/(\w)/$1\./g;
	if ($n > 0) {
		$addr = substr($addr, -2 * $n, 2 * $n);
	}
	$addr = $addr.$ipv6revzone.".";
	}
return $addr;
}

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

# Record types whose owner names must follow hostname rules. Other types
# (TXT, CNAME, SRV, PTR, TLSA, CAA, ...) may legitimately use underscores
# in their owner names (e.g. _domainkey, _dmarc, _acme-challenge), so the
# allow_underscore config is ignored for them, matching BIND's check-names.
our %hostname_owner_types = map { $_ => 1 } qw(A AAAA MX NS DS DNAME);

# valdnsname(name, wild, [origin], [type])
# Returns 1 if a DNS record has a valid name. If a type is supplied and
# isn't one of the hostname-bearing types, underscores are accepted in
# the name regardless of the allow_underscore config.
sub valdnsname
{
my ($name, $wild, $origin, $type) = @_;
my $root = !defined($origin) || $origin eq "" || $origin eq ".";
my $fqdn = $name =~ /\.$/    ? $name
	 : $root              ? "$name."
	 :                      "$name.$origin.";
if (length($fqdn) > 255) {
	&error(&text('edit_efqdn', $fqdn));
	}
if ($name =~ /[^\.]{64}/) {
	# no label longer than 63 chars
	&error(&text('edit_elabel', $name));
	}
my $u = ($config{'allow_underscore'} ||
	 ($type && !$hostname_owner_types{uc($type)})) ? "_" : "";
return ((($wild && $config{'allow_wild'})
	 ? (($name =~ /^[\*A-Za-z0-9\-\.$u]+$/)
	   && ($name !~ /.\*/ || $bind_version >= 9) # "*" can be only the first
						    # char, for bind 8
	   && ($name !~ /\*[^\.]/))	# a "." must always follow "*"
	 : ($name =~ /^[A-Za-z0-9\-\.$u]+$/))
	&& ($name !~ /\.\./)		# no ".." inside
	&& ($name !~ /^\../)		# no "." at the beginning
	&& ($name !~ /^\-/)		# no "-" at the beginning
	&& ($name !~ /\-$/)		# no "-" at the end
	&& ($name !~ /\.\-/)		# no ".-" inside
	&& ($name !~ /\-\./)		# no "-." inside
	&& ($name !~ /\.[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*)/ && 
       &valdnsname($2, 0, ".") && 
       $1 =~ /[a-z][\w\-\.$uscore]+/i;
}

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

# 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->{$w} = 1;
			}
		elsif ($w =~ /^(a|mx|ip4|ip6|ptr|include|exists):(\S+)$/) {
			push(@{$spf->{"$1:"}}, $2);
			}
		elsif ($w eq "-all") {
			$spf->{'all'} = 3;
			}
		elsif ($w eq "~all") {
			$spf->{'all'} = 2;
			}
		elsif ($w eq "?all") {
			$spf->{'all'} = 1;
			}
		elsif ($w eq "+all" || $w eq "all") {
			$spf->{'all'} = 0;
			}
		elsif ($w eq "v=spf1") {
			# Ignore this
			}
		elsif ($w =~ /^(redirect|exp)=(\S+)$/) {
			# Modifier for domain redirect or expansion
			$spf->{$1} = $2;
			}
		else {
			push(@{$spf->{'other'}}, $w);
			}
		}
	return $spf;
	}
return;
}

# join_spf(&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->{$s});
	}
foreach my $s ("a", "mx", "ip4", "ip6", "ptr", "include", "exists") {
	if ($spf->{"$s:"}) {
		foreach my $v (@{$spf->{"$s:"}}) {
			push(@rv, "$s:$v");
			}
		}
	}
if ($spf->{'other'}) {
	push(@rv, @{$spf->{'other'}});
	}
foreach my $m ("redirect", "exp") {
	if ($spf->{$m}) {
		push(@rv, $m."=".$spf->{$m});
		}
	}
if ($spf->{'all'} == 3) { push(@rv, "-all"); }
elsif ($spf->{'all'} == 2) { push(@rv, "~all"); }
elsif ($spf->{'all'} == 1) { push(@rv, "?all"); }
elsif ($spf->{'all'} eq '0') { push(@rv, "all"); }
my @rvwords;
my $rvword = "";
while(@rv) {
	my $w = shift(@rv);
	if (length($rvword)+length($w)+1 >= 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|fo|rf|ri)=(\S+)$/i) {
			$dmarc->{$1} = $2;
			}
		else {
			push(@{$dmarc->{'other'}}, $w);
			}
		}
	return $dmarc;
	}
return;
}

# join_dmarc(&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 ("p", "pct", "ruf", "rua", "sp", "adkim", "aspf", "fo", "rf", "ri") {
	if ($dmarc->{$s} && $dmarc->{$s} ne '') {
		push(@rv, $s."=".$dmarc->{$s});
		}
	}
if ($dmarc->{'other'}) {
	push(@rv, @{$dmarc->{'other'}});
	}
my @rvwords;
my $rvword = "";
while(@rv) {
	my $w = shift(@rv);
	if (length($rvword)+length($w)+1 >= 255) {
		push(@rvwords, $rvword);
		$rvword = "";
		}
	$rvword .= "; " if ($rvword);
	$rvword .= $w;
	}
push(@rvwords, $rvword);
return join("\" \"", @rvwords);
}

# join_record_values(&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->{'type'} eq 'SOA') {
	# Multiliple lines, with brackets
	my $v = $r->{'values'};
	return "$v->[0] $v->[1] (\n\t\t\t$v->[2]\n\t\t\t$v->[3]\n".
	       "\t\t\t$v->[4]\n\t\t\t$v->[5]\n\t\t\t$v->[6] )";
	}
else {
	# All one one line
	my @rv;
	foreach my $v (@{$r->{'values'}}) {
		push(@rv, $v =~ /\s|;/ || $r->{'type'} eq 'TXT' ?
				"\"$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 && $old =~ /^(\d{8})(\d+)$/) {
	if ($1 >= &date_serial()) {
		if ($2 >= 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 &date_serial().sprintf("%2.2d", $config{'soa_start'});
		}
	}
elsif ($config{'soa_style'} == 2) {
	# Unix time
	my $rv = time();
	while($rv <= $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(&zone|&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->{'members'}) {
	my $file = &find("file", $z->{'members'});
	return if (!$file);
	$fn = $file->{'values'}->[0];
	}
else {
	$fn = $z->{'file'};
	}
return if (!$fn);
if ($abs) {
	$fn = &absolute_path($fn);
	}
if ($abs == 2) {
	$fn = &make_chroot($fn);
	}
return $fn;
}

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

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

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

# get_dnskey_rrset(&zone, [&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->{'members'} ? $z->{'values'}->[0] : $z->{'name'};
	if (!$recs) {
		# Need to get zone file and thus records
		my $fn = &get_zone_file($z);
		$recs = [ &read_zone_file($fn, $dom) ];
	}
	# Find the record
	foreach my $r (@$recs) {
		if ($r->{'type'} eq 'DNSKEY' &&
			$r->{'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, "<", $file) || return 0;
my $buf;
read($RAW, $buf, 3);
close($RAW);
return $buf eq "\0\0\0";
}

Cancel