#!/usr/bin/perl -w
#
# zone-convert
# jms1@jms1.net 2002-05-31
#
# reads a single BIND zone file and writes the equivalent djbdns data
#
# 2007-04-26 jms1 - bringing out of mothballs, adding GPLv2 notice. no code
#   changes at this time.
#
# 2007-04-29 jms1 - adding support for TXT records
#
# 2009-04-05 jms1 - re-doing tokenization logic
#
###############################################################################
#
# Copyright (C) 2002,2007,2009 John Simpson.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 or version 3 of the
# license, at your option.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
###############################################################################

require 5.003 ;
use strict ;

use Getopt::Std ;

###############################################################################
#
# configuration and globals

my $do_debug	= 0 ;
my $show_src	= 0 ;

my %parser	= () ;

my $owner	= "" ;
my $o_owner	= "" ;
my $origin	= "" ;
my $d_ttl	= 3600 ;
my $ttl		= $d_ttl ;
my $rtype	= "" ;

my %opt		= () ;

# SOA values if "-Z" is used. see RFC 1912 section 2.2.
my $Z_ref	=  3600 ;	# refresh: how often caches poll master to see
				#   if serial number has changed.
my $Z_ret	=   300 ;	# retry: how often caches retry if a unable to
				#   reach a master.
my $Z_exp	= 86400 ;	# expire: how long caches will treat their
				#   copy of the data as valid if the master
				#   cannot be reached.
my $Z_min	=  3600 ;	# minimum: minimum TTL value for all records,
				#   default TTL value for all records if not
				#   otherwise specified.

###############################################################################
#
# debug

sub debug($)
{
	return unless $do_debug ;
	print $_[0] ;
}

###############################################################################
#
# tokenizing routines
# tokens are defined as any string of characters separated by whitespace

my @tokens = ( ) ;
my $t_done = 0 ;

sub read_tokens()
{
	while ( defined ( my $line = <> ) )
	{
		$show_src && ( print "# $line" ) ;

		$line =~ s/\s*#.*// ;
		$line =~ s/\s*;.*// ;

		$line =~ s/\s+$// ;
		$line =~ s/^\s+// ;

		next unless $line ;

		while ( $line )
		{
			debug "- checking [$line]\n" ;

			if ( $line =~ s|^"(.*?)"|| )
			{
				my $z = $1 ;
				debug "- found token [$z]\n" ;
				push ( @tokens , $z ) ;
			}
			elsif ( $line =~ s|^(\S+)|| )
			{
				my $z = $1 ;
				if ( ( $z ne "(" ) && ( $z ne ")" ) )
				{
					debug "- found token [$z]\n" ;
					push ( @tokens , $z ) ;
				}
				else
				{
					debug "- ignoring token [$z]\n" ;
				}
			}
			else
			{
				die "ERROR: Cannot parse line fragment\n$line\n" ;
			}

			$line =~ s|^\s+|| ;
		}
	}
}

