#! /usr/bin/perl
#
# XPARSE
# =======
# Transform the xaliases file to generics/aliases/virtusertable files
# It resolves the virtusertable entries because sendmail does not process
# the virtusertable entries recursively if they point to virtusertable
# entries themself. During this process it detects recursive aliases
# (alias loops) and duplicate addresses in lists.
# Also, since virtusertables cannot contain lists, it creates an
# anonymious alias in the aliases file, and routes the virtusertable
# entry through that alias.
#
# Copyright (c) 1999 by Pauline Middelink <middelin@polyware.nl>
# 
# Changelog:
#   1999-12-24: Pauline Middelink
#     - made keys to hashes uppercased, real key is added in front
#	of hash value. The speedup is tremendus...
#     - warning and skipping of duplicate virtusertable entries.
#	Previously only the alias were checked.
#   1999-12-23: Pauline Middelink
#     - made sure that lines without a colon ':' are skipped, since
#	the resuling empty aliases entries would be kind of erronuous.
#     - allow aliases file(s) to be given on commandline. If there
#	are no files given, stdin is processed instead.
#     - added linecounter, so an error now indicated the offending
#	file and linenumber.
#   1999-12-08: Pauline Middelink
#     - removed small buglet where '<' entries with @ in their key
#	were added to virtusers without beeing a real alias!
#     - added -x option, which generates missing fall-through entries
#	for each domain mentioned in the virtusertable. The entries
#	are default generated as error:nouser, if you don't need this
#	define your own fall-through entry.
#     -	Added warning in the top of the generated files, indicating
#	that it is an generated file and should not be edited here.
#   1999-11-29: Pauline Middelink
#     -	added virtusertable resolving, and aliasing of virtuser-lists
#     -	reworked lowercase translation so it leaves the case of the
#	names in the generics database intact.
#     -	re-reworked parsing of xaliases, so that the quoted text
#	stays intact, and /no/ case translation is done at all.

use strict;
use Text::ParseWords;
use Getopt::Std;
use vars qw/ $opt_x /;

sub lookup(\%$);

my %alias;
my %generic;
my %virtuser;

getopts('x') || die "Invalid option\n";

