view release on metacpan or  search on metacpan

examples/klc2c.pl  view on Meta::CPAN

my($VK2bind, $scan2VK) = scan_layout $IN{LAYOUT}, \@VK2binds, \@VK2bindsX;
my %VK2bind = %$VK2bind;
my %scan2VK = %$scan2VK;

($VK2bind, $scan2VK) = scan_layout $L_default, \@VK2binds, \@VK2bindsX, $VK2bind, $scan2VK;
%VK2bind = (%VK2bind, %$VK2bind);
%scan2VK = (%scan2VK, %$scan2VK);

############################# Output redefinition of scancodes (if needed)

my($FX_scans, $add_X, $add_Y, @sc_pref) = ('', '', '', qw(X Y));
my @pre_NUMPAD = qw(INSERT END DOWN PRIOR LEFT CLEAR RIGHT HOME UP NEXT DELETE);	# Not used
for my $sc (sort keys %fix_scans) {
  my($vk, $was) = ($fix_scans{$sc}, '');
  next if $vk =~ /^(NUMPAD(\d)|DECIMAL)$/ 	# Ignore fake codes (usually these VK's are not associated with scancodes; produced by translation of pre_NUMPAD)
    and (hex $sc >= 0xE0E0 and hex $sc < 0xE0F0 or "$vk-$sc" eq 'DECIMAL-53');	# kbdutool only accepts DECIMAL on 53
  $was = "\t// was $scancodes{$sc}" if exists $scancodes{$sc};
  (my $osc = "T$sc") =~ s/^TE([01])/$sc_pref[$1]/;
  $FX_scans .= <<EOF;
#undef  $osc
 #define $osc _EQ(                                                    $vk                   )$was
EOF
  if (not $was and $sc =~ /^E([01])\w/) {
    ($1 ? $add_Y : $add_X) .= <<EOA;
        { 0x$sc, $osc | KBDEXT              },  // $vk$was
EOA
  }
}
$REPL{fix_scancodes}  = $FX_scans;	# join ' ', keys %fix_scans, values %fix_scans;
$REPL{addX_scancodes} = $add_X;
$REPL{addY_scancodes} = $add_Y;

############################# Output SC_ part of the Layout

my @lay_lens  = grep defined $VK2binds[$_],  0..$#VK2binds;
my @lay_lensX = grep defined $VK2bindsX[$_], 0..$#VK2bindsX;
warn "Existing lengths of bindings: [@lay_lens], [@lay_lensX]";
my @extralendefs = map "TYPEDEF_VK_TO_WCHARS($_)\n", grep $_>10, @lay_lens;   # std definition file defines up to 10
$REPL{extralendefs} = join '', @extralendefs;

my(%VK2scan,@xtrascans, $ext) = reverse %scan2VK;
if ($VK2bind{DIVIDE} and ($ext = (~0xff & hex $VK2scan{DIVIDE}))) {
  warn "Unknown extended modifier for the scancode for VK_DIVIDE: $VK2scan{DIVIDE} -> $ext, expect " . 0xe000
    unless 0xe000 == $ext;
  push @xtrascans, "        { 0x35, X35 | KBDEXT              },  // Numpad Divide\n"
}
$REPL{xtrascans} = join '', @xtrascans;

############################# Output VK part of the Layout

my $prevVK;
my %compatTR = qw( 0008 '\b' 000a '\n' 000d '\r' 005c '\\\\' 0027 '\'' 0022 '\"' );
my $compatRx = qr/^00(0[8ad]|2[27]|5c)$/i;	# these frivolous conversions simplify comparison with kbdutool; may be removed!
sub s2c($;$) {my($i,$o) = shift; return $prevVK if $i eq '-1';
              $o = ($i =~ /^[''""\\]$/ ? "'\\$i'" : ($i =~ /^.$/ ? "'$i'" : ($i =~ /^0x[\da-z]+$/i ? $i : "VK_$i"))); $prevVK = $o if shift; $o}
