#! /usr/bin/perl -w
#
# dpkg-subarchitecture
#
# Copyright 2003 Bart Trojanowski <bart@jukie.net>
#
# 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 of the License, or
# (at your option) any later version.
#
# 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, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA

use strict;

# History
#  1.10.10  Initial release.

my $version="1.10.18";
my $prog = `basename $0`; chomp $prog;

my $dpkglibdir="/usr/lib/dpkg";
my $dpkgsharedir = "/usr/share/dpkg";
#push(@INC,$dpkglibdir);
#require 'controllib.pl';

#my $subarchtablefile = "./subarchtable";
my $subarchtablefile = "$dpkgsharedir/subarchtable";

sub usageversion {
    print STDERR
"Debian $prog $version.  Copyright (C) 2003 Bart Trojanowski
This is free software; see the GNU General Public Licence version 2
or later for copying conditions.  There is NO warranty.

Usage:
  $prog [<option> ...] [<action>]
Options:
       -f<subarchtable>   read from non default file
                              (default: $subarchtablefile)
       -a<debian-arch>    set Debian architecture.
       -t<gnu-system>     set GNU system type.
Actions:
       -d                 (debug) dump of entire subarch table.
       -l                 list variables.
       -q<variable>       prints only the value of <variable>.
       -Q<variable>       like -q but case sensative (and faster).
       -b                 prints only the values of Build-* variables.
       -s                 prints all sub-architectures of requested arch.
       -S<subarch>        returns true (0) if <subarch> is a valid sub-arch.
       -L<subarch>        lib-dir for <subarch>.

";
}

# global architecture table
my %architectures = ();

# regular expressions for different parts of the file
my $archre = "[a-z][a-z0-9]\+";
#my $tagre = "[A-Z][A-Z0-9_]*";
my $tagre = "[A-Z][A-Z0-9_]*(?:_${archre})?";
my $valre = ".\+";

my @required_arch_tags = ("ABI", "LIB_DIR");
my @allowed_arch_tags = ("ARCHITECTURE", "ALIASES", "BITS", 
	"COMPAT", "ABI", "LIB_DIR(_$archre)?", 
	"BUILD_[A-Z][A-Z0-9]\+");

sub commit_archvars {
	my ($arch, $varsref) = @_;
	my %vars = %$varsref;

	#print "\n";
	($arch eq "__defaults__" or defined $architectures{__defaults__})
		or die "subarchtable:$arch: DEFAULTS must be defined "
			. "first\n";
	
	# bypass everything if this is the defaults bock
	if ($arch eq '__defaults__') {
		$architectures{$arch} = \%vars;
		return;
	}

	# make sure required keys are available
	foreach my $tag (@required_arch_tags) {
		die "subarchtable: ARCHITECTURE '$arch' does not define $tag\n"
			if (not defined $vars{$tag})
	}

	# if the architecture tag is not present set it
	$vars{ARCHITECTURE}=$arch if (not defined $vars{ARCHITECTURE});

	# test supplied tags and do ${var} variable substitutions
	foreach my $tag (keys %vars) {
		my $good = 0;

		LOOP: foreach my $allow (@allowed_arch_tags) {
			if ($tag =~ m/$allow/) {
				$good = 1;
				last LOOP;
			}
		}
		die "subarchtable: '$tag' is not supported\n" if (not $good);

		# expand variables in value string
		$vars{$tag} =~ s/\$\{($tagre)\}/&hash_lookup($1,\%vars)/eg;
	}

	$architectures{$arch} = \%vars;
}

sub hash_lookup {
	my ($tag,$varsref) = @_;

	return "\$\{$tag\}" if (not defined $tag);
	return "\$\{$tag\}" if (not defined $$varsref{$tag});

	return $$varsref{$tag};
}