sub next_token($)
{
	my $die_err = shift ;
	my $tline ;

	########################################
	# do we have anything left to parse from?

	if ( $t_done )
	{
		debug "[[NO-TOKENS-LEFT]]\n" ;
		$die_err && die "Attempt to read past end of input\n" ;
		return undef ;
	}

	if ( $#tokens > -1 )
	{
		my $k = shift @tokens ;
		$k =~ s/\@/$origin/g ;
		debug "[$k]\n" ;
		return $k ;
	}

	$t_done = 1 ;
	debug "[END-OF-TOKENS]\n" ;
	$die_err && die "Attempt to read past end of input\n" ;
	return undef ;
}

###############################################################################
#
# fix dots at the end where required

sub fixdot($;$)
{
	my $x = shift ;
	my $suffix = ( shift || $origin || die "\$ORIGIN not specified\n" ) ;

	if ( $x =~ /\.$/ )
	{
		return $x ;
	}

	$x .= ".$suffix" ;
	$x =~ s|\.+$|.| ;

	if ( $x =~ /\.$/ )
	{
		return $x ;
	}

	return "$x." ;
}

sub fixowner($)
{
	debug "fixowner($_[0]) starting\n" ;
	my $x = fixdot ( $_[0] ) ;
	debug "fixowner($_[0]) x=[$x]\n" ;
	$x =~ s/\.$// ;
	debug "fixowner($_[0]) returning [$x]\n" ;
	return $x ;
}

###############################################################################
#
# handlers for different record types

$parser{"A"} = sub
{
	my $ip = next_token ( 1 ) ;
	if ( $opt{"L"} && ( $owner =~ m|localhost| ) && ( $ip =~ m|^127\.| ) )
	{
		debug "not generating localhost entry\n" ;
	}
	else
	{
		print "+$owner:$ip:$ttl\n" ;
	}
} ;

$parser{"CNAME"} = sub
{
	my $target = fixdot ( next_token ( 1 ) ) ;
	print "C$owner:$target:$ttl\n" ;
} ;

$parser{"MX"} = sub
{
	my $priority	= next_token ( 1 ) ;
	my $target	= fixowner ( next_token ( 1 ) ) ;
	print "\@$owner:" . ":$target:$priority:$ttl\n" ;
} ;

$parser{"SOA"} = sub
{
	my $ns  = fixowner ( next_token ( 1 ) ) ;
	my $rp  = fixowner ( next_token ( 1 ) ) ;
	my $ser = next_token ( 1 ) ;
	my $ref = next_token ( 1 ) ;
	my $ret = next_token ( 1 ) ;
	my $exp = next_token ( 1 ) ;
	my $min = next_token ( 1 ) ;

	if ( $opt{"Z"} )
	{
		$ser = "" ;
		$ref = $Z_ref ;
		$ret = $Z_ret ;
		$exp = $Z_exp ;
		$min = $Z_min ;
	}

	print "Z$owner:$ns:$rp:$ser:$ref:$ret:$exp:$min:$ttl\n" ;
} ;

$parser{"NS"} = sub
{
	my $target = fixowner ( next_token ( 1 ) ) ;
	print "&$owner:" . ":$target:$ttl\n" ;
} ;

$parser{"TXT"} = sub
{
	my $target = next_token ( 1 ) ;
	$target =~ s/^"// ;
	$target =~ s/"$// ;
	$target =~ s/\:/\\072/g ;
	print "'$owner:$target:$ttl\n" ;
} ;

###############################################################################
###############################################################################
###############################################################################
#
# let's do this

# -d	debug
# -s	show_src
# -t	dump tokens and exit. forces "-d" and "-s" options on.
# -o:	set initial origin, if file doesn't have a $ORIGIN line
# -L	remove "localhost -> 127.0.0.1" entries
# -Z	remove SOA serial numbers, set timeouts low

getopts ( "dsto:LZ" , \%opt ) ;

$do_debug = ( $opt{"t"} ? 1 : ( $opt{"d"} ? 1 : 0 ) ) ;
$show_src = ( $opt{"t"} ? 1 : ( $opt{"s"} ? 1 : 0 ) ) ;
$origin = ( $opt{"o"} || "" ) ;

if ( $origin && ( $origin !~ /\.$/ ) )
{
	$origin .= "." ;
}

read_tokens() ;

if ( $opt{"t"} )
{
	print "Token dump\n" ;
	map { print "  [$_]\n" } @tokens ;
	exit 0 ;
}

while ( defined ( my $token = next_token ( 0 ) ) )
{
	########################################
	# handle directives

	if ( $token eq "\$TTL" )
	{
		$d_ttl = next_token ( 1 ) ;
		$opt{"Z"} && ( $d_ttl = 3600 ) ;
		next ;
	}

	if ( $token eq "\$ORIGIN" )
	{
		$origin = next_token ( 1 ) ;
		next ;
	}

	########################################
	# read the beginning of the line
	# until we get to a record type that we know
	# the line is formatted as:
	#   [owner] [ttl] [class] rtype ...
	# where
	#   owner is the name we're defining.
	#     default is the same owner as the previous record.
	#   ttl   is the TTL value for the record.
	#     default is set by $TTL directive, with default 3600
	#   class is always "IN"
	#   rtype is one of ( SOA NS MX A CNAME PTR SVC TXT )

	$owner = "" ;
	$ttl = $d_ttl ;
	$rtype = "" ;

	do
	{
		if ( exists $parser{$token} )
		{
			$rtype = $token ;
		}
		elsif ( $token eq "IN" )
		{
			$rtype = next_token ( 1 ) ;
			unless ( exists $parser{$rtype} )
			{
				die "Unknown record type [$rtype]\n" ;
			}
		}
		elsif ( $token =~ /^\d+$/ )
		{
			$ttl = $token ;
		}
		else
		{
			$owner = $token ;
		}

		$rtype || ( $token = next_token ( 1 ) ) ;
	} until ( $rtype ) ;

	########################################
	# we have a record.
	# call the appropriate parser

	debug "- 1 rtype=[$rtype] owner=[$owner] o_owner=[$o_owner]\n" ;

	$owner = fixowner ( $owner || $o_owner || die "??? \$owner\n" ) ;
	$o_owner = $owner ;

	debug "- 2 rtype=[$rtype] owner=[$owner] o_owner=[$o_owner]\n" ;

	&{$parser{$rtype}} ;
}