#!/usr/bin/perl -w

#
# Package contents
#
$keymaps = {};
$keymaps->{i386} = {
    'azerty' => {
	'France' => {
	    'Without Euro' => 'fr-pc',
	    'With Euro' => 'fr-latin0',
	},
	'Belgium' => { 
	    'Standard' => 'be-latin1',
	    'Wang' => 'wangbe',
	    'Alternate' => 'be2-latin1',
	},
    },
    'dvorak' => {
	'Country-independant ?' => {
	    'Standard' => 'dvorak',
	    'ANSI' => 'ANSI-dvorak',
	    'Left single-handed' => 'dvorak-l',
	    'Right single-handed' => 'dvorak-r',
	    'With French and Spanish accents' => 'pc-dvorak-latin1',
	},
    },
    'fgGIod' => {
	'Turkey' => {
	    'trf' => 'trf',
	    'tr_f-latin5' => 'tr_f-latin5',
	},
    },
    'qwerty' => {
    	default => 1,
	'USA' => {
	    default => 1,
	    'Standard' => 'us',
	    'With latin1' => 'us-latin1',
	},
	'UK' => {
	    'Standard' => 'uk',
	},
	'Bulgaria' => {
	    'Standard' => 'bg',
	},
	'Brazil' => {
	    'Standard' => 'br-abnt2',
	},
	'Canada' => {
	    'French' => 'cf',
	    'English' => 'us',
	},
	'Czech Rep.' => {
	    'Standard' => 'cz-lat2',
	    'Programmer' => 'cz-lat2-prog',
	},
	'Denmark' => {
	    'Standard' => 'dk',
	    'Dead keys' => 'dk-latin1',
	},
	'Spain' => {
	    'Standard' => 'es',
	    'CP850' => 'es-cp850',
	},
	'Estonia' => {
	    'Standard' => 'et',
	    'No dead keys' => 'et-nodeadkeys',
	},
	'Finland' => {
	    'Standard' => 'fi-latin1',
	    'Old (obsolete)' => 'fi',
	},
	'Poland' => {
	    'AltGr only diacritics' => 'pl',
	    'Diacritics with AltGr and Alt' => 'pl1',
	},
	'Greece' => {
	    'Standard' => 'gr',
	    'gr-pc' => 'gr-pc',
	},
	'Italy' => {
	    'Standard' => 'it',
	    'it2' => 'it2',
	    'IBM' => 'it-ibm',
	},
	'Lithuania' => {
	    'latin4' => 'lt.l4',
	    'unicode' => 'lt',
	},
	'Latvia' => {
	    'latin4' => 'lv-latin4',
	    'latin7' => 'lv-latin7',
	},
	'Norway' => {
	    'Standard' => 'no',
	    'latin1' => 'no-latin1',
	},
	'Japan' => {
	    'Standard' => 'jp106',
	    'PC 110' => 'pc110',
	},
	'Netherlands' => {
	    'Standard' => 'nl',
	},
	'Israel' =>{
	    'Standard' => 'hebrew',
	},
	'Hungary' => {
	    'Standard' => 'hu101',
	},
	'Iceland' => {
	    'Standard' => 'is-latin1',
	},
	'Latin America' => {
	    'Standard' => 'la-latin1',
	},
	'Macedonia' => {
	    'unicode' => 'mk',
	},
	'Portugal' => {
	    'Standard' => 'pt-latin1',
	    'Old keymap' => 'pt-old',
	},
	'Romania' => {
	    'Standard' => 'ro',
	},
	'Russia' => {
	    'KOI8-R (RightAlt)' => 'ru1',
	    'KOI8-R (RightCtrl)' => 'ru',
	    'KOI8-R (102 Keys)' => 'ru3',
	    'KOI8-R (105 Keys)' => 'ru4',
	    'KOI8-R (MS Cyrillic Layout)' => 'ru-ms',
	    'KOI8-R (Yawerty Layout)' => 'ru-yawerty',
	    'CP-1251 (1)' => 'ru-cp1251',
	    'CP-1251 (2)' => 'ru_win',
	    'CP-866' => 'ru2',
	},
	'Sweden' => {
	    'Standard' => 'se-latin1',
	},
	'Slovakia' => {
	    'Standard' => 'sk-qwerty',
	    'Programmer' => 'sk-prog',
	    'Alternate programmer' => 'sk-prog-qwerty',
	},
	'Turkey' => {
	    '"Q" layout (1)' => 'tr_q-latin5',
	    '"Q" layout (2)' => 'trq',
	    'Alternate' => 'tralt',
	},
	'Ukrain' => {
	    'Standard (koi8u)' => 'ua',
	    'WS' => 'ua-ws',
	    'unicode' => 'ua',
	    'WS - unicode' => 'ua-ws',
	    'Alternate' => 'uaw',
	    'Alternate - unicode' => 'uaw_uni',
	},
    },
    'qwertz' => {
	'Swiss' => {
	    'French' => 'fr_CH',
	    'French - latin1' => 'fr_CH-latin1',
	    'German' => 'sg',
	    'German - latin1' => 'sg-latin1',
	    'German - latin1-lk450' => 'sg-latin1-lk450',
	},
	'Germany' => {
	    default => 1,
	    'Standard' => 'de',
	    'latin1' => 'de-latin1',
	    'latin1 - no dead keys' => 'de-latin1-nodeadkeys',
	},
	'Slovakia' => {
	    'Standard' => 'sk-qwertz',
	    'Programmer' => 'sk-prog-qwertz',
	},
	'Czech Rep.' => {
	    'Standard' => 'cz-us-qwertz',
	},
	'Hungary' => {
	    'Standard' => 'hu',
	},
	'Slovenia' => {
	    'Standard' => 'slovene',
	},
	'Croatia' => {
	    'Standard' => 'croat',
	},
	'Serbia' => {
	    'Standard' => 'sr',
	},
    },
};
$keymaps->{sparc} = {
    'Type 5' => {
    	default => 1,
	'France' => {
	    'Standard' => 'sunt5-fr-latin1',
	},
	'Germany' => {
	    'Standard' => 'sunt5-de-latin1',
	},
	'Spain' => {
	    'Standard' => 'sunt5-es',
	},
	'Finland' => {
	    'Standard' => 'sunt5-fi-latin1',
	},
	'Russia' => {
	    'Standard' => 'sunt5-ru',
	},
	'UK' => {
	    default => 1,
	    'Standard' => 'sunt5-uk',
	},
    },
    'Type 4' => {
	'Spain' => {
	    'Standard' => 'sunt4-es',
	},
    },
    'dvorak' => {
	'Country-independant ?' => {
	    'Standard' => 'sundvorak',
	},
    },
    'Unknown (Poland)' => {
	'Poland' => {
	    'Standard' => 'sun-pl',
	},
    },
};
$keymaps->{atari} = {
    'Unknown' => {
	'Germany' => {
	    'Standard' => 'atari-de',
	    'With dead keys' => 'atari-de-deadkeys',
	    'Emacs-like' => 'atari-de-emacs',
	},
	'Sweden' => {
	    'Standard' => 'atari-se',
	    'With dead keys' => 'atari-se-deadkeys',
	},
	'UK' => {
	    'Standard' => 'atari-uk',
	    'With dead keys' => 'atari-uk-deadkeys',
	},
	'USA' => {
	    default => 1,
	    'Standard' => 'atari-us',
	    'With dead keys' => 'atari-us-deadkeys',
	},
    },
};
$keymaps->{amiga} = {
    'Unknown' => {
	'Germany' => {
	    'Standard' => 'amiga-de',
	},
	'Spain' => {
	    'Standard' => 'amiga-es',
	},
	'France' => {
	    'Standard' => 'amiga-fr',
	},
	'Italy' => {
	    'Standard' => 'amiga-it',
	},
	'Sweden' => {
	    'Standard' => 'amiga-se',
	},
	'Swiss' => {
	    'German' => 'amiga-sg',
	},
	'USA' => {
	    default => 1,
	    'Standard' => 'amiga-us',
	},
    },
};
$keymaps->{mac} = {
    'Unknown' => {
	'Germany' => {
	    'Standard' => 'mac-de2-ext',
	    'No dead keys (broken)' => 'mac-de-latin1-nodeadkeys',
	},
	'France' => {
	    'Standard' => 'mac-fr3',
	    'Alternate' => 'mac-fr2-ext',
	},
	'USA' => {
	    default => 1,
	    'Standard' => 'mac-us-std',
	    'Extended' => 'mac-us-ext',
	},
    },
};

