use strict;
use warnings;
use 5.020;
use utf8;
use open ':std',':locale';
use List::AllUtils qw(uniq natatime);
use HTML::Tiny;
use HTML::Entities;
use Unicode::UCD qw(charinfo);
use Unicode::Normalize;
my $COLUMNS = 5;
sub parse_compose_file {
my ($fn) = @_;
$fn //= $ENV{HOME}.'/.XCompose';
open my $fh, '<:utf8', $fn;
my @ret;
while (my $line = <$fh>) {
$line =~ s{#.*\z}{}sm;
if ($line =~ m{^include \s* "(.+?)"}x) {
my $file = $1;
$file =~ s{%L}{/usr/share/X11/locale/$ENV{LC_ALL}/Compose}g;
push @ret, parse_compose_file($file);
}
elsif ($line =~ m{<Multi_key>}) {
my ($keys,$output) = split /:/,$line;
unless ($keys && $output) {
warn "<$line>";
next;
}
my @keys = $keys =~ m{<(.+?)>}g;
$output =~ s{\A \s* "(.+?)" .* \z}{$1}smx;
$output = NFC($output);
warn sprintf "%s %d <%s> [%s] %d %s\n",
$fn, $.,
join(' ',@keys),
$output,length($output),
join(' ',map { sprintf 'U+%04X', ord($_) } split //,$output);
push @ret, [$output,@keys];
}
}
return @ret;
}
sub sort_it {
sort { $a->[0] cmp $b->[0] } @_
}
sub extract_collisions {
my %same_output;
my %same_input;
for my $mapping (@_) {
my ($input,$output) = @{$mapping};
push @{$same_input{$input}},$output;
push @{$same_output{$output}},$input;
}
for my $h (\%same_input,\%same_output) {
for my $i (keys %$h) {
@{$h->{$i}} = uniq @{$h->{$i}};
delete $h->{$i} if @{$h->{$i}} < 2;
}
}
return (\%same_input,\%same_output);
}
my %glyph = (
acute => '`',
ampersand => '&',
apostrophe => q{'},
asciicircum => '^',
asciitilde => '~',
asterisk => '*',
at => '@',
backslash => '\\',
BackSpace => '␈',
bar => '|',
braceleft => '{',
braceright => '}',
bracketleft => '[',
bracketright => ']',
colon => ':',
comma => ',',
division => '/',
dollar => '$',
Down => '↓',
equal => '=',
exclam => '!',
grave => q{'},
greater => '>',
Left => '←',
less => '<',
minus => '-',
Multi_key => '⌥',
numbersign => '#',
parenleft => '(',
parenright => ')',
percent => '%',
period => '.',
plus => '+',
question => '?',
quotedbl => '"',
Right => '→',
semicolon => ';',
slash => '/',
space => '␣',
tilde => '~',
underscore => '_',
Up => '↑',
KP_1 => '1⃣',
KP_2 => '2⃣',
KP_3 => '3⃣',
KP_4 => '4⃣',
KP_5 => '5⃣',
KP_6 => '6⃣',
KP_7 => '7⃣',
KP_8 => '8⃣',
KP_9 => '9⃣',
KP_0 => '0⃣',
KP_Equal => '=⃣',
KP_Divide => '/⃣',
KP_Add => '+⃣',
KP_Multiply => '*⃣',
);
sub to_presentation_form {
map {
my ($output, @keys) = @$_;
my $unmapped=0;
@keys = map {
length($_)==1
? $_
: ($glyph{$_} // do { warn "What's a <$_>??";++$unmapped });
} @keys;
if ($unmapped) {
();
}
else {
[(join '',@keys),$output];
}
} @_;
}
sub fill_table {
my @rows;
my $it = natatime $COLUMNS,@_;
while (my @row_data = $it->()) {
push @rows,[ \'tr', [
map {
my ($sequence, $output) = @{$_};
my @infos;
if ($output =~ /\s|\P{Print}/) {
my @points = split //,$output;
for my $p (@points) {
my $info = charinfo(ord($p));
if ($info) {
push @infos, lc($info->{name});
}
else {
warn sprintf 'no charinfo for %s (%04X)',
$p,ord($p);
}
}
}
(
[ \'th', {class=>'key'}, encode_entities($sequence), ],
[ \'td', {class=>'out'}, [
[\'span', {class=>'out'}, encode_entities($output), ],
(@infos
? [ \'span',{class=>'info'}, encode_entities("(@infos)") ]
: ()
),
] ],
);
} @row_data
] ];
}
return [ \'table', [
@rows,
] ];
}
sub show_collisions {
my @kind = qw(input output);
my %same; @same{@kind} = @_;
map {
my $kind = $_;
[ \'div', [
[ \'h2', "\u$kind collisions" ],
[ \'dl', [
map {
[ \'dt', $_ ],
map { [ \'dd', $_ ] } sort @{$same{$kind}->{$_}}
} sort keys %{$same{$kind}}
] ],
] ];
} @kind;
}
my $css = <<'CSS';
table {
width: 100%;
border-collapse: collapse;
font-size: x-large;
}
td, th {
text-align: left;
border-top: solid thin black;
vertical-align: baseline;
}
td {
border-right: solid thin black;
padding: 0.2em;
}
th {
font-weight: normal;
font-family: monospace;
white-space: pre-line;
}
span.out {
border: dotted thin black;
padding: 0.1em;
}
span.info {
margin-left: 0.5em;
font-size: 50%;
}
CSS
my @data = to_presentation_form sort_it parse_compose_file;
print HTML::Tiny->new->html([
[\'head',[
[\'meta', {'http-equiv'=>'Content-Type',content=>'text/html;charset=utf-8'}],
[\'style',$css],
[\'title','Compose mappings']
] ],
[ \'body', [
(fill_table @data),
(show_collisions extract_collisions @data),
] ],
]);