sub read_table {
	open (SA,"< $subarchtablefile") 
		or die "could not open $subarchtablefile for reading\n";

	my $arch = "";
	my $line = 0;

	my %archvars = ();

	LOOP: while (<SA>) {
		$line ++;
		next LOOP if (m/^\s*#/);

		# prepare line
		chomp;
		s/\s*#.*$//;

		#print "> $_\n";

		# parse out the tag and value from the line
		my ($tag, $val) = ("","");
		if ($_ eq "") {
			if (length $arch) {
				commit_archvars ($arch, \%archvars);
				my $allref = $architectures{__defaults__};
				%archvars = %$allref;
				$arch="";
			}
			next LOOP;
		} elsif (m/^($tagre):\s*($valre)\s*$/) {
			($tag, $val) = ($1, $2);
		} elsif (m/^($tagre):\s*$/) {
			$tag = $1;
			undef $val;
		} else {
			die "subarchtable:$line: invalid line syntax:\n$_\n";
		}

		#printf "  %-20s", $tag, $val;
		#print "$val" if (defined $val);
		#print "\n";

		# test type of tag
		if ($tag eq "DEFAULTS") {
			$arch = "__defaults__";
			next LOOP;
		} elsif ($tag eq "ARCHITECTURE") {
			$arch = $val;
			next LOOP;
		} elsif (not length $arch) {
			die "subarchtable:$line: DEFAULTS or ARCHITECTURE tag "
				. "must be the first in a block\n$_\n";
		}

		if (defined $val) {
			$archvars{$tag} = $val;
		} else {
			delete $archvars{$tag};
		}
	}

	commit_archvars ($arch, \%archvars) if (length $arch);

	close (SA);
}

# ---------------------------------------------------------------------------

sub var_to_shvar {
	my ($var) = @_;

	#$var =~ tr/a-z/A-Z/;
	#$var =~ tr/-/_/;

	return $var;
}

# ---------------------------------------------------------------------------

sub dump_arch {
	my ($arch) = (@_);
	my $varsref = $architectures{$arch};
	my %vars = %$varsref;

	print "$arch\n";

	foreach my $key (sort keys %vars) {
		printf "\t%-20s %s\n", $key, $vars{$key};
	}

	print "\n";
}

sub dump_table {
	foreach my $arch (sort keys %architectures) {
		dump_arch ($arch);
	}
}

sub print_vars {
	my ($arch, $match) = @_;

	my $varsref = $architectures{$arch};
	my %vars = %$varsref;

	LOOP: foreach my $key (sort keys %vars) {
		my $val = $vars{$key};
		(defined $val) or next LOOP;

		if (defined $match) {
			($key =~ m/$match/) or next LOOP;
			$key =~ s/$match//;
		}

		my $shvar = var_to_shvar($key);
		$val =~ s/^(.+\s.+)$/\"$1\"/;
		print "$shvar=$val\n";
	}
}

sub print_one {
	my ($arch, $key) = @_;

	my $varsref = $architectures{$arch};
	my %vars = %$varsref;

	my $val = $vars{$key};

	(defined $val)
	  or die "dpkg-subarchitecture: unknown variable \`$key'\n";

	print "$val\n";
}

sub print_one_i {
	my ($arch, $key) = @_;

	my $varsref = $architectures{$arch};
	my %vars = %$varsref;

	my $val = $vars{$key};

	if (not defined $val) {

		my $seek = $key;
		$seek =~ tr/A-Z/a-z/;

		LOOP: foreach my $realkey (keys %vars) {
			my $smallkey = $realkey;
			$smallkey =~ tr/A-Z/a-z/;

			if ($seek eq $smallkey) {
				$val = $vars{$realkey};
				last LOOP if (defined $val);
			}
		}
	}

	(defined $val)
	  or die "dpkg-subarchitecture: unknown variable \`$key'\n";

	print "$val\n";
}

sub get_subarchs {
	my ($arch) = @_;

	my $varsref = $architectures{$arch};
	my %vars = %$varsref;

	(defined $vars{COMPAT}) or return "";

	my @ret = ();

	foreach my $sub (split /\s*,\s*/, $vars{COMPAT}) {
		push @ret, $sub;
		(defined $architectures{$sub})
			or die "dpkg-subarchitecture: unknown architecture "
				. "\`$sub'\n";
		push @ret, get_subarchs ($sub);
	}

	return @ret;
}

sub print_subarchs {
	my ($arch) = @_;
	my @subarchs = get_subarchs ($arch);

	print join ' ', @subarchs;
}

sub test_subarch {
	my ($arch, $subarch) = @_;

	# if they are the same they are compatible
	($arch ne $subarch) or return;

	(defined $architectures{$subarch})
	  or die "dpkg-subarchitecture: unknown architecture \`$subarch'\n";

	my $allsubs = join (' ', get_subarchs($arch));

	($allsubs =~ m/(\W|^)$subarch(\W|$)/)
		or die "dpkg-subarchitecture: \`$subarch' is not a "
				. "sub-architecture of \`$arch'\n";
}

sub print_subarch_libdir {
	my ($arch, $seekarch) = @_;

	my $varsref = $architectures{$arch};
	my %vars = %$varsref;

	my $libdir=$vars{"LIB_DIR"};

	my $allsubs = join (' ', get_subarchs($arch));
	($allsubs =~ m/(\W|^)$seekarch(\W|$)/)
		or die "dpkg-subarchitecture: unknown subarch "
				. "\`$seekarch'\n";

	LOOP: foreach my $sub (split /\s*,\s*/, $vars{COMPAT}) {
		(defined $vars{"LIB_DIR_$sub"}) or last LOOP;

		if ($sub eq $seekarch) {
			$libdir=$vars{"LIB_DIR_$sub"};
			last LOOP;
		}

		my $branchsubs = join (' ', get_subarchs($sub));

		if ($branchsubs =~ m/(\W|^)$seekarch(\W|$)/) {
			$libdir=$vars{"LIB_DIR_$sub"};
			last LOOP;
		}
	}

	print "$libdir\n";
}


# ---------------------------------------------------------------------------

my $action = '';
my $actncnt = 0;
my $req_host_arch = `dpkg-architecture -qDEB_HOST_ARCH`;

while (@ARGV) {
	$_=shift(@ARGV);
	if (m/^-h$/ or m/^--help$/) {
		usageversion;
		exit 0;
	} elsif (m/^-f/) {
		$subarchtablefile = $';
	} elsif (m/^-a/) {
		$req_host_arch = $';
	} elsif (m/^-t/) {
		my $req_host_arch = `dpkg-architecture -t$' -qDEB_HOST_ARCH`;
	} elsif (m/^-([dlsb])$/) {
		$action = $1;
		$actncnt++;
	} elsif (m/^-d/) {
		$action = "d$'";
		$actncnt++;
	} elsif (m/^-L/) {
		$action = "L$'";
		$actncnt++;
	} elsif (m/^-S/) {
		$action = "S$'";
		$actncnt++;
	} elsif (m/^-([Qq])/) {
		$action = "$1$'";
		$actncnt++;
	} else {
		die "dpkg-subarchitecture: unknown option \`$_'\n";
	}
}

chomp $req_host_arch;

if ($actncnt != 1) { usageversion; exit 1; }

read_table;

(defined $architectures{$req_host_arch})
  or die "dpkg-subarchitecture: unknown architecture \`$req_host_arch'\n";

if ($action eq 'd') {
	dump_table;

} elsif ($action =~ m/^d($valre)/) {
	dump_arch ($1);

} elsif ($action eq 'l') {
	print_vars ($req_host_arch);

} elsif ($action =~ m/^q($tagre)/) {
	print_one ($req_host_arch, $1);

} elsif ($action =~ m/^Q($tagre)/i) {
	print_one_i ($req_host_arch, $1);

} elsif ($action eq 's') {
	print_subarchs ($req_host_arch);

} elsif ($action eq 'b') {
	print_vars ($req_host_arch, "^BUILD_");

} elsif ($action =~ m/^S($valre)/) {
	test_subarch ($req_host_arch, $1);

} elsif ($action =~ m/^L($valre)/) {
	print_subarch_libdir ($req_host_arch, $1);

} else {
	die "dpkg-subarchitecture: internal error (action=$action)\n";
}