#
# Package history
#

# This is an array containing keymaps descriptions not installed any more,
# without the filename
# FIXME: would be nice to have prefix-match here, to make size drop
$obsolete_keymaps = [
		     # Until 1999.08.29-5: old swiss descriptions
		     'i386:qwertz:sg (?):Standard',
		     'i386:qwertz:sg (?):latin1',
		     'i386:qwertz:sg (?):latin1-lk450',
		     'i386:qwertz:Swiss (french):Standard',
		     'i386:qwertz:Swiss (french):latin1',
		     'i386:qwertz:Finland:latin1',
		     # Until 1999.08.29-8: US->USA, "Unknown"->"Unknown (Poland)"
		     'i386:qwerty:US:Standard',
		     'i386:qwerty:US:With latin1',
		     'sparc:Unknown:Poland:Standard',
		     ];

# END OF DATAPACKAGE-SPECIFIC PART
# BELOW THIS LINE IS THE GENERIC PART

# This a preliminary debconf script for console-related data.
# (c) 1999, Yann Dirson <dirson@debian.org>

# It has the following limitations that should be addressed:
# - only handles keymap configuration (ie, only does part of kbdconfig's job)
# - does not allow testing keymap before accepting it (REGRESSION).
# - does not allow reloading a default keymap (REGRESSION).