sub hex2c($$) {my($i,$h) = (shift,shift); my $n = hex $i; return "0x\L$i" if !$h or $n<0x20 or $n > 0x7e; "L" . s2c chr $n }
sub ch2c($;$)  {my($i,$h) = (shift,shift); return $compatTR{lc $i} if $h and $i =~ $compatRx;
                $i =~ /^[\da-f]{2,}$/i ? hex2c($i,$h) : ($i =~ /^.$/ ? s2c($i) : ($i =~ /^-1$/ ? 'WCH_NONE'
			: ($i =~ /\@$/ ? 'WCH_DEAD' : ($i eq '%%' ? 'WCH_LGTR' : $i))))}

sub mx($$) {my($i,$j)=(shift, shift); $i<$j? $j : $i}
sub fmt_st($$$) {my($i,$j,$l) = (shift, shift, shift); "$i" . (' ' x mx(1, $l - 3 - length "$i$j")) . ",$j ,"}

my($sublayouts, @sublayouts) = '';
sub emit_layout_line ($$$$) {	# XXXX Need to take into account required length too ???
  my($vk, $caps, $bind, $x, @xx) = (shift, shift, shift, shift || []);
  (my $ss, $caps) = (hex($caps) & 0xF, hex($caps) & ~0xF);
  $caps ||= '';
  $caps .= '|' if $caps;
  $caps .= join ' | ', map {$ss&(1<<$_) ? $capsFl->[$_] : ()} 0..$#$capsFl; # [1,'CAPLOK'], [2,'SGCAPS'], [4,'CAPLOKALTGR'], [8,'KANALOK'];
  my @bind = map ch2c($_,'unhex'), @$bind;
  my $comment = $comment_vkcodes{$vk} ? '//' : '  ';
  $sublayouts .= $comment . fmt_st("{" . s2c($vk, 'prev'), $caps||"0", 26) . join(" ,", map {sprintf "%-8s", $_} @bind) . " },\n";
  return unless grep /^WCH_DEAD$/, @bind or @$x;
  if (@$x) {
    $#$x = 1 if $#$x > 1;
    shift @$bind for 0..$#$x;	 # XXXX actually, not shift, but splice, and not 0,1, but columns of bitmaps 0,1???
    @xx = map ch2c($_,'unhex'), @$x;
  }
  $sublayouts .= $comment . fmt_st('{' . (@$x? s2c($vk, 'prev') : '0xff'), 0, 26)
     . join(" ,", @xx, map {sprintf "%-8s", (/^(.*)\@$/ ? "0x$1" : 'WCH_NONE')} @$bind) . " },\n";
  return unless "@$x" =~ /\@/;	# Emit short initializer, as kbdutool does with the preceding row:
  $sublayouts .= $comment . fmt_st('{0xff', 0, 26) . join(" ,", map {sprintf "%-8s", (/^(.*)\@$/ ? "0x$1" : 'WCH_NONE')} @$x) . " },\n";
}

for my $X ('', 'X') {
  my $L =  ($X ? $lenX : $len);
  my @tbl =  ($X ? @VK2bindsX : @VK2binds);
  $sublayouts .= <<'EOS' if $X;
// The following keys are put last so that VkKeyScan interprets
// (e.g.) number characters
// as coming from the main section of the kbd (aVkToWch2 and
// aVkToWch5) before considering the numpad (aVkToWch1).

EOS
  for my $_len (@$L) {
    (my $len = $_len) =~ s/^X//;
    my $lst = $tbl[$len] or next;
    push @sublayouts, [$len, "aVkToWch$_len"];
    $sublayouts .= <<EOP;
static ALLOC_SECTION_LDATA VK_TO_WCHARS$len aVkToWch$_len\[] = {
//                         |         |  Shift  |  Ctrl   |S+Ctrl   |  C+  X1 |  C+  X1 |
//                         |=========|=========|=========|=========|=========|=========|
EOP
  emit_layout_line $_->[0], $_->[1], $_->[2], $_->[3] for @$lst;
  $sublayouts .= "  {\t" . join(",\t", (0) x ($len+2)) . "}\n" . <<'EOP';
};

EOP
  }
}
$REPL{sublayouts} = $sublayouts;

my $LL = '';
for my $sub (@sublayouts) {
#  warn "[<<<$sub>>>]";
#  warn "<<@$sub>>";
  $LL .= <<EOS;
    {  (PVK_TO_WCHARS1)$sub->[1],	$sub->[0],	sizeof($sub->[1]\[0]) },
EOS
}