#!/usr/bin/perl -w
use strict;
sub format_ochar_c ($) {
my($C, $c) = shift;
map { /\@$/ and 'WCH_DEAD'
or /^-1$/ and 'WCH_NONE'
or /^%%$/ and 'WCH_LGTR'
or ($c = $_) =~ s/^([0-9A-Z])$/'$1'/i and $c
or ($c = chr hex) =~ /[\\'']/ and "'\\$c'"
or ($c = chr hex) =~ /[\x20-\x7e]/ and "'$c'"
or "0x$_"
} $C;
}
sub format_key_line_c ($$@) {
my($vk, $F, @B) = @_;
# sprintf " {%-13s,%-7s,%s},\n", $vk, $F, join ',', map {sprintf '%-9s', $_} @B;
sprintf " {%-13s,%-20s,%s},\n", $vk, $F, join ',', map {sprintf '%-9s', $_} @B;
}
my %CL_flags = (qw(0 0 1 CAPLOK 4 CAPLOKALTGR SGCap SGCAPS), 5 => 'CAPLOK | CAPLOKALTGR');
sub translate_key_line_c($$$$) {
my($prev_vk, $b_len, $in, $LIG) = (shift, shift, shift, shift);
# $prev_vk = $$prev_vk;
$in =~ s(\s+//.*)();
$in =~ s(^\s+)();
my($scan, $vk, $flags, @bind, @prefix, $c, $neg1, @O, @LIG) = split /\s+/, $in;
push @bind, ('-1') x ($b_len - @bind) if $b_len > @bind;
$#bind = $b_len - 1 if $b_len < @bind;
@prefix = @bind if grep /\@$/, @bind;
$_ eq '-1' and $neg1++ for $scan, $vk;
die "VK=$vk in combination with SC=$scan (I expect -1 -1)" if 1 == ($neg1 || 0);
$vk =~ s/^([0-9A-Z])$/'$1'/ or $vk = "VK_$vk";
my $prev_LIG;
if ($vk eq 'VK_-1') {
# $flags eq 'SGCap' or die "non-SGCap line with VK=-1";
defined ($vk = $prev_vk->[0]) or die "SGCap continuation line not preceded by SGCap line";
$prev_LIG = $prev_vk->[1];
$prev_vk->[0] = undef;
$#bind = 1 if $#bind > 1;
$#bind = 0 if '-1' eq ($bind[1] || '-1');
} else {
$prev_vk->[0] = ($flags eq 'SGCap' ? $vk : undef);
}
$#$prev_vk = 0 if $#$prev_vk > 0;
defined (my $F = $CL_flags{$flags}) or die "Unexpected value in FLAGS: <$flags> in: $in";
@$LIG = ($vk, grep {$bind[$_] =~ /%%/} 0..$#bind);
if (defined $prev_vk->[0]) {
$prev_vk->[1] = [map {scalar($bind[$_] =~ /%%/)} 0..$#bind];
} elsif ($prev_LIG) {
my @conflicts = grep {$bind[$_] =~ /%%/ and $prev_LIG->[$_]} 0..$#bind;
warn "Conflicts for CapsLock bindings: positions @conflicts" if @conflicts;
my $max = $#bind;
$max = $#$prev_LIG if $max < $#$prev_LIG;
@$LIG = ($vk, grep {($bind[$_] || '') =~ /%%/ or $prev_LIG->[$_]} 0..$max);
warn '<', join('> <', @$LIG), '>' if $vk eq "'T'";
}
push @O, format_key_line_c $vk, $F, map format_ochar_c($_), @bind;
s/\@$// or $_ = -1 for @prefix;
push @O, format_key_line_c '0xff', 0, map format_ochar_c($_), @prefix if @prefix;
@O
}
sub extract_section ($$;$) {
my($in, $sec, $strip) = (shift, shift, shift);
$in =~ s([^\S\n]*//.*)()g; # remove comments
$in =~ s([^\S\n]+$)()gm; # remove trailing whitespace (including \r!)
$in =~ s/\A.*?^\s*$sec([ \t]*;[^\n]*)?\n//sm or die "Cannot find $sec inside the KLC file";
$in =~ s/^[^\S\n]*(KEYNAME|LIGATURE|COPYRIGHT|COMPANY|LOCALENAME|LOCALEID|VERSION|SHIFTSTATE|LAYOUT|ATTRIBUTES|KEYNAME_EXT|KEYNAME_DEAD|DESCRIPTIONS|LANGUAGENAMES|ENDKBD)\b.*//ms
or die "Cannot find end of $sec inside the KLC file";
$in =~ s/^\n//gm if $strip; # remove empty lines
$in
}
sub fix_liga ($$) {
my($in, $LIGS, %idx) = (shift, shift);
my @in = split /(?<=,)(?=\s*\{)/, $in;
my $z = pop @in;
for my $l (@in) {
my($vk, $i) = ($l =~ /^\s*\{\s*(\S+)\s*,\s*(\d+)\s*,/) or die "Unrecognized LIGATURE: <<$l>>";
my $LIGs = $LIGS->{$vk} or die "Can't find WCH_LGTRs for <$vk>";
defined (my $LIG = $LIGs->[$idx{$vk}++ || 0]) or die "Too many LIGATURES for <$vk>: I see $idx{$vk}; command line argument too low?";
my $exp = substr $LIG, 0, 1;
$i == $LIG or $i == $exp or die "Unexpectedly broken LIGATURE for <$vk>: see $i, expect $exp or $LIG (in [@$LIGs])";
$l =~ s/^(\s*\{\s*\S+\s*,\s*)(\d+)\b/$1$LIG/ or die "Panic in s///???";
}
join '', @in, $z
}
sub format_modifiers ($) {
my ($in, @bits, @out) = (shift, qw(Shift Ctrl Alt Kana Roya Loya Z T));
push @out, (($in & (1<<$_)) ? $bits[$_] : '') for 0..$#bits;
(my $O = join "\t", @out) =~ s/\t+$//;
$O;
}
sub produce_masks (@) {
my(@masks, @OUT) = @_;
$OUT[$masks[$_]] = $_ for 0..$#masks;
defined and $_ != 15 or $_ = 'SHFT_INVALID' for @OUT;
<<EOP
$#OUT,
{
// Modification# // ORed bitmap for pressed modifiers
// ============= // =================================
EOP
. join( '', map { sprintf "\t%-14s// %s\n", "$OUT[$_],", format_modifiers $_ } 0..$#OUT )
. <<EOP;
}
EOP
}
if (@ARGV == 1) {
my $b_len = shift;
my $layout = do {local $/; <>};
$layout = extract_section $layout, 'LAYOUT', 'strip';
my(@prev_vk, @LIG);
for my $in (split /\n/, $layout) {
print for translate_key_line_c \@prev_vk, $b_len, $in, \@LIG;
}
exit;
}
my @prev_len = (8, 1);
if (@ARGV == 4) {
my($src_klc, $src_c, @b_len) = (shift, shift, shift, shift);
@ARGV = $src_klc;
my $klc = do {local $/; <>};
@ARGV = $src_c;
my $c_file = do {local $/; <>};
my $layout = extract_section $klc, 'LAYOUT', 'strip';
my (@pass_table, @prev_vk, $skip_m1, %LIG) = ('');
# for my $pass (0, 1) {
for my $in (split /\n/, $layout) {
my ($vk) = ($in =~ /^\s*\S+\s+(\S+)\b/);
$skip_m1 = 1, next if $vk =~ /^(ABNT_C2|OEM_8|SPACE)$/; # In len=6 section
$skip_m1 = 0, next if $skip_m1 and $in =~ /^\s*-1\s+-1\b/;
$skip_m1 = 0;
my $pass = ($vk =~ /^((F|NUMPAD)\d+|HOME|UP|PRIOR|DIVIDE|LEFT|CLEAR|RIGHT|MULTIPLY|END|DOWN|NEXT|SUBTRACT|INSERT|DECIMAL|DELETE|ADD|RETURN)$/);
$pass_table[$pass] .= join '', translate_key_line_c \@prev_vk, $b_len[$pass], $in, \my @LIG;
my $VK = shift @LIG;
$LIG{$VK} = \@LIG;
#warn "DECIMAL --> [@LIG] for: $in" if $VK eq 'VK_DECIMAL';
}
# }
my $extra_sizes = join "\n", '', map "TYPEDEF_VK_TO_WCHARS($_) // VK_TO_WCHARS$_, *PVK_TO_WCHARS$_;", grep $_>10, @b_len;
$c_file =~ s/(\A.*^\s*#\s*include\s+[^\n]+)/$1\n\n$extra_sizes/ms if $extra_sizes;
for my $p (0, 1) {
my $s = $prev_len[$p];
my $S = $b_len[$p];
$c_file =~ s((\s*static\s+ALLOC_SECTION_LDATA\s+VK_TO_WCHARS)$s(\s+aVkToWch)$s(\s*\[\s*\]\s*=\s*\{[ \t]*(?:\n\s*//[^\n]*)*).*?(?=[ \t]*\{\s*0\s*,))
($1$S$2$S$3\n$pass_table[$p])s;
$c_file =~ s<(\{\s*\(\s*PVK_TO_WCHARS1\s*\)\s*aVkToWch)$s(\s*,\s*)$s(\s*,\s*sizeof\s*\(\s*aVkToWch)$s(\s*\[\s*0\s*\]\s*\)\s*\}\s*,)>
# $c_file =~ s<(\{\s*\(\s*PVK_TO_WCHARS1\s*\)\s*aVkToWch)$s(\s*,\s*)$s(\s*,\s*sizeof\s*\(\s*aVkToWch)$s>
($1$S$2$S$3$S$4)s; # { (PVK_TO_WCHARS1)aVkToWch2, 2, sizeof(aVkToWch2[0]) },
}
$c_file =~ s/(\baLigature\s*\[\s*\]\s*=\s*\{\s*)(.*?)(?=\s*\}\s*;)/ $1 . fix_liga $2, \%LIG /se
or $c_file !~ /\baLigature\b/ or die "Can't find LIGATURE table definition";
my $masks = extract_section $klc, 'SHIFTSTATE', 'strip'; # Semantic of empty lines unclear; for now, ignore
my @masks = map {/^\s*(\d+)/ and $1} split /\n/, $masks;
my $Omasks = produce_masks @masks;
$c_file =~ s/(&aVkToBits\s*\[\s*0\s*\]\s*,[ \t]*\n).*?^\s+\}[ \t]*\n/$1$Omasks/ms
or $c_file !~ /\baLigature\b/ or die "Can't find CharModifiers table definition";
print $c_file;
}
exit;
my($IN, $OUT) = <DATA>;
my $b_len = 8;
my @prev_vk;
for my $in ($IN) {
my @O = translate_key_line_c \@prev_vk, $b_len, $in, \my %fake;
warn "$OUT" unless $O[0] eq $OUT;
print for @O;
}
__DATA__
11 W 5 w W 0017 0017 00e1 00c1 03c9 03a9 0432 0412 05e9 fb2a // w, W, ^W, ^W, á, Á, ?, O, ?, ?, ?, ? // LATIN SMALL LETTER W, LATIN CAPITAL LETTER W, <control>, <control>, LATIN SMALL LETTER A WITH ACUTE, LATIN CAPITAL LETTER A WITH ACUTE, GREEK SMALL LETTER OMEGA, GREEK CAPITAL LETTER OMEGA, CYRILLIC SMALL LETTER VE, CYRILLIC CAPITAL LETTER VE, HEBREW LETTER SHIN, HEBREW LETTER SHIN WITH SHIN DOT
{'W' ,CAPLOK | CAPLOKALTGR,'w' ,'W' ,0x0017 ,0x0017 ,0x00e1 ,0x00c1 ,0x03c9 ,0x03a9 },