use Debian::DebConf::Client::ConfModule ':all';

die "Syntax error: no argument" if ($#ARGV < 0);

# Subarches
# FIXME: not done
# Issues:
# * ppc issues not fully asserted yet
# * /proc/hardware, which only exists on m68k and ppc, seems to be
#   an OPTION while configuring the kernel !
#   Any fallback when it's not there ?
# * USB set of keymap should contain what ? mac ? i386 ? subset of those ?

# SUBARCH	KEYMAP SET	DETECTION
# m68k/atari	atari		"Model: Atari"
# m68k/amiga	amiga		"Model: Amiga"
# m68k/mac	mac		"Model: Macintosh"
# m68k/mvme	i386		"Model: Motorola"
# m68k/bvme	i386		"Model: BVME[46]000"
# m68k/{sun,apollo,next,q40,hp300} Not supported by Debian

# ppc/apus	amiga		"Model: Amiga"
# ppc/chrp	i386,mac	"Model: CHRP"
# ppc/pmac	mac		"Model: PowerMac|[Pp]ower[Bb]ook*|Power|iMac*|PowerMac1*"
# ppc/prep	i386		"Model: PReP"
# ppc/{bbox,mbx,ppc64,82xx,8xx} Not yet supported by Debian
sub guess_arch {
    my ($defs) = @_;

    my $arch = `dpkg --print-installation-architecture`;
    chomp $arch;

# Overrides for testing:
#     $arch = 'powerpc';
#     $arch = 'm68k';

    if (($arch eq 'powerpc') || ($arch eq 'm68k')) {
	my $subarch;
	if ($arch eq 'powerpc') {
	    my $line = `grep ^machine /proc/cpuinfo`;
	    chomp $line;
	    abort ($defs, "No \"machine\" field in /proc/cpuinfo") if $line eq '';
	    $subarch = lc substr ($line, 11);
	} elsif ($arch eq 'm68k') {
	    my $line = `grep ^Model: /proc/hardware`;
	    chomp $line;
	    abort ($defs, "No \"Model\" field in /proc/hardware") if $line eq '';
	    $subarch = lc substr ($line, 6);
	}
	chomp($subarch);
	$subarch =~ s/^\s*//;
	$subarch = 'amiga'	if $subarch =~ m/^amiga/;
	$subarch = 'chrp'	if $subarch =~ m/^chrp/;
	$subarch = 'prep'	if $subarch =~ m/^prep/;
	$subarch = 'mac'	if $subarch =~ m/^macintosh|powermac|powerbook|power|imac|powermac1/;
	$subarch = 'atari'	if $subarch =~ m/^atari/;
	$subarch = 'mvme'	if $subarch =~ m/^motorola/;
	$subarch = 'bvme'	if $subarch =~ m/^bvme/;
	
	$arch = "$arch/$subarch";
    }

# Overrides for testing:
#     $arch = 'sparc';
#     $arch = 'powerpc/mac';
#     $arch = 'powerpc/chrp';
#     $arch = 'm68k/amiga';
#     $arch = 'alpha';

    return $arch;
}

sub abort {
    my ($defs, $msg) = @_;
    print STDERR "Debconf module aborted ($msg) - using old config mechanism.\n";
    fset_default($defs);
    exit 0;
}

sub merge_hashes {
    my @hashes = @_;
    my $outhash;
    
    foreach $inhash (@hashes) {
	my $key;
	while (defined ($key = each %{$inhash})) {
	    # FIXME: should assert there are no duplicates by disambiguating if needed
	    $outhash->{$key} = $inhash->{$key};
	}
    }

    return $outhash;
}

# # TEST
# use Data::Dumper;
# $h1 = { 'a' => 'z', 'e' => 'r' };
# $h2 = { 'q' => 's', 'd' => 'f' };
# $h = merge_hashes ($h1, $h2);
# print Dumper($h1);
# print Dumper($h2);
# print Dumper($h);
# exit 0;
# # /TEST

#
# multilevel-select library
#

$SEP = ":";

sub item2list {
    my ($item) = @_;
    return split (/$SEP/, $item);
}

sub list2item {
    my (@list) = @_;
    return join ($SEP, @list);
}

sub item_matches {
    my ($item, $pattern) = @_;
    my @item = item2list $item;
    # strip filename
    pop @item;
    return $pattern eq list2item (@item);
}

# Convert Hash-tree into Array of strings for the debconf DB
sub h2a {
    my ($hashRef) = @_;
    my @array = ();
    foreach my $key (keys %$hashRef) {
	if (ref ($hashRef->{$key})) { # CASE: hash
	    my @a = h2a($hashRef->{$key});
	    push (@array, map ("$key$SEP" . $_, @a));
	} else { # CASE: leaf
	    push (@array, "$key$SEP$hashRef->{$key}");
	}
    }
    return @array;
}

# ...and reverse
sub a2h {
    my (@array) = @_;
    my $hash = {};
    foreach my $item (@array) {
	my @path = item2list $item;
	if ($#path < 1) {
	    die "Error in data definition";
	}
	my $curHash = $hash;
	# create the hash hierarchy, leaving the last 2 componants alone
	if ($#path >= 2) {
	    for ($i = 0; $i <= ($#path-2); $i++) {
		$elem = $path[$i];
		if (! exists ($curHash->{$elem})) {
		    # create a sub-hash if none is there yet
		    $curHash->{$elem} = {};
		} elsif (ref ($curHash->{$elem}) ne 'HASH') {
		    # we come here if a description item is too short.
		    # This is probably a bug in the description (eg. embedded
		    # comma in a string), so we just throw the old hash
		    # value and insert a hash instead.
		    $curHash->{$elem} = {};
		}
		$curHash = $curHash->{$elem};
	    }
	}
	# add the last 2 componants where they belong
	$curHash->{$path[-2]} = $path[-1];
    }
    return $hash;
}

# Add our declarations
sub merge_into {
    my ($defs) = @_;
    my ($code, $ret) = metaget ($defs->{registry}, 'choices');
    my @existing = split (/, */, $ret);
    my $addeditems = 0;

    # add in @existing each of our items not already there
    foreach my $item (h2a($defs->{allitems})) {
	die "Item description must not contain comma ! ($item)" if $item =~ /, */;
	my @found = grep {$item eq $_} @existing;
	if ($#found == -1) {
#	    print STDERR "TRACE: Adding $item\n";
	    push (@existing, $item);
	    $addeditems = 1;
	}
    }

    # update the debconf DB
    if ($addeditems == 1) {
	subst ($defs->{registry}, 'choices', join (", ", @existing));
	# we added something: re-ask the user
	fset_default ($defs);
    }

    $defs->{allitems} = a2h @existing;
}

# Remove our declarations
sub remove_from {
    my ($defs) = @_;
    my ($code, $ret) = metaget ($defs->{registry}, 'choices');
    my @existing = split (/, */, $ret);
    my @mine = h2a($defs->{allitems});
    my @new = ();

    # copy each item not in @mine from @existing to @new
    foreach my $item (@existing) {
	my @found = grep {$item eq $_} @mine;
	if ($#found == -1) {
	    push (@new, $item);
	}
    }

    # update the debconf DB
    subst ($defs->{registry}, 'choices', join (", ", @new));
    
    # DEBUG
    metaget ($defs->{registry}, 'choices');
}

# Do one level of user-querying.
# This is the heart of the hierarchical mechanism.
sub onelevel {
    my ($hash, $confvar, $prevState, $nextState) = @_;
    my ($code, $choice, $newState, $oldchoice);

    # get choices to be presented
    # This is a two-level sort; items that are default sort first,
    # with fallback to a lexical ordering.
    my @choices = sort { 
    	(-1 * exists $hash->{$a}->{default} || exists $hash->{$b}->{default})
    			        ||
			 uc($a) cmp uc($b)
    } grep { $_ ne 'default' } keys %$hash;
    # insert them in debconf variable definition, and ask
    my $choices = join (', ', @choices);
    subst ($confvar, 'choices', $choices);
    input ('high', $confvar);
    # memorize old choice
    ($code, $oldchoice) = get ($confvar);
    #
    ($code, undef) = go ();
    if ($code == 30) {	# "back"
	$newState = $prevState;
    } elsif ($code == 0) {
	(undef, $choice) = get ($confvar);
	$newState = $nextState;
    } else {
	die "go() returned unhandled code $code";
    }

    my $newchoice = {};
    my $changed = 0;
    if (defined $choice) {
	$newchoice = $hash->{$choice};
	$changed = ($choice ne $oldchoice);
    }

#    print "Choice: $newchoice, State: $newState\n";
    return ($newchoice, $newState, $changed);
}

# remove from the debconf DB all specified obsolete items
sub cleanup_old_items {
    my ($defs) = @_;
    
    my ($code, $olditems) = metaget ($defs->{registry}, 'choices');
    die "metaget failed in cleanup_old_items()" if ($code != 0);

    my @olditems = split (/, */, $olditems);
    my @newitems = ();
  ITEM:
    foreach $item (@olditems) {
	# ignore items found in obsolete list
	my @found = grep {item_matches ($item, $_)} $defs->{obsolete};
	next ITEM if ($#found != -1);

	# ignore items with a wrong depth
	my @item = item2list $item;
	# note that arch and final value are not listed in 'levels'
	# FIXME: this impairs genericity - arch should not be treated specially
	next ITEM if ($#item != 2 + $#{$defs->{levels}});

	push (@newitems, $item);
    }

    subst ($defs->{registry}, 'choices', join (', ', @newitems));
}

# ensure our debconf entries are in a good shape, given the
# hierarchy of choices.
sub sanitize {
    my ($defs) = @_;

    # set all isdefault flags if any of them is
  VAR:
    foreach $var (@{$defs->{levels}}) {
	my ($code, $isdef) = fget ($var, 'isdefault');
	if ($isdef eq "true") {
	    fset_default ($defs);
	    last VAR;
	}
    }
}

sub fset_default {
    my ($defs) = @_;

    my @levels = @{$defs->{levels}};
    push (@levels, $defs->{output});

    foreach my $level (@levels) {
	fset ($level, 'isdefault', 'true');
    }
}

sub hselect_setup {
    my ($defs) = @_;

    sanitize ($defs);
}

# BELOW THIS LINE IS STUFF FOR ALL KEYMAP PROVIDERS

$keymap_defs = {
    'levels' => ['shared/keymap/layout',
		 'shared/keymap/country', 
		 'shared/keymap/variant'],
    'registry' => 'shared/keymap/keymap',
    'output' => 'shared/keymap/keymap_filename',
    'allitems' => $keymaps,
    'obsolete' => $obsolete_keymaps,
    'archsets' => {
	'i386' => [ 'i386' ],
	'hurd-i386' => [ 'i386' ],
	'sparc' => ['sparc' ],
	'alpha' => [ 'i386' ],
	'arm' => [ 'i386' ],
#	'mips' => [ 'i386' ],
	'm68k/atari' => [ 'atari' ],
	'm68k/amiga' => [ 'amiga' ],
	'm68k/mac' => [ 'mac' ],
	'm68k/mvme' => [ 'i386' ],
	'm68k/bvme' => [ 'i386' ],
	'powerpc/amiga' => [ 'amiga' ],
	'powerpc/chrp' => [ 'i386', 'mac' ],
	'powerpc/mac' => [ 'mac' ],
	'powerpc/prep' => [ 'i386' ],
    },
};

sub kmap_setup {
    my ($defs) = @_;

    $hw_arch = guess_arch($defs);

    $defs->{architems} = merge_hashes (map ($defs->{allitems}->{$_},
					    @{$defs->{archsets}->{$hw_arch}}));

# ASSERT arch is supported
    die "Please report this bug: no keymaps described for architecture $hw_arch"
	unless defined $defs->{architems};
}

# The real config engine 
# FIXME: Could be abstracted to not have all states hardcoded (the hard part)
sub configure {
    my ($defs) = @_;

    my ($state, $countriesRef, $variantsRef, $changed);
    $state=0;

    cleanup_old_items ($defs);

    # This is a simple state machine
    while ($state != 99) {
	($state == 0) && do {	# get_layout
	    ($countriesRef, $state, $changed) =
		onelevel ($defs->{architems}, $defs->{levels}->[0], 0, 1);
#  	    if ($ret eq "back") {
#  		previous_module;
#  		exit;
#  	    }
	    if ($changed) {
		reset $defs->{levels}->[1];
	    }
	    next;
	};

	($state == 1) && do {	# get_country
	    ($variantsRef, $state, $changed) =
		onelevel ($countriesRef, $defs->{levels}->[1], 0, 2);
	    if ($changed) {
		reset $defs->{levels}->[2];
	    }
	    next;
	};

	($state == 2) && do {	# get_variant
	    (undef, $state, $changed) =
		onelevel ($variantsRef, $defs->{levels}->[2], 1, 99);

	    if ($changed) {
		(undef, $variant) = get ($defs->{levels}->[2]);
		$keymapFilename = $variantsRef->{$variant};
		set ($defs->{output}, $keymapFilename);
	    }
	    next;
	};
    }
}


# FIXME: to be abstracted (easy)
sub deconfigure {
    my ($defs) = @_;

    my ($code, $ret, $layout, $country, $variant, $filename);

    # I no longer claim this variable.
    ($code, $ret) = unregister ($defs->{registry});
    die "unregister returned ($code,$ret)" if ($code != 0);

    ($code, $ret) = get ($defs->{registry});
    if ($code == 0) {
	# Unregister our alternatives
	remove_from ($defs);
	# If current choice was one of ours, ask for re-selection
	($code, $layout) = get ($defs->{levels}->[0]);
	($code, $country) = get ($defs->{levels}->[1]);
	($code, $variant) = get ($defs->{levels}->[2]);
	($code, $filename) = get ($defs->{output});
	# do not try to match architecture, as one arch may use serval sets of keymaps
	my @found = grep (/$SEP$layout$SEP$country$SEP$variant$SEP$filename$/, h2a($defs->{allitems}));
	if ($#found != -1) {
	    fset_default($defs);
	    configure($defs);
	}
    }
}

# GO !

hselect_setup ($keymap_defs);
kmap_setup ($keymap_defs);
capb ('backup');

if ($ARGV[0] eq 'configure') {
    merge_into ($keymap_defs);
    configure($keymap_defs);
}
elsif ($ARGV[0] eq 'reconfigure') {
    configure($keymap_defs);
}
elsif ($ARGV[0] eq 'X-deconfigure') {
    deconfigure($keymap_defs);
}