# Process stdin...
my $oldfile;
my $line;
while (<>) {
	# are we doing a new file? reset the line count
	if ($oldfile ne $ARGV) {
		$line = 0;
		$oldfile = $ARGV;
	}
	# skip empty or commented fields
	chomp;
	$line++;
	next if $_ =~ /^[ \t]*(#|$)/;

	# break-up a single line, no continuation
	my ($keys,$vals) = split(':',$_,2);
	$vals =~ s/^[ \t]*//g;
	if (!defined $vals || $vals eq "") {
		print "$ARGV($line): no colon found, skipped\n";
		next
	}

	my @addr = quotewords(",", 1, $vals);
	for (@addr) {
		s/^[ \t]*//g;
		s/[ \t]*$//g;
	}
	for my $key (quotewords(",", 1, $keys)) {
		$key =~ s/^[ \t]*//g;
		$key =~ s/[ \t]*$//g;
		if (defined lookup(%alias,$key)) {
			print "$ARGV($line): duplicate alias ($key), skipped\n";
			next;
		}
		if (defined lookup(%virtuser,$key)) {
			print "$ARGV($line): duplicate alias ($key), skipped\n";
			next;
		}

		my @list;
		for my $addr (@addr) {
			my $mode = 1;
			$mode = 3 if $addr =~ s/^((<>)|(><))[ \t]*//;
			$mode = 1 if $addr =~ s/^>[ \t]*//;
			$mode = 2 if $addr =~ s/^<[ \t]*//;

			# do we need to write to generics?
			$generic{$key} = $addr
				if $mode & 2;

			# do we need to write to aliases/virtusertable?
			push(@list, $addr)
				if $mode & 1;
		}
		if ($#list >= 0) {
			if ($key =~ /@/) {
				$virtuser{uc($key)} = join("\n",$key,@list);
			} else {
				$alias{uc($key)} = join("\n",$key,@list);
			}
		}
	}
}

# Second, try to resolve all virtuser aliases
my %virts;
for my $key (keys %virtuser) {
	my $lckey;
	my @dest;
	my @done;
	my @todo = ($key);
	while (defined (my $target = shift @todo)) {
		my ($lkey,$vals) = lookup(%virtuser,$target);
		$lckey = $lkey
			if !defined $lckey;

		if (defined $vals) {
			for my $val (split("\n",$vals)) {
				if (grep($_ eq uc($val),@done)) {
					print "Duplicate address ($val) in list ($key), removed\n";
				} else {
					push(@done,uc($val));
					push(@todo,$val);
				}
			}
		}
		else {
			push(@dest,$target);
		}
	}

	if (scalar(@dest)) {
		$virts{$key} = join("\n",$lckey,sort @dest);
	} else {
		print "Recursive alias $key; dropped\n";
	}
}
undef %virtuser;

if (1) {
# Third, create anonymious aliases for list-virtusertable entries
my $lastlist = "1000";
OUTER:
for my $key (sort keys %virts) {
	next if $key !~ /@/;
	my ($lckey,$rest) = split("\n",$virts{$key},2);
	next if $rest !~ "\n";

	# check if we already have an alias for this list...
	for my $k (keys %alias) {
		my ($la,$arest) = split("\n",$alias{$k},2);
		if (uc($arest) eq uc($rest))
		{
			print "list ($lckey) mapped to $la\n";
			$virts{$key} = "$lckey\n$la";
			next OUTER;
		}
	}

	# make sure we don't collide with a userdefined list
	$lastlist++ while defined lookup(%alias,"list-$lastlist");

	print "list ($lckey) mapped to list-$lastlist\n";
# not sure about this one
#	$alias{"OWNER-LIST-$lastlist"} = "owner-list-$lastlist\nowner-$lckey";
	$alias{"LIST-$lastlist"} = "list-$lastlist\n$rest";
	$virts{$key} = "$lckey\nlist-$lastlist";
	$lastlist++;
}
}

# Sanity check; check if all virtuser domains have @<domain> entries.
if ($opt_x) {
	for my $key (sort keys %virts) {
		next if $key =~ /^\@/;
		$key =~ /^.*(@.*)/;
		my $domain = $1;
		my $vals = lookup(%virts,$domain);
		if (! defined $vals) {
			print "missing $domain; added\n";
			$virts{$domain} = "error:nouser \"Unknown user\"";
		}
	}
}

# Ok, nothing went wrong, store the stuff
open(GENER,">generics") || die "Unable to create generics\n";
print GENER "# Automaticly generated with xparse, do NOT edit manualy\n\n";
for my $key (sort keys %generic) {
	print GENER "$generic{$key}\t$key\n";
}
open(ALIAS,">aliases") || die "Unable to create aliases\n";
print ALIAS "# Automaticly generated with xparse, do NOT edit manualy\n\n";
for my $key (sort keys %alias) {
	my ($lckey,$rest) = split("\n",$alias{$key},2);
	$rest =~ tr/\n/,/;
	print ALIAS "$lckey:$rest\n";
}
open(VIRTU,">virtusertable") || die "Unable to create virtusertable\n";
print VIRTU "# Automaticly generated with xparse, do NOT edit manualy\n\n";
for my $key (sort keys %virts) {
	my ($lckey,$rest) = split("\n",$virts{$key},2);
	print VIRTU "$lckey\t$rest\n";
}
exit 0;

sub lookup(\%$)
{
	if (0) {
		my ($hash,$key) = @_;
		$key = uc($key);
		for my $ky (keys %$hash) {
			return $hash->{$ky}
				if uc($ky) eq $key;
		}
	} else {
		my ($hash,$key) = @_;
		$key = $hash->{uc($key)};
		return undef
			if !defined($key);
		return split("\n",$key,2);
	}
	return undef;
}