UI-KeyboardLayout
view release on metacpan or search on metacpan
lib/UI/KeyboardLayout.pm view on Meta::CPAN
Later, a version of these layers with exportable keys marked is created as ini_layers_prefix.
ini_filled_layers: adds extra (fake) keys containing control characters and created via-VK-keys
(For these extended layers, the previous version can be inspected via ini_copy1.)
(created when exportable keys are handled.)
The next modification is done not by modifying the list of names of layers
associated to the face, but by editing the corresponding layers in place.
(The unmodified version of layer, one containing the exportable keys, is
accessible via C<ini_copy>.) On this step one adds the missing characters
from the face specified in the C<LinkFace> key.
=cut
# '
my (%Globals, $DEBUG);
sub set__value ($$$) {
my($class, $key) = (shift, shift);
(ref $class ? $class->{$key} : $Globals{$key}) = shift;
}
sub get__value ($$) {
my($class, $key) = (shift, shift);
if (ref $class and defined(my $v = $class->{$key})) {
$v;
} else {
$Globals{$key};
}
}
sub set_NamesList ($$;$) {
my $class = shift;
set__value($class, 'NamesList', shift);
set__value($class, 'AgeList', shift);
}
sub get_NamesList ($) { get__value(shift, 'NamesList') }
sub get_AgeList ($) { get__value(shift, 'AgeList') }
sub new ($;$) {
my $class = shift;
die "too many arguments to UI::KeyboardLayout->new" if @_ > 1;
my $data = @_ ? {%{shift()}} : {};
bless $data, (ref $class or $class);
}
sub put_deep($$$$@) {
my($self, $hash, $v, $k) = (shift, shift, shift, shift);
return $self->put_deep($hash->{$k} ||= {}, $v, @_) if @_;
$hash->{$k} = $v;
}
# Sections [foo/bar] [visual -> foo/bar]; directives foo=bar or @foo=bar,baz
# actually: parses configfile string, not file
sub parse_configfile ($$) { # Trailing whitespace is ignored, whitespace about "=" is not
my ($self, $s) = (shift, shift);
$self->parse_add_configstring($s, {});
}
sub parse_add_configstring ($$$) { # Trailing whitespace is ignored, whitespace about "=" is not
my ($self, $s, $vv, @KEYS) = (shift, shift, shift);
$s =~ s/[^\S\n]+$//gm;
$s =~ s/^\x{FEFF}//; # BOM are not stripped by Perl from UTF-8 files with -C31
(my $pre, my %f) = split m(^\[((?:visual\s*->\s*)?[\w/]*)\]\s*$ \n?)mx, $s; # //x is needed to avoid $\
warn "Part before the first section in configfile ignored: `$pre'" if length $pre;
for my $k (sort keys %f) {
# warn "Section `$k'";
my($v, $V, @V) = $f{$k};
if ($k =~ s{^visual\s*->\s*}{[unparsed]/}) { # Make sure that prefixes do not allow visual line to be confused with a config
$v =~ s[(^(?!#|[/\@+]?\w+=).*)]//ms; # find non-comment non-assignment
@V = "unparsed_data=$1";
}
# warn "xxx: @V";
push @KEYS, $k;
my @k = split m(/), $k;
@k = () if "@k" eq ''; # root
for my $l ((grep !/^#/, split(/\n/, $v)), @V) {
die "unrecognized config file line: `$l' in `$s'"
unless my($arr, $at, $slash, $kk, $vvv) = ($l =~ m[^((?:(\@)|(/)|\+)?)(\w+)=(.*)]s);
my $spl = $at ? qr/,/ : ( $slash ? qr[/] : qr[(?!)] );
$vvv = [ length $vvv ? (split $spl, $vvv, -1) : $vvv ] if $arr; # create empty element if $vvv is empty
my $slot = $self->get_deep($vv, @k);
if ($slot and exists $slot->{$kk}) {
if ($arr) {
if (ref($slot->{$kk} || 0) eq 'ARRAY') {
$vvv = [@{$slot->{$kk}}, @$vvv];
} else {
warn "Redefinition of non-array entry `$kk' in `$k' by array one, old value ignored"
}
} else {
warn "Redefinition of entry `$kk' in `$k', old value ignored"
}
}
# warn "Putting to the root->@k->`$kk'";
$self->put_deep($vv, $vvv, @k, $kk);
}
}
$vv->{'[keys]'} = \@KEYS;
# warn "config parsed";
$vv
}
sub merge_configstrings ($$@) { # Trailing whitespace is ignored, whitespace about "=" is not
my ($self, $overwrite) = (shift, shift);
for my $s (@_) {
my $data = {};
$self->parse_add_configstring($s, $data); # consolidate arrays into $data
$self->merge_hash($data, $self, $overwrite);
}
$self
}
sub merge_confighash ($$@) { # Trailing whitespace is ignored, whitespace about "=" is not
my ($self, $overwrite) = (shift, shift);
for my $data (@_) {
$self->merge_hash($data, $self, $overwrite);
}
$self
}
sub merge_hash ($$$$) {
my ($self, $from, $to, $overwrite) = (shift, shift, shift, shift);
for my $k (keys %$from) {
my $old = (exists $to->{k} ? ref($to->{k}) : '-');
if ($old eq 'HASH') {
die "Merging non-HASH subentry into a HASH" unless 'HASH' eq ref($from->{$k});
$self->merge_hash($from->{$k}, $to->{$k}, $overwrite);
} elsif ($old ne '-' and not $overwrite) { # Do nothing
} elsif (ref $from->{$k} eq 'HASH') {
die "Merging HASH subentry into a non-HASH";
} else {
$to->{$k} = $from->{$k};
}
}
$self
}
sub process_key_chunk ($$$$$) {
my $self = shift;
my $name = shift;
my $skip_first = shift;
(my $k = shift) =~ s/\p{Blank}(?=\p{NonspacingMark})//g; # Allow combining marks to be on top of SPACE
my $sep2 = shift;
$k = $self->stringHEX2string($k);
my @k = split //, $k;
if (defined $sep2 and 3 <= @k and $k =~ /$sep2/) { # Allow separation by $sep2, but only if too long
@k = split /$sep2/, $k;
shift @k if not length $k[0] and @k == 2;
warn "Zero length expansion in the key slot <$k>\n" if not @k or grep !length, @k;
}
undef $k[0] if ($k[0] || '') eq "\0" and $skip_first;
push @k, ucfirst $k[0] if @k == 1 and defined $k[0] and 1==length $k[0] and $k[0] ne ucfirst $k[0];
$name = "VisLr=$name" if $name;
# warn "Multi-char key in <<@k>>" if grep $_ && 1<length, @k;
warn "More that 2 Shift-states in <<@k>>" if @k > 2;
#warn "Sep2 in $name, $skip_first, <$k> ==> <@k>\n" if defined $sep2 and $k =~ /$sep2/;
map {defined() ? [$_, undef, undef, $name] : $_} @k;
# @k
} # -> list of chars
sub process_key ($$$$$$;$) { # $sep may appear only in a beginning of the first key chunk
my ($self, $k, $limit, $sep, $ln, $l_off, $sep2, @tr) = (shift, shift, shift, shift, shift, shift, shift);
my @k = split m((?!^)\Q$sep), $k;
die "Key descriptor `$k' separated by `$sep' has too many parts: expected $limit, got ", scalar @k
if @k > $limit;
defined $k[$_] and $k[$_] =~ s/^--(?=.)/\0/ and $tr[$_]++ for 0..$#k;
$k[0] = '' if $k[0] eq '--'; # Allow a filler (multi)-chunk
map [$self->process_key_chunk( $ln->[$l_off+$_], $tr[$_], (defined($k[$_]) ? $k[$_] : ''), $sep2)], 0..$#k;
} # -> list of arrays of chars
sub decode_kbd_layers ($@) {
my ($self, $lineN, $row, $line_in_row, $cur_layer, @out, $N, $l0) = (shift, 0, -1);
my %needed = qw(unparsed_data x visual_rowcount 2 visual_per_row_counts [2;2] visual_prefixes * prefix_repeat 3 in_key_separator / layer_names ???);
my %extra = (qw(keyline_offsets 1 in_key_separator2), undef);
my $opt;
for my $k (keys %needed, keys %extra) {
my ($from) = grep exists $_->{$k}, @_, (ref $self ? $self : ());
die "option `$k' not specified" unless $from or exists $extra{$k};
$opt->{$k} = $from->{$k};
}
die "option `visual_rowcount' differs from length of `visual_per_row_counts': $opt->{visual_rowcount} vs. ",
scalar @{$opt->{visual_per_row_counts}} unless $opt->{visual_rowcount} == @{$opt->{visual_per_row_counts}};
my @lines = grep !/^#/, split /\s*\n/, $opt->{unparsed_data};
my ($C, $lc, $pref) = map $opt->{$_}, qw(visual_rowcount visual_per_row_counts visual_prefixes);
die "Number of uncommented rows (" . scalar @lines . ") in a visual template not divisible by the rowcount $C: `$opt->{unparsed_data}'"
if @lines % $C;
$pref = [map {$_ eq ' ' ? qr/\s/ : qr/\Q$_/ } split(//, $pref), (' ') x $C];
# my $line_in_row = [];
my @counts;
my $sep2;
$sep2 = qr/$opt->{in_key_separator2}/ if defined $opt->{in_key_separator2};
while (@lines) {
# push @out, $line_in_row = [] unless $C % $c;
$row++, $line_in_row = $cur_layer = 0 unless $lineN % $C;
$lineN++;
my $l1 = shift @lines;
my $PREF = qr/(?:$pref->[$line_in_row]){$opt->{prefix_repeat}}/;
$PREF = '\s' if $pref->[$line_in_row] eq qr/\s/;
$l1 =~ s/\s*\x{202c}$// if $l1 =~ s/^[\x{202d}\x{202e}]//; # remove PDF if removed LRO, RLO
die "line $lineN in visual layers has unexpected prefix:\n\tPREF=/$PREF/\n\tLINE=`$l1'" unless $l1 =~ s/^$PREF\s*(?<=\s)//;
my @k1 = split /\s+(?!\p{NonspacingMark})/, $l1;
$l0 = $l1, $N = @k1 if $line_in_row == 0;
# warn "Got keys: ", scalar @k1;
die sprintf "number of keys in lines differ: %s vs %s in:\n\t`%s'\n\t`%s'\n\t<%s>",
scalar @k1, $N, $l0, $l1, join(">\t<", @k1) unless @k1 == $N; # One can always fill by --
for my $key (@k1) {
my @kk = $self->process_key($key, $lc->[$line_in_row], $opt->{in_key_separator}, $opt->{layer_names}, $cur_layer, $sep2);
push @{$out[$cur_layer + $_]}, $kk[$_] || [] # (defined $kk[$_] ? [$kk[$_],undef,undef,$opt->{layer_names}[$cur_layer + $_]] : [])
for 0..($lc->[$line_in_row]-1);
}
$cur_layer += $lc->[$line_in_row++];
push @counts, scalar @k1 if 1 == $lineN % $C;
}
# warn "layer[0] = ", join ', ', map "@$_", @{$out[0]};
die "Got ", scalar @out, " layers, but ", scalar @{$opt->{layer_names}}, " layer names"
unless @out == @{$opt->{layer_names}};
my(%seen, %out);
$seen{$_}++ and die "Duplicate layer name `$_'" for @{$opt->{layer_names}};
@out{ @{$opt->{layer_names}} } = @out;
for my $i ( 0 .. ($#{ $opt->{layer_names} } - 1) ) {
my($base,$shift) = ($out[$i], $out[$i+1]);
$out{$opt->{layer_names}[$i] . '²'} ||= [ map [$base->[$_][0], $shift->[$_][0]], 0..$#$base ]; # ²: Layer, and the next “as shiftedâ€
next if $i > $#{ $opt->{layer_names} } - 3;
lib/UI/KeyboardLayout.pm view on Meta::CPAN
@out{ @{$opt->{layer_names}} } = @out;
for my $i ( 0 .. ($#{ $opt->{layer_names} } - 1) ) {
my($base,$shift) = ($out[$i], $out[$i+1]);
$out{$opt->{layer_names}[$i] . '²'} ||= [ map [$base->[$_][0], $shift->[$_][0]], 0..$#$base ]; # ²: Layer, and the next “as shiftedâ€
next if $i > $#{ $opt->{layer_names} } - 3;
($base,$shift) = ($out[$i+2], $out[$i+3]);
$out{$opt->{layer_names}[$i] . '²âº'} ||= [ map [$base->[$_][0], $shift->[$_][0]], 0..$#$base ]; # ²âº: two next layers (likewise)
### warn "Created ² etc appended-names for rect layer $opt->{layer_names}[$i]";
}
my $ii = 0;
for my $pre_row ( 0 .. @{ $opt->{rect_horizontal_counts} } - 2) {
my $C = $opt->{rect_horizontal_counts}[$pre_row];
for my $iii ( 0 .. $C - 1) {
my $I = $ii + $iii;
my $i = $I + $C;
next if $i > $#{ $opt->{layer_names} }; # Next row may be shorter
my($base,$shift) = ($out[$i], $out[$i+1]);
$out{$opt->{layer_names}[$I] . 'â‚'} ||= [ map [$base->[$_][0]], 0..$#$base ]; # In the next row listing layer-names
next if $i > $#{ $opt->{layer_names} } - 1;
$out{$opt->{layer_names}[$I] . '₂'} ||= [ map [$base->[$_][0], $shift->[$_][0]], 0..$#$base ]; # As ² but in the next row
next if $i > $#{ $opt->{layer_names} } - 3;
($base,$shift) = ($out[$i+2], $out[$i+3]);
$out{$opt->{layer_names}[$I] . '₂₊'} ||= [ map [$base->[$_][0], $shift->[$_][0]], 0..$#$base ]; # As ²⺠but in the next row
}
$ii += $C;
}
\%out, [($opt->{rect_rows_cols}[1]) x $opt->{rect_rows_cols}[0]];
}
sub get_deep ($$@) {
my($self, $h) = (shift, shift);
return $h unless @_;
my $k = shift @_;
return unless exists $h->{$k};
$self->get_deep($h->{$k}, @_);
}
sub get_deep_via_parents ($$$@) { # quadratic algorithm
my($self, $h, $idx, $IDX) = (shift, shift, shift);
#warn "Deep: `@_'";
((defined $h) ? return $h : return) unless @_;
my $k = pop @_;
{
#warn "Deep::: `@_'";
my $H = $self->get_deep($h, @_);
(@_ or return), $IDX++, # Start extraction from array
pop, redo unless exists $H->{$k};
my $v = $H->{$k};
#warn "Deep -> `$v'";
return $v unless ref($v || 1) and $IDX and defined $idx;
return $v->[$idx];
}
return;
}
sub fill_kbd_layers ($$) { # We do not do deep processing here...
my($self, $h, %o, %c, %O) = (shift, shift);
my @K = grep m(^\[unparsed]/(KBD|RECT)\b), @{$h->{'[keys]'}};
# my $H = $h->{'[unparsed]'};
for my $k (@K) {
my (@parts, @h) = split m(/), $k;
ref $self and push @h, $self->get_deep($self, @parts[1..$_]) || {} for 0..$#parts;
push @h, $self->get_deep($h, @parts[1..$_]) || {} for 0..$#parts; # Drop [unparsed]/ prefix...
push @h, $self->get_deep($h, @parts[0..$_]) || {} for -1..$#parts;
my ($in, $counts, $offsets) = ($k =~ m(^\[unparsed]/KBD\b) ? $self->decode_kbd_layers( reverse @h )
: $self->decode_rect_layers( reverse @h ) );
exists $o{$_} and die "Visual spec `$k' overwrites exiting layer `$k'" for keys %$in;
my $cnt = (@o{keys %$in} = values %$in);
@c{keys %$in} = ($counts) x $cnt;
@O{keys %$in} = ($offsets) x $cnt if $offsets;
}
\%o, \%c, \%O
}
sub key2hex ($$;$) {
my ($self, $k, $ignore) = (shift, shift, shift);
return -1 if $ignore and not defined $k;
return sprintf '%04x', ord $k; # if ord $k <= 0xFFFF;
# sprintf '%06x', ord $k;
}
sub keyORarray2hex ($$;$) {
my ($self, $k, $ignore) = (shift, shift, shift);
return -1 if $ignore and not defined $k;
$k = $k->[0] if $k and ref $k;
$self->key2hex($k, $ignore);
}
sub keys2hex ($$;$) {
my ($self, $k, $ignore) = (shift, shift, shift);
return -1 if $ignore and not defined $k;
return join '.', map {sprintf '%04x', ord} split //, $k; # if ord $k <= 0xFFFF;
# sprintf '%06x', ord $k;
}
sub coverage_hex_sub($$$) { # Unfinished!!! XXXX UNUSED
my ($self, $layer, $to) = (shift, shift, shift);
++$to->{ $self->key2hex($_->[0], 'undef_ok') }, ++$to->{ $self->key2hex($_->[1], 'undef_ok') }
for @{$self->{layers}{$layer}};
}
# my %MANUAL_MAP = qw( 0020 0020 00a0 00a0 2007 2007 ); # We insert entry for SPACE manually
# my %MANUAL_MAP_ch = map chr hex, %MANUAL_MAP;
sub coverage_hex($$) {
my ($self, $face) = (shift, shift);
my $layers = $self->{faces}{$face}{layers};
my $to = ($self->{faces}{$face}{'[coverage_hex]'} ||= {}); # or die "Panic!"; # Synthetic faces may not have this...
my @Layers = map $self->{layers}{$_}, @$layers;
for my $sub (@Layers) {
++$to->{ $self->keyORarray2hex($_, 'undef_ok') } for map +(@$_[0,1]), @$sub;
}
}
sub deep_copy($$) {
my ($self, $o) = (shift, shift);
return $o unless ref $o;
return [map $self->deep_copy($_), @$o] if "$o" =~ /^ARRAY\(/; # We should not have overloaded elements
return {map $self->deep_copy($_), %$o} if "$o" =~ /^HASH\(/;
}
sub DEEP_COPY($@) {
lib/UI/KeyboardLayout.pm view on Meta::CPAN
sub __dbg_latin_CtrlD ($) {
my $self = shift;
my $Ln = $self->{faces}{Latin}{layers}[0];
my $L = $self->{layers}{$Ln};
my $Kn = $start_SEC{ARROWS}[0] + 14; # 14: RETURN 15: ADD
my $K = $L->[$Kn][0]; # Unshifted
$K = $K->[0] if ref $K;
die "Got \\x0d (=$K)" if $K and ($K eq "\x09" or $K eq '000d');
}
sub revive_layer ($$$$) { # What is the difference with make_translated_layers()??? Supporting the fundamental layers???
my($self, $f, $ln, $l) = (shift, shift, shift, shift);
next if $self->{layers}{$l}; # Else, auto-vivify
my $ll = $l;
#warn "Creating layer `$l' for face `$f'...";
my @r = $self->layer_recipe($l);
$ll = $r[0] if @r;
warn "Massaging: Using layout_recipe `$ll' for layer '$l'\n" if debug_face_layout_recipes and exists $self->{layer_recipes}{$l};
warn " mk_tr_lyrs 0" if debug_stacking_ord;
$ll = $self->make_translated_layers($ll, $f, [$ln], '0000');
#warn "... Result `@$ll' --> $self->{layers}{$ll->[0]}";
(debug_face_layout_recipes and warn "Massaging: Using layout_recipe `$ll->[0]' for layer '$l'\n"),
$self->{layers}{$l} = $self->{layers}{$ll->[0]} unless $self->{layers}{$l}; # Could autovivify in between???
}
my $w_o;
sub order_faces_4_massage ($) { # process LinkFace first (if no loops)
my($self, $prekeys) = (shift, 1e300);
my(@res, @RES, %seen) = [sort keys %{$self->{faces}}];
while ($prekeys > $#{$res[-1]}) { # Construct chains of LinkFace'ing; next element is made of linkface's of the previous one
$prekeys = $#{$res[-1]};
push @res, [];
for my $f (@{$res[-2]}) {
next if 'HASH' ne ref $self->{faces}{$f} or $f =~ m(\bVK$); # "parent" taking keys for a child
if (my $LF = $self->{faces}{$f}{LinkFace}) {
push @{$res[-1]}, $LF;
}
}
}
for my $r (reverse @res) {
push @RES, grep !$seen{$_}++, sort @$r; # reverse? ??? Voodoo !!! Sorting changes the result... XXXX
}
warn 'Face order `', join("' `", @RES), "'" unless $w_o++;
@RES
}
sub massage_faces ($) {
my $self = shift;
# warn "Massaging faces...";
for my $f ($self->order_faces_4_massage) { # Needed for (pre_)link_layers...
next if 'HASH' ne ref $self->{faces}{$f} or $f =~ m(\bVK$); # "parent" taking keys for a child
#warn "Massaging face `$f'...";
for my $key ( qw( Flip_AltGr_Key Diacritic_if_undef DeadChar_DefaultTranslation DeadChar_32bitTranslation extra_report_DeadChar
PrefixChains ctrl_after_modcol create_alpha_ctrl keep_missing_ctrl output_layers
output_layers_WIN output_layers_XKB skip_extra_layers_WIN Prefix_Base_Altern Prefix_Force_Altern
layers_modifiers layers_mods_keys mods_keys_KBD AltGrInv_AltGr_as_Ctrl
ComposeKey_Show AltGr_Invert_Show Apple_Override Apple_Duplicate Apple_HexInput
ComposeKey Explicit_AltGr_Invert Auto_Diacritic_Start CapsLOCKoverride
WindowsEmitDeadkeyDescrREX ExtraChars modkeys_vk) ) {
$self->{faces}{$f}{"[$key]"} = $self->get_deep_via_parents($self, undef, 'faces', (split m(/), $f), $key);
}
$self->{faces}{$f}{'[char2key_prefer_first]'}{$_}++ # Make a hash
for @{ $self->{faces}{$f}{char2key_prefer_first} || [] } ;
$self->{faces}{$f}{'[char2key_prefer_last]'}{$_}++ # Make a hash
for @{ $self->{faces}{$f}{char2key_prefer_last} || [] } ;
$self->{faces}{$f}{'[AltGrInv_AltGr_as_Ctrl]'} = 1 unless defined $self->{faces}{$f}{'[AltGrInv_AltGr_as_Ctrl]'};
my $idx = $self->get_deep($self, 'faces', (split m(/), $f), 'MetaData_Index');
# defined $self->{faces}{$f}{"[$_]"} and not ref $self->{faces}{$f}{"[$_]"}
# or
$self->{faces}{$f}{"[$_]"} = $self->get_deep_via_parents($self, $idx, 'faces', (split m(/), $f), $_)
for qw(LRM_RLM ALTGR SHIFTLOCK NOALTGR);
my %R = qw(ComposeKey_Show ⎄ AltGr_Invert_Show ⤨); # On Apple only
defined $self->{faces}{$f}{"[$_]"} or $self->{faces}{$f}{"[$_]"} = $R{$_} for keys %R;
$self->{faces}{$f}{"[ComposeKey_Show]"}[0] = '⎄' # Make a safe default
if ref $self->{faces}{$f}{"[ComposeKey_Show]"} and not length $self->{faces}{$f}{"[ComposeKey_Show]"}[0];
my ($compK, %compK) = $self->{faces}{$f}{'[ComposeKey]'};
if ($compK and ref $compK) {
for my $cK (@$compK) {
my @kkk = split /,/, $cK;
$compK{ $self->key2hex($self->charhex2key($kkk[3])) }++ if defined $kkk[3] and length $kkk[3];
}
} elsif (defined $compK) {
$compK{ $self->key2hex($self->charhex2key($compK)) }++;
}
$self->{faces}{$f}{'[ComposeKeys]'} = \%compK;
unless ($self->{faces}{$f}{layers}) {
next unless $self->{face_recipes}{$f};
$self->face_by_face_recipe($f, $f);
}
for my $ln ( 0..$#{$self->{faces}{$f}{layers} || []} ) {
my $l = $self->{faces}{$f}{layers}[$ln];
$self->revive_layer($f, $ln, $l) unless $self->{layers}{$l};
}
### warn "Layer names (face=`$f', layer[0]=`$self->{faces}{$f}{layers}[0]'):\n\t`", join("'\n\t`", sort keys %{$self->{layers}}), "'"
### if debug_face_layout_recipes or not defined $self->{layers}{$self->{faces}{$f}{layers}[0]};
}
for my $f ($self->order_faces_4_massage) { # Needed for LinkFace inside massage_VK()... Breaks CopticTens etc.
next if 'HASH' ne ref $self->{faces}{$f} or $f =~ m(\bVK$); # "parent" taking keys for a child
(my ($seen, $seen_dead), $self->{faces}{$f}{'[dead_in_VK]'}) = $self->massage_VK($f);
$self->{faces}{$f}{'[dead_in_VK_array]'} = $seen_dead;
$self->{faces}{$f}{'[coverage_hex]'}{$self->key2hex($_)}++ for @$seen;
$self->{faces}{$f}{"Altern$_"} ||= $self->{faces}{$f}{"AltGr$_"}
for qw(CharSubstitutions CharSubstitutionFaces CharSubstitutionLayers);
# Obsolete names
for my $S (@{ $self->{faces}{$f}{AlternCharSubstitutions} || []}) {
my $s = $self->stringHEX2string($S);
$s =~ s/\p{Blank}(?=\p{NonspacingMark})//g;
die "Expect 2 chars in AltGr-char substitution rule; I see <$s> (from <$S>)" unless 2 == (my @s = split //, $s);
push @{ $self->{faces}{$f}{'[AltSubstitutions]'}{$s[0]} }, [$s[1], 'manual'];
push @{ $self->{faces}{$f}{'[AltSubstitutions]'}{lc $s[0]} }, [lc $s[1], 'manual']
if lc $s[0] ne $s[0] and lc $s[1] ne $s[1];
push @{ $self->{faces}{$f}{'[AltSubstitutions]'}{uc $s[0]} }, [uc $s[1], 'manual']
if uc $s[0] ne $s[0] and uc $s[1] ne $s[1];
}
s/^\s+//, s/\s+$//, $_ = $self->stringHEX2string($_) for @{ $self->{faces}{$f}{Import_Prefix_Keys} || []};
my %h = @{ $self->{faces}{$f}{Import_Prefix_Keys} || []};
$self->{faces}{$f}{'[imported2key]'} = \%h if %h;
my ($l0, $c);
unless ($c = $self->{layer_counts}{$l0 = $self->{faces}{$f}{layers}[0]}) {
$l0 = $self->get_deep_via_parents($self, undef, 'faces', (split m(/), $f), 'geometry_via_layer');
$c = $self->{layer_counts}{$l0} if defined $l0;
}
my $o = $self->{layer_offsets}{$l0} if defined $l0;
$self->{faces}{$f}{'[geometry]'} = $c if $c;
$self->{faces}{$f}{'[g_offsets]'} = $o if $o;
}
# $self->__dbg_latin_CtrlD;
for my $f ($self->order_faces_4_massage) { # Needed for face_make_backlinks: must know which keys in faces will be finally present
next if 'HASH' ne ref $self->{faces}{$f} or $f =~ m(\bVK$); # "parent" taking keys for a child
for my $F (@{ $self->{faces}{$f}{AlternCharSubstitutionFaces} || []}) { # Now has a chance to have real layers
unless ($self->{faces}{$F}{layers}) {
next unless $self->{face_recipes}{$F};
$self->face_by_face_recipe($F, $f);
}
for my $L (0..$#{$self->{faces}{$f}{layers}}) {
my $from = $self->{faces}{$f}{layers}[$L];
next unless my $to = $self->{faces}{$F}{layers}[$L];
$_ = $self->{layers}{$_} for $from, $to;
for my $k (0..$#$from) {
next unless $from->[$k] and $to->[$k];
for my $shift (0..1) {
next unless defined (my $s = $from->[$k][$shift]) and defined (my $ss = $to->[$k][$shift]);
$_ and ref and $_ = $_->[0] for $s, $ss;
push @{ $self->{faces}{$f}{'[AltSubstitutions]'}{$s} }, [$ss, "F=$F"];
}
}
}
}
} # ^^^ This is not used yet???
# $self->__dbg_latin_CtrlD;
for my $f ($self->order_faces_4_massage) { # Needed for face_make_backlinks: must know which keys in faces will be finally present
next if 'HASH' ne ref $self->{faces}{$f} or $f =~ m(\bVK$); # "parent" taking keys for a child
my $linked = $self->{faces}{$f}{LinkFace};
for my $N (0..$#{ $self->{faces}{$f}{AlternCharSubstitutionLayers} || []}) { # Now has a chance to have real layers
my $TO = my $to = $self->{faces}{$f}{AlternCharSubstitutionLayers}[$N];
my $from = $self->{faces}{$f}{layers}[$N] or next;
$self->revive_layer($f, $N, $TO) unless $self->{layers}{$TO};
$_ = $self->{layers}{$_} for $from, $to;
my $from_linked;
if ($linked) {
$from_linked = $self->{faces}{$linked}{layers}[$N];
$from_linked = $self->{layers}{$from_linked} if defined $from_linked;
}
for my $k (0..$#$from) {
next unless ($from->[$k] or $from_linked and $from_linked->[$k]) and $to->[$k];
for my $shift (0..1) {
next unless defined (my $s = ($from->[$k][$shift] or $from_linked and $from_linked->[$k][$shift]))
and defined (my $ss = $to->[$k][$shift]);
$_ and ref and $_ = $_->[0] for $s, $ss;
push @{ $self->{faces}{$f}{'[AltSubstitutions]'}{$s} }, [$ss, "L=$TO"];
}
}
}
if ($f =~ /^(Latin|CyrillicPhonetic|GreekPoly|Hebrew)$/ and $self->{faces}{$f}{'[AltSubstitutions]'}) {
warn " `$f' AltSubstitutions: ", join '', sort keys %{$self->{faces}{$f}{'[AltSubstitutions]'}};
}
}
# $self->__dbg_latin_CtrlD;
for my $f ($self->order_faces_4_massage) { # Linking uses the number of slots in layer 0 as the limit; fill to make into max
next if 'HASH' ne ref $self->{faces}{$f} or $f =~ m(\bVK$); # "parent" taking keys for a child
lib/UI/KeyboardLayout.pm view on Meta::CPAN
next unless length $k;
$k = $self->charhex2key($k);
1 < length $k and die "not a character as an exported deadkey: `$k'";
$export->{$k} = 1;
}
if (my $LL = $self->{faces}{$f}{'[ini_layers]'}) {
my @out;
for my $L ( @$LL ) {
push @out, "$L++prefix+";
my $l = $self->{layers}{$out[-1]} = $self->deep_copy($self->{layers}{$L});
for my $n (0 .. $#$l) {
my $K = $l->[$n];
for my $k (@$K) {
#warn "face `$f' layer `$L' ini_layers_prefix: key `$k' marked as a deadkey" if defined $k and $DDD->{$k};
$k = [$k] if defined $k and not ref $k; # Allow addition of doc strings
if (defined $k and ($DDD->{$k->[0]} or $vk->{$k->[0]})) {
@$k[1,2] = ($f, $k->[2] || ($export->{$k->[0]} ? 2 : 1)); # Is exportable?
}
}
}
}
$self->{faces}{$f}{'[ini_layers_prefix]'} = \@out;
$LL = $self->{faces}{$f}{'[ini_filled_layers]'} = [ @{ $self->{faces}{$f}{layers} } ]; # Deep copy
my @OUT;
for my $L ( @$LL ) {
push @OUT, "$L++PREFIX+";
my $l = $self->{layers}{$OUT[-1]} = $self->deep_copy($self->{layers}{$L});
for my $n (0 .. $#$l) {
my $K = $l->[$n];
for my $k (@$K) {
#warn "face `$f' layer `$L' layers_prefix: key `$k' marked as a deadkey" if defined $k and $DDD->{$k};
$k = [$k] if defined $k and not ref $k; # Allow addition of doc strings
if (defined $k and ($DDD->{$k->[0]} or $vk->{$k->[0]})) {
@$k[1,2] = ($f, $k->[2] || ($export->{$k->[0]} ? 2 : 1)); # Is exportable?
}
}
}
}
$self->{faces}{$f}{layers} = \@OUT;
} else {
warn "Face `$f' has no ini_layers";
}
$self->{faces}{$f}{'[dead_array]'} = \@d;
for my $D (@{$self->{faces}{$f}{faceDeadKeys2} || $self->{faces}{$f}{layerDeadKeys2} || []}) { # layerDeadKeys2 obsolete
$D =~ s/^\s+//; $D =~ s/\s+$//;
my @k = split //, $self->stringHEX2string($D);
2 != @k and die "not two characters as a chained deadkey: `@k'";
#warn "dead2 for <@k>";
$self->{faces}{$f}{'[dead2]'}{$k[0]}{$k[1]}++;
# $k[1] is "untranslated"; it is not good for [DEAD]:
#$self->{faces}{"$f###" . $self->key2hex($k[0])}{'[DEAD]'}{$k[1]}++;
}
}
# $self->__dbg_latin_CtrlD;
$self
}
sub massage_hash_values($) {
my($self) = (shift);
for my $K ( @{$self->{'[keys]'}} ) {
my $h = $self->get_deep($self, split m(/), $K);
$_ = $self->charhex2key($_) for @{ $h->{char2key_prefer_first} || []}, @{ $h->{char2key_prefer_last} || []};
}
}
#use Dumpvalue;
sub print_codepoint ($$;$$) { # $postfix may be a name of base-font. Then the coverage_how is used instead of $postfix
my ($self, $k, $prefix, $postfix) = (shift, shift, shift, shift);
my $K = ($k =~ /$rxCombining/ ? " $k" : $k);
if (defined $postfix) {
my $how = $self->{faces}{$postfix}{'[coverage_how]'}{$k};
# $how2 =~ s/(1+)/length $1/e;
# defined($how) ? $how .= " $how2" : $how = $how2 if $how2;
$postfix = '' if $self->{faces}{$postfix}{'[coverage_how]'};
$postfix = " $how" if $how;
}
$prefix = '' unless defined $prefix;
$postfix = '' unless defined $postfix;
my $kk = join '.', map $self->key2hex($_), split //, $k;
my $UN = join ' + ', map $self->UName($_, 'verbose', 'vbell'), split //, $k;
printf "%s%s\t<%s>%s\t%s\n", $prefix, $kk, $K, $postfix, $UN;
}
sub require_unidata_age ($) {
my $self = shift;
my $f = $self->get_NamesList;
$self->load_compositions($f) if defined $f;
$f = $self->get_AgeList;
$self->load_uniage($f) if defined $f and not $self->{Age};
$self;
}
sub print_coverage_string ($$) {
my ($self, $s, %seen) = (shift, shift);
$seen{$_}++ for split //, $s;
my $f = $self->get_NamesList;
$self->load_compositions($f) if defined $f;
$f = $self->get_AgeList;
$self->load_uniage($f) if defined $f and not $self->{Age};
require Unicode::UCD;
$self->print_codepoint($_) for sort keys %seen;
}
sub print_coverage ($$) {
my ($self, $F) = (shift, shift);
my $f = $self->get_NamesList;
$self->load_compositions($f) if defined $f;
$f = $self->get_AgeList;
$self->load_uniage($f) if defined $f and not $self->{Age};
my $file = $self->{'[file]'};
my $app = (defined $file and @$file > 1 and 's');
$file = (defined $file) ? "file$app @$file" : 'string descriptor';
lib/UI/KeyboardLayout.pm view on Meta::CPAN
### my @e = each %$map; warn "map-start $F=>$FFF: $e[0] <@{ref $e[1] ? $e[1] : [$e[1]||'---']}>\n";
($SEEN{$_}++ or $seen1{$_}++), # micro-optimization
$reached{$_} || $u{$_}++,
($not_in_base and not $is_extra{$deadKey}) || $seen0oneUTF16{$_} || $seen1only{$_}++, # Only for multi-prefix maps
for map {ref() ? $_->[0] : $_} grep !(ref and $_->[2]), @$cov1; # Skip 2nd level deadkeys
# !$is_extra{$deadKey} && ($reach_how{$_} ||= '', $reach_how{$_} .= (($not_in_base and $dK_of_extra) ? 'â’º' : 'E')),
# $_ eq 'â©' && warn "See â© on [$deadKEY] !base=$not_in_base deadKey_of_ExtraFace=$dK_of_extra; of $F\n"
### $is_extra{$deadKey} && $seenExtra{$_}++ # Only for extra modifiers maps
# for keys %{$H->{'[coverageExtra]'}};
%u and warn "Unreached: <<$_>> in [$deadKEY] of $F\n" for join ' ', sort keys %u;
if (my $d2 = $H->{'[dead2]'}{$deadKey}) {
# warn "linked map (face=$F) = ", keys %$d2;
@dd2 = map $self->charhex2key($_), map {($_ and ref $_) ? $_->[0] : $_} map $map->{$self->key2hex($_)}, keys %$d2;
# warn "sub-D2 (face=$F) = ", @dd2;
}
#warn "2nd level prefixes for `$deadKey': ", keys %{$self->{faces}{$FFF}{'[coverage0_prefix]'} || {}};
#warn "2nd level prefixes for `$deadKey': <@dd2> ", keys %{$H->{'[dead2]'}{$deadKey} || {}};
unless ($not_in_base) {
# warn "sub-cov0 (face=$F) = ", keys %{ $self->{faces}{$FFF}{'[coverage0_prefix]'} || {} };
$coverage1_prefix{$_}++ for keys %{ $self->{faces}{$FFF}{'[coverage0_prefix]'} || {} }; # XXXX prefix keys (maybe unreachable???)
# warn "sub-D2 (face=$F) = ", @dd2;
$coverage1_prefix{$_}++ for @dd2;
}
# warn "...... deadkey `$deadKey' reached0 in face `$F'" unless $not_in_base;
%prefix_with_1prefix = (%prefix_with_1prefix, %havePref) if $pass == 1; # Hex
%prefix_with_2prefices = (%prefix_with_2prefices, %havePref) if $pass == 2; # Hex
# %prefix_with_3prefices = (%prefix_with_3prefices, %havePref) if $pass == 3; # Hex
}
}
for my $c (keys %difficult) {
$difficult{$c} = 9;
for my $d (0..8) {
$difficult{$c} = $d, last if $difficult[$d]{$c};
}
}
my @check = grep { !$coverage1_prefix{$_} and !$is_extra{$_} } sort keys %check_later; # dead: ∉ base ∪ 1-prefix ∪ extra
my @only_extra = grep { !$coverage1_prefix{$_} and $is_extra{$_} } sort keys %check_later;
$H->{'[only_extra]'} = { map {($_, 1)} @only_extra }; # extra layers which are not reachable by 2 prefix keys
my $_s = (@check > 1 ? 's' : '');
warn("Prefix key$_s <@check> not reached (without double prefix keys?) in face `$F'; later=", sort(keys %check_later), " ; cov1=", sort keys %coverage1_prefix) if @check;
$H->{'[coverage1]'} = [sort keys %seen1];
$H->{'[coverage1only]'} = [sort keys %seen1only];
$H->{'[coverage1only_hash]'} = \%seen1only;
$H->{'[coverage_hash]'} = \%SEEN;
$H->{'[coverage_how]'} = \%reach_how;
$H->{'[coverage_difficulty]'} = \%difficult;
warn "$F coverage_how: ", join(' ', map +"$_ $reach_how{$_}", sort keys %reach_how), "\n"
if warnReached and ( keys %{$H->{'[deadkeyFace]'}} or keys %{$H->{'[coverageExtra]'}} );
# $H->{'[coverageExtra]'} = \%seenExtra; # also done above???
}
$self
}
sub massage_deadkeys_win ($$) {
my($self, $h, @process, @to) = (shift, shift);
my @K = grep m(^\[unparsed]/DEADKEYS\b), @{$h->{'[keys]'}};
# warn "Found deadkey sections `@K'";
# my $H = $h->{'[unparsed]'};
for my $k (@K) {
push @process, $self->get_deep($h, (split m(/), $k), 'unparsed_data');
(my $k1 = $k) =~ s(^\[unparsed]/)();
push @to, $k1
}
@K = grep m(^DEADKEYS\b), @{$h->{'[keys]'}};
for my $k (@K) {
my $slot = $self->get_deep($h, split m(/), $k);
next unless exists $slot->{klc_filename};
open my $fh, '< :encoding(UTF-16)', $slot->{klc_filename}
or die "open of <klc_filename>=`$slot->{klc_filename}' failed: $!";
local $/;
my $in = <$fh>;
push @process, $in;
push @to, $k;
}
for my $k1 (@to) {
#warn "DK sec `$k' -> `$v', <", join('> <', keys %{$h->{'[unparsed]'}{DEADKEYS}{la_ru}}), ">";
#warn "DK sec `$k' -> `$v', <$h->{'[unparsed]'}{DEADKEYS}{la_ru}{unparsed_data}>";
my $v = shift @process;
my($o,$d,$t) = $self->read_deadkeys_win($v); # Translation tables, names, rest of input
my (@parts, @h) = split m(/), $k1;
my %seen = (%$o, %$d);
for my $kk (keys %seen) {
#warn "DK sec `$k1', deadkey `$kk'. Map: ", $self->array2string( [%{$o->{$kk} || {}}] );
my $slot = $self->get_deep($h, @parts, $kk);
warn "Deadkey `$kk' defined for `$k1' conflicts with previous definition"
if $slot and grep exists $slot->{$_}, qw(map name);
$self->put_deep($h, $o->{$kk}, @parts, $kk, 'map') if exists $o->{$kk};
$self->put_deep($h, $d->{$kk}, @parts, $kk, 'name') if exists $d->{$kk};
}
}
$self
}
# http://bepo.fr/wiki/Pilote_Windows
# http://www.phon.ucl.ac.uk/home/wells/dia/diacritics-revised.htm#two
# http://msdn.microsoft.com/en-us/library/windows/desktop/ms646280%28v=vs.85%29.aspx
my %oem_keys = do {{ no warnings 'qw' ; reverse (qw(
OEM_MINUS -
OEM_PLUS =
OEM_4 [
OEM_6 ]
OEM_1 ;
OEM_7 '
OEM_3 `
OEM_5 \
OEM_COMMA ,
OEM_PERIOD .
OEM_2 /
OEM_102 \#
SPACE #
DECIMAL .#
DECIMAL ,#
ABNT_C1 /#
ABNT_C1 ¥
ABNT_C1 ¦
)) }}; #'# Here # marks "second occurence" of keys...
# Extra bindings: see http://www.fysh.org/~zefram/keyboard/xt_scancodes.txt (after “===â€)
# e005 Messenger (or Files); e007 Redo; e008 undo; e009 ApplicationLeft; e00a Paste;
# e00b,e011,e012,e01f ScrollWheel-to-key-emulation
# e013 Word; e014 Excel; e015 Calendar; e016 Log Off; e017 Cut; e018 Copy; e01e ApplicationRight
# e03b -- e044 (Microsoft/Logitech Fkeys_without_Flock, F1...F10)
# e063 Wake; e064 My Pictures [or Keypad-) ]
# (for yet more VK_-symbols see https://learn.microsoft.com/en-us/previous-versions/aa931968(v=msdn.10))
# OEM_ATTN OEM_COPY OEM_CUSEL OEM_ENLW do not have any scancodes assigned anywhere???
# The discussion: https://stackoverflow.com/questions/11740958/js-what-keyboard-keys-are-specified-for-key-codes-in-intervals-146-185-193-218
# More details in (change “Arrangement†if needed): https://kbdlayout.info/kbdibm02/scancodes
# see also this (and references there): https://bsakatu.net/doc/virtual-key-of-windows/
# One of (industrial) keyboards with 000-key: https://geekhack.org/index.php?topic=60355.0
# (Part of a huge family: https://telcontar.net/KBK/Fujitsu/series
# Before OEM_8: For type 4 of keyboard (same as types 1,3, except OEM_AX, (NON)CONVERT, ABNT_C1)
# except KANA,(NON)CONVERT; after OEM_8 all is junk (non-scancodes???)...
my %scan_codes = (reverse qw(
02 1
03 2
04 3
05 4
lib/UI/KeyboardLayout.pm view on Meta::CPAN
e030 VOLUME_UP
e032 BROWSER_HOME
e035 DIVIDE
e037 SNAPSHOT
e038 RMENU
e046 CANCEL
e047 HOME
e048 UP
e049 PRIOR
e04B LEFT
e04D RIGHT
e04F END
e050 DOWN
e051 NEXT
e052 INSERT
e05B LWIN
e05C RWIN
e05D APPS
e05E POWER
e05F SLEEP
e065 BROWSER_SEARCH
e066 BROWSER_FAVORITES
e067 BROWSER_REFRESH
e068 BROWSER_STOP
e069 BROWSER_FORWARD
e06A BROWSER_BACK
e06B LAUNCH_APP1
e06C LAUNCH_MAIL
e06D LAUNCH_MEDIA_SELECT
e11D PAUSE
7D OEM_8
)); # http://www.opensource.apple.com/source/WebCore/WebCore-1C25/platform/gdk/KeyboardCodes.h
# [ ] \ space
my %oem_control = (qw(
OEM_4 [001b
OEM_6 ]001d
OEM_5 \001c
SPACE 0020
OEM_102 \001c
)); # In ru layouts, only entries which match the char are present
my %do_control = map /^(.)(.+)/, values %oem_control;
$do_control{' '} = '0020';
delete $do_control{0};
my %default_bind = ( (map {( "NUMPAD$_" => [[$_]] )} 0..9 ),
TAB => [["\t", "\t"]],
ADD => [["+", "+"]],
SUBTRACT => [["-", "-"]],
MULTIPLY => [["*", "*"]],
DIVIDE => [["/", "/"]],
RETURN => [["\r", "\r"], ["\n"]],
BACK => [["\b", "\b"], ["\x7f"]],
ESCAPE => [["\e", "\e"], ["\e"]],
CANCEL => [["\cC", "\cC"], ["\cC"]],
);
sub get_VK ($$) {
my ($self, $f) = (shift, shift);
$self->get_deep_via_parents($self, undef, 'faces', (split m(/), $f), 'VK') || {}
# $self->{faces}{$f}{VK} || {}
}
my $min_sec;
sub last_pre_funckeys($$) {
my ($self, $l0) = (shift, shift);
unless (defined $min_sec) {
$min_sec = 1e300;
$min_sec > $_->[0] and $min_sec = $_->[0] for values %start_SEC;
}
## warn "Layer disappeared: `$l0'; layer names:\n\t`", join("'\n\t`", sort keys %{$self->{layers}}), "'"
## unless defined $self->{layers}{$l0};
my $post_main = @{ $self->{layers}{$l0} };
if ($post_main >= $min_sec) {
$post_main = $min_sec;
while ($post_main > 0) {
last if grep defined, map {ref() ? $_->[0] : $_} grep defined, @{ $self->{layers}{$l0}[$post_main - 1] || [] };
$post_main--;
}
}
$post_main;
}
sub massage_VK ($$) {
my ($self, $f, %seen, %seen_dead, @dead, @ctrl) = (shift, shift);
my $l0 = $self->{faces}{$f}{layers}[0];
warn "Finding last key for face `$f' layer[0] = `$l0'...\n" if debug_face_layout_recipes;
my $post_main = $self->last_pre_funckeys($l0);
if (my $LF = $self->{faces}{$f}{LinkFace}) {
my $l00 = ($self->export_layers($LF))->[0];
$self->revive_layer($LF, 0, $l00) unless $self->{layers}{$l00};
warn "Finding last key for face `$f' LinkFace = `$l00'...\n" if debug_face_layout_recipes;
my $post_main0 = $self->last_pre_funckeys($l00);
$post_main = $post_main0 if $post_main0 > $post_main;
}
if (defined (my $b = $self->{faces}{$f}{BaseLayer})) { # Cannot bump into known keycodes
warn " mk_tr_lyrs 1" if debug_stacking_ord;
$b = $self->make_translated_layers($b, $f, [0])->[0] if defined $b and not $self->{layers}{$b};
warn "Finding last key for face `$f' BaseLayer = `$b'...\n" if debug_face_layout_recipes;
my $post_main0 = $self->last_pre_funckeys($b);
$post_main = $post_main0 if $post_main0 > $post_main;
}
## warn "post_main=$post_main; layer=$l0 min_sec=$min_sec";
$self->{faces}{$f}{'[non_VK]'} = $post_main;
my $create_a_c = $self->{faces}{$f}{'[create_alpha_ctrl]'};
$create_a_c = $create_alpha_ctrl unless defined $create_a_c;
my $EXTR = [ ["\r","\n"], ["\b","\x7F"], ["\t","\cC"], ["\x1b","\x1d"], # Enter/C-Enter/Bsp/C-Bsp/Tab/Cancel/Esc=C-[/C-]
["\x1c", ($create_a_c ? "\cZ" : ())], ($create_a_c>1 ? (["\x1e", "\x1f"], ["\x00"]) : ())]; # C-\ C-z, C-^ C-_
if ($create_a_c) { # Fill all control-chars too
my %s;
push @ctrl, scalar @$EXTR;
$s{$_}++ for $self->flatten_arrays($EXTR);
my @ctrl_l = grep !$s{$_}, map chr($_), 1..26;
push @$EXTR, [shift @ctrl_l, shift @ctrl_l] while @ctrl_l > 1;
push @$EXTR, [@ctrl_l] if @ctrl_l;
push @ctrl, scalar @$EXTR;
}
lib/UI/KeyboardLayout.pm view on Meta::CPAN
}
sub array2string ($$) {
my ($self, $a) = (shift, shift);
warn "method array2string() takes one argument" if @_;
return '(undef)' unless defined $a;
return "<$a>" unless ref($a || '') eq 'ARRAY';
'[ ' . join(', ', map $self->array2string($_), @$a) . ' ]';
}
sub dialist2lists ($$) {
my ($self, $Dia, @groups) = (shift, shift);
for my $group (split /\|/, $Dia, -1) {
my @dia;
for my $dia (split /,/, $group) {
push @dia, $self->dia2list($dia);
}
push @groups, \@dia; # Do not omit empty groups
} # Now get all the chars, and precompile results for them
@groups
}
sub document_char ($$$;$) {
my ($self, $c, $doc, $old) = (shift, shift, shift, shift);
return $c if not defined $c or not defined $doc;
$doc = "$old->[3] ⇒ $doc" if $old and ref $old and defined $old->[3];
$c = [$c] unless ref $c;
$c->[3] = $doc if defined $doc;
$c
}
sub document_chars_on_key ($$$;$) { # Usable with all_layers
my ($self, $c, $doc, $old, @o) = (shift, shift, shift, shift);
for my $layer (@$c) {
push @o, [ map {$self->document_char($_, $doc, $old)} @$layer ];
}
@o
}
#use Dumpvalue;
my %translators = ( Id => sub ($) {shift}, Empty => sub ($) { return undef },
dectrl => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c;
return undef if 0x20 <= ord $c; chr(0x40 + ord $c)},
maybe_ucfirst => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c; ucfirst $c},
maybe_lc => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c; lc $c},
maybe_uc => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c; uc $c},
ucfirst => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c;
my $c1 = ucfirst $c; return undef if $c1 eq $c; $c1},
lc => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c;
my $c1 = lc $c; return undef if $c1 eq $c; $c1},
uc => sub ($) {defined (my $c = shift) or return undef; $c = $c->[0] if 'ARRAY' eq ref $c;
my $c1 = uc $c; return undef if $c1 eq $c; $c1} );
sub make_translator ($$$$$) { # translator may take some values from "environment"
# (such as which deadkey is processed), so caching is tricky: if does -> $used_deadkey reflects this
# The translator should return exactly one value (possibly undef) so that map TRANSLATOR, list works intuitively.
# Exception: translator with all_layers: takes a ref to a key (array of arrays of chars); returns array of arrays.
# There is a possibility to redirect the translation to another key; see $cvt (usually combined with 'all_layers').
my ($self, $name, $deadkey, $face, $N, $used_deadkey) = (shift, shift, shift || 0, shift, shift, ''); # $deadkey used eg for diagnostics
die "Undefined recipe in a translator for face `$face', layer $N on deadkey `$deadkey'" unless defined $name;
if ($name =~ /^Imported\[([\/\w]+)(?:,([\da-fA-F]{4,}))?\]$/) {
my($d, @sec) = (($2 ? "$2" : undef), split m(/), "$1");
$d = $deadkey, $used_deadkey ="/$deadkey" unless defined $d;
my $fromKBDD = $self->get_deep($self, 'DEADKEYS', @sec, lc $d, 'map') # DEADKEYS/bepo with 00A4 ---> DEADKEYS/bepo/00a4
or die "DEADKEYS section for `$d' with parts `@sec' not found";
# indexed by lc hex
return sub { my $cc=my $c=shift; return $c unless defined $c; $c = $c->[0] if 'ARRAY' eq ref $c; defined($c = $fromKBDD->{$self->key2hex($c)}) or return $c; $self->document_char(chr hex $c, $name, $cc) }, '';
}
die "unrecognized Imported argument: `$1'" if $name =~ /^Imported(\[.*)/s;
return $translators{$name}, '' if $translators{$name};
if ($name =~ /^PrefixDocs\[(.+)\]$/) {
$self->{faces}{$face}{'[prefixDocs]'}{$deadkey} = $1;
return $translators{Empty}, '';
}
if ($name =~ /^X11symbol\[(.+)\]$/) {
$self->{faces}{$face}{'[dead_X11symbol]'}{$deadkey} = $1;
return $translators{Empty}, '';
}
if ($name =~ /^Show\[(.+)\]$/) {
$self->{faces}{$face}{'[Show]'}{$deadkey} = $self->stringHEX2string($1);
return $translators{Empty}, '';
}
if ($name =~ /^HTML_classes\[(.+)\]$/) {
(my @c = split /,/, "$1") % 3 and die "HTML_classes[] for key `$deadkey' not come in triples";
my $C = ( $self->{faces}{$face}{'[HTML_classes]'}{$deadkey || ''} ||= {} ); # Above, deadkey is ||= 0
# warn "I create HTML_classes for face=$face, prefix=`$deadkey'";
while (@c) {
my ($where, $class, $chars) = splice @c, 0, 3;
( $chars = $self->stringHEX2string($chars) ) =~ s/\p{Blank}(?=\p{NonspacingMark})//g;
push @{ $C->{$where}{$_} }, $class for split //, $chars;
}
return $translators{Empty}, '';
}
if ($name =~ /^Space(Self)?2Id(?:\[(.+)\])?$/) {
my $dia = $self->charhex2key((defined $2) ? $2 : do {$used_deadkey = "/$deadkey"; $deadkey}); # XXXX `do' is needed, comma does not work
my $self_OK = $1 ? $dia : 'n/a';
return sub ($) { my $c = (shift() || '[none]'); $c = $c->[0] if 'ARRAY' eq ref $c; # Prefix key as usual letter
($c eq ' ' or $c eq $self_OK and defined $dia) ? $self->document_char($dia, $name) : undef }, $used_deadkey;
}
if ($name =~ /^ShiftFromTo\[(.+)\]$/) {
my ($f,$t) = split /,/, "$1";
$_ = hex $self->key2hex($self->charhex2key($_)) for $f, $t;
$t -= $f; # Treat prefix keys as usual keys:
return sub ($) { my $cc=my $c=shift; return $c unless defined $c; $c = $c->[0] if 'ARRAY' eq ref $c; $self->document_char(chr($t + ord $c), $name, $cc) }, '';
}
if ($name =~ /^SelectRX\[(.+)\]$/) {
my ($rx) = qr/$1/; # Treat prefix keys as usual keys:
return sub ($) { my $cc = my $c=shift; defined $c or return $c; $c = $c->[0] if 'ARRAY' eq ref $c; return undef unless $c =~ $rx; $cc }, '';
}
if ($name =~ /^FlipShift$/) {
return sub ($) { my $c = shift; defined $c or return $c; map [@$_[1,0]], @$c }, '', 'all_layers';
}
if ($name =~ /^AssignTo\[(\w+),(\d+)\]$/) {
my ($sec, $cnt) = ($1, $2);
$cnt = 0, warn "Unrecognized section `$sec' in AssignTo" unless my $S = $start_SEC{$sec};
warn("Too many keys ($cnt) put into section `$sec', max=$S->[1]"), $cnt = $S->[1] if $cnt > $S->[1];
my $toTarget = sub { my $slot = shift; return unless $slot < $cnt; $slot + $S->[0] };
return sub ($) { @{shift()} }, '', ['all_layers', $toTarget];
}
if ($name =~ /^FromTo(FlipShift)?\[(.+)\]$/) {
my $flip = $1;
my ($f,$t) = split /,/, "$2", 2;
exists $self->{layers}{$_} or (debug_stacking_ord and warn " mk_tr_lyrs 2"),
$_ = ($self->make_translated_layers($_, $face, [$N], $deadkey))->[0]
for $f, $t; # Be conservative for caching...
my $B = "~~~{$f>>>$t}";
$_ = $self->{layers}{$_} for $f, $t;
my (%h, $kk);
for my $k (0..$#$f) {
my @fr = map {($_ and ref) ? $_->[0] : $_} @{$f->[$k]};
my @to = map {($_ and ref) ? $_->[0] : $_} @{$t->[$k]};
if ($flip) {
$h{defined($kk = $fr[$_]) ? $kk : ''} = $to[1-$_] for 0,1;
} else {
$h{defined($kk = $fr[$_]) ? $kk : ''} = $to[$_] for 0,1;
}#
} # Treat prefix keys as usual keys:
return sub ($) { my $cc = my $c = shift; defined $c or return $c; $c = $c->[0] if 'ARRAY' eq ref $c; $self->document_char($h{$c}, $name, $cc) }, $B;
}
if ($name =~ /^InheritPrefixKeys\[(.+)\]$/) {
my $base = $1;
exists $self->{layers}{$_} or (debug_stacking_ord and warn " mk_tr_lyrs 3"),
$_= ($self->make_translated_layers($_, $face, [$N], $deadkey))->[0]
for $base;
my $baseL = $self->{layers}{$base};
my (%h);
for my $k (0..$#$baseL) {
for my $shift (0..1) {
my $C = $baseL->[$k][$shift] or next;
next unless ref $C and $C->[2]; # prefix
$h{"$N $k $shift $C->[0]"} = $C;
}
} # Treat prefix keys as usual keys:
return sub ($) { my $c = shift; defined $c or return $c; return $c if 'ARRAY' eq ref $c and $c->[2]; $h{"@_ $c"} or $c }, $base;
}
if ($name =~ /^ByColumns\[(.+)\]$/) {
my @chars = map {length() ? $self->charhex2key($_) : undef} split /,/, "$1";
my $g = $self->{faces}{$face}{'[geometry]'}
or die "Face `$face' has no associated layer with geometry info; did you set geometry_via_layer?";
my $o = ($self->{faces}{$face}{'[g_offsets]'} or [(0) x @$g]);
$o = [@$o]; # deep copy
my ($tot, %c) = 0;
# warn "geometry: [@$g] [@$o]";
for my $r (@$g) {
my $off = shift @$o;
$c{$tot + $_} = $_ + $off for 0..($r-1);
$tot += $r;
}
return sub ($$$$) { (undef, my ($L, $k, $shift)) = @_; return undef if $L or $shift or $k >= $tot; $self->document_char($chars[$c{$k}], "ByColumn[$c{$k}]") }, '';
}
if ($name =~ /^ByRows\[(.+)\]$/) {
s(^\s+(?!\s|///\s+))(), s((?<!\s)(?<!\s///)\s+$)() for my $recipes = $1;
my (@recipes, @subs) = split m(\s+///\s+), $recipes;
my $LL = $#{ $self->{faces}{$face}{layers} }; # Since all_layers, we are called only for layer 0; subrecipes may need more
for my $rec (@recipes) {
push(@subs, sub {return undef}), next unless length $rec;
#warn "recipe=`$rec'; face=`$face'; N=$N; deadkey=`$deadkey'; last_layer=$LL";
my ($tr) = $self->make_translator_for_layers( $rec, $deadkey, $face, [0..$LL] );
#warn " done";
push @subs, $tr;
}
my $g = $self->{faces}{$face}{'[geometry]'}
or die "Face `$face' has no associated layer with geometry info; did you set geometry_via_layer?";
my ($tot, $row, %r) = (0, 0);
# warn "geometry: [@$g] [@$o]";
for my $r (@$g) {
$r{$tot + $_} = $row for 0..($r-1);
$tot += $r;
$row++;
}
# return sub ($$$$) { (undef, undef, my $k) = @_; return undef if $k >= $tot; return undef if $#recipes < (my $r = $r{$k});
# die "Undefined recipe: row=$row; face=`$face'; N=$N; deadkey=`$deadkey'; ARGV=(@_)" unless $subs[$r];
# goto &{$subs[$r]} }, '';
return sub ($$) { (undef, my $k) = @_; return [] if $k >= $tot or $#recipes < (my $r = $r{$k});
die "Undefined recipe: row=$row; face=`$face'; N=$N; deadkey=`$deadkey'; ARGV=(@_)" unless $subs[$r];
goto &{$subs[$r]} }, '', 'all_layers';
}
if ($name =~ /^(?:Diacritic|Mutate)(SpaceOK)?(Hack)?(2Self)?(DupsOK)?(32OK)?(?:\[(.+)\])?$/) {
my ($spaceOK, $hack, $toSelf, $dupsOK, $w32OK) = ($1, $2, $3, $4, $5);
my $Dia = ((defined $6) ? $6 : do {$used_deadkey ="/$deadkey"; $deadkey}); # XXXX `do' is needed, comma does not work
if ($toSelf) {
die "Mutate2Self does not make sense with SpaceOK/Hack/DupsOK/32OK" if grep $_, $hack, $spaceOK, $dupsOK, $w32OK;
$Dia = $self->charhex2key($Dia);
my(@sp, %sp) = map {(my $in = $_) =~ s/(?<=.)\@$//s; $in} @{ ($self->get_VK($face))->{SPACE} || [] };
@sp = map $self->charhex2key($_), @sp;
my $flip_AltGr = $self->{faces}{$face}{'[Flip_AltGr_Key]'};
$flip_AltGr = $self->charhex2key($flip_AltGr) if defined $flip_AltGr;
@sp = grep $flip_AltGr ne $_, @sp if defined $flip_AltGr; # It has a different function...
@sp{@sp[1..$#sp]} = (0..$#sp); # The leading elt is the scancode
# warn "SPACE on $Dia: <", join('> <', %sp), '>';
return sub ($) {
$self->document_chars_on_key([$self->diacritic2self_2($Dia, shift, $face, \%sp)], $name)
}, $used_deadkey, 'all_layers';
}
my $isPrimary;
$Dia =~ s/^\+// and $isPrimary++; # Wait until <NAMED-*> are expanded
my $f = $self->get_NamesList;
$self->load_compositions($f) if defined $f;
$f = $self->get_AgeList;
$self->load_uniage($f) if defined $f and not $self->{Age};
# New processing: - = strip 1 from end; -3/ = strip 1 from the last 3
#warn "Doing `$Dia'";
#print "Doing `$Dia'\n";
#warn "Age of <Ã > is <$self->{Age}{Ã }>";
$Dia =~ s(<NAMED-([-\w]+)>){ (my $R = $1) =~ s/-/_/g;
die "Named recipe `$1' unknown" unless exists $self->{faces}{$face}{"Named_DIA_Recipe__$R"};
# (my $r = $self->{faces}{$face}{"Named_DIA_Recipe__$R"}) =~ s/^\s+//;
$self->recipe2str($self->{faces}{$face}{"Named_DIA_Recipe__$R"}) }ge;
$Dia =~ s/\|{3,4}/|/g if $isPrimary;
my($skip, $limit, @groups, @groups2, @groups3) = (0);
lib/UI/KeyboardLayout.pm view on Meta::CPAN
next unless $extra->[1];
$self->deep_undef_by_hash(\%seen, $extra->[1]);
for my $Ln (0..$#L) {
my $o = $out[$Ln];
unless (defined $o->[0] and defined $o->[1]) {
my $o2 = $self->shift_pop_compositions($extra->[1], $Ln, $extra->[0], !'omit', !'limit', 0, undef, defined $o->[0], defined $o->[1]);
$o2 = [map {(!defined $_ or ref) ? $_ : [$_,undef,undef,"Diacritic operator (choice $extra->[2])"]} @$o2];
defined $o->[$_] or $o->[$_] = $o2->[$_] for 0,1;
$seen{$_}++ for grep defined, map {($_ and ref) ? $_->[0] : $_} @$o;
}
}
}
print 'Extracted ', $self->array2string(\@out), " deadKey=$deadkey\n" if printSORTEDLISTS;
warn 'Extracted ', $self->array2string(\@out), " deadKey=$deadkey\n" if warnSORTEDLISTS;
$self->{faces}{$face}{'[from_dia_chains]'}{$_}++
for grep defined, ($hack ? () : map {($_ and ref) ? $_->[0] : $_} map @{$_||[]}, @out);
#warn "Age of <Ã > is <$self->{Age}{Ã }>";
#warn "Output: <", join('> <', map {defined() ? $_ : '[undef]'} $self->flatten_arrays(\@out)), '>';
return @out;
}, $used_deadkey, 'all_layers';
}
if ($name =~ /^DefinedTo\[(.+)\]$/) {
my $to = ($1 eq 'undef' ? [] : $self->charhex2key($1));
return sub ($) { my $c = shift; defined $c or return $c; $self->document_char($to, 'DefinedTo', $c) }, '';
}
if ($name =~ /^ByPairs(Inv)?(Prefix)?(Flat)?(Apple)?\[(.+)\]$/) {
my ($invert, $prefix, $flat, $Apple, $in, @Pairs, %Map) = ($1, $2, $3, $4, $5);
die "Inversion is tested only with flat maps or a prefix key: <<<$in>>> in `$face´" if $invert and not ($flat or $prefix);
$in =~ s/^\s+//;
@Pairs = split /\s+(?!\p{NonspacingMark})/, $in;
for my $p (@Pairs) {
while (length $p) {
die "Odd number of characters in a ByPairs map <$in>"
unless $p =~ s/^((?:\p{Blank}\p{NonspacingMark}|(?:\b\.)?[0-9a-f]{4,}\b(?:\.\b)?|.){2})//i;
(my $Pair = $1) =~ s/\p{Blank}//g;
#warn "Pair = <$Pair>";
# Cannot do it earlier, since HEX can introduce new blanks
$Pair =~ s/(?<=[0-9a-f]{4})\.$//i; # Remove . which was on \b before extracting substring
$Pair = $self->stringHEX2string($Pair);
#warn " --> <$Pair>";
die "Can't split ByPairs rule into a pair: I see <$Pair>" unless 2 == scalar (my @c = split //, $Pair);
die qq("From" character <$c[0] duplicated in a ByPairs map <$in>)
if exists $Map{$c[0]};
$Map{$c[0]} = ($prefix ? [$c[1], undef, ($invert ? 3 : 1)<<3] : $c[1]); # massage_imported2 makes >> 3
}
}
die "Empty ByPairs map <$in>" unless %Map; # Treat prefix keys as usual keys:
if ($Apple) { # XXXX ???? This does not work! Do we store $deadkey anywhere?
$self->{faces}{$face}{'[AppleMap]'}[$N]{$_} = $Map{$_} for keys %Map;
return $translators{Empty}, '';
}
if ($flat and not $N) {
die "<<<Flat>>> makes sense only in toplevel descriptions of satellite faces: <<<$in>>> in `$face´" unless $deadkey;
my $inv = $invert ? 'Inv' : '';
$self->{faces}{$face}{"[FlatPrefixMap$inv]"}{$deadkey}{$self->key2hex($_)}
= $self->document_char($Map{$_}, 'explicit flat tuneup') for keys %Map;
$used_deadkey = "/$deadkey";
}
return sub ($) { my $c = shift; defined $c or return $c; $c = $c->[0] if 'ARRAY' eq ref $c; $self->document_char($Map{$c}, 'explicit tuneup') }, $used_deadkey;
}
my $map = $self->get_deep($self, 'DEADKEYS', split m(/), $name);
die "Can't resolve character map `$name'" unless defined $map;
unless (exists $map->{map}) {{
my($k1) = keys %$map;
die "Character map `$name' does not contain HEX: `$k1'" if %$map and not $k1 =~ /^[0-9a-f]{4,}$/;
die "Character map is a parent-type map, but no deadkey to use specified" unless defined $deadkey;
my $Map = { map +(chr hex $_, $map->{$_}), keys %$map };
die "Character map `$name' does not contain `$deadkey', contains <", (join '> <', keys %$map), ">"
unless exists $Map->{chr hex $deadkey};
$map = $Map->{chr hex $deadkey}, $used_deadkey = "/$deadkey" if %$Map;
$map = {map => {}}, warn "Character map for `$name' empty" unless %$map;
}}
die "Can't resolve character map `$name' `map': <", (join '> <', %$map), ">" unless defined $map->{map};
$map = $map->{map};
my $Map = { map +(chr hex $_, chr hex($map->{$_})), keys %$map }; # hex form is not unique
( sub ($) { # Treat prefix keys as usual keys:
my $c = shift; defined $c or return $c; $c = $c->[0] if 'ARRAY' eq ref $c; $self->document_char($Map->{$c}, "DEADKEYS=$name")
}, $used_deadkey )
}
sub depth1_A_translator($$) { # takes a ref to an array of chars
my ($self, $tr) = (shift, shift);
return sub ($) {
my $in = shift;
[map $tr->($_), @$in]
}
}
sub depth2_translator($$) { # takes a ref to an array of arrays of chars
my ($self, $tr) = (shift, shift);
return sub ($$) {
my ($in, $k, @out) = (shift, shift);
for my $L (0..$#$in) {
my $Tr = $tr->[$L];
die "Undefined translator for layer=$L; total=", scalar @$tr unless defined $Tr;
push @out, [map $Tr->($in->[$L][$_], $L, $k, $_), 0..$#{$in->[$L]}]
}
@out
}
}
sub make_translator_for_layers ($$$$$) { # translator may take some values from "environment"
# (such as which deadkey is processed), so caching is tricky: if does -> $used_deadkey reflects this
# The translator should return exactly one value (possibly undef) so that map TRANSLATOR, list works intuitively.
my ($self, $name, $deadkey, $face, $NN) = (shift, shift, shift || 0, shift, shift); # $deadkey used eg for diagnostics
my ($Tr, $used, $for_layers) = $self->make_translator( $name, $deadkey, $face, $NN->[0] );
($for_layers, my $cvt) = (ref $for_layers ? @$for_layers : $for_layers);
return $Tr, [map "$used![$_]", @$NN], $cvt if $for_layers;
my @Tr = map [$self->make_translator($name, $deadkey, $face, $_)], @$NN;
$self->depth2_translator([map $_->[0], @Tr]), [map $_->[1], @Tr], $cvt;
}
sub make_translated_layers_tr ($$$$$$$) { # Apply translation map
my ($self, $layers, $tr, $append, $deadkey, $face, $NN) = (shift, shift, shift, shift, shift, shift, shift);
my ($Tr, $used, $cvt) = $self->make_translator_for_layers($tr, $deadkey, $face, $NN);
#warn " tr=<$tr>, key=<$deadkey>, used=<$used>";
my @new_names = map "$tr$used->[$_]($layers->[$_])$append" . ($append and $NN->[$_]), 0..$#$NN;
return @new_names unless grep {not exists $self->{layers}{$_}} @new_names;
# warn "Translating via `$tr' from layer [$layer]: <", join('> <', map "@$_", @{$self->{layers}{$layer}}), '>';
my (@L, @LL) = map $self->{layers}{$_}, @$layers;
for my $n (0..$#{$L[0]}) { # key number
lib/UI/KeyboardLayout.pm view on Meta::CPAN
or die "Whitespace face recipe `$recipe'?!";
if (@parts > 1) {
#warn "parts of the translation spec: <", join('> <', @parts), '>';
my @layers = map $self->make_translated_layers($_, $face, $NN, $deadkey), @parts;
warn "Stacking/NOID for layers `@parts'", (join "\n\t", '', map {join ' &&& ', @$_} @layers), "\n"
if debug_noid and $noid or debug_stacking;
#print "Stacking for `$recipe'\n" if $DEBUG;
#Dumpvalue->new()->dumpValue(\@layers) if $DEBUG;
return [$self->make_translated_layers_noid($noid eq 'NotSameKey' && " $parts[0] ", @layers)]
if $noid;
return [$self->make_translated_layers_stack(@layers)];
}
return [map $self->pseudo_layer($recipe, $face, $_), @$NN]
if $recipe =~ /^(prefix(?:NOTSAME(?:case)?)?=.*|(FlipLayers)?LinkFace|FlipLayers|Self|((Full)?(Face|FlipLayers)|Layers)\([^()]+\))$/;
$recipe =~ s/^(FlipShift)$/$1(Self)/;
if ( $recipe =~ /\)$/ ) {
if ( $recipe =~ /^[^(]*\[/ ) { # Tricky: allow () inside Func[](args)
my $pos;
while ( $recipe =~ /(?=\]\()/g ) {
$pos = 1 + pos $recipe, last if $self->brackets_match_q(substr $recipe, 0, 1 + pos $recipe)
}
die "Can't parse `$recipe' as Func[Arg1](Arg2)" unless $pos;
$ARG = substr $recipe, $pos + 1, length($recipe) - $pos - 2;
$recipe = substr $recipe, 0, $pos;
} else {
my $o = $recipe;
($recipe, $ARG) = ($recipe =~ /^(.*?)\((.*)\)$/s) or warn "Can't parse recipe `$o'";
}
} else {
$ARG = '';
}
#warn "Translation sub-spec: recipe = <$recipe>, ARG=<$ARG>";
if ($recipe =~ /^If(Not)?Prefix\[(.*)\]$/s) { # No embedded \\]
my $neg = $1;
my @prefix = map $self->key2hex($self->charhex2key($_)), split /,/, "$2";
### warn "dk=<$deadkey> prefix=<@prefix>" if defined $deadkey;
return $self->make_translated_layers($ARG, $face, $NN, $deadkey, $noid)
if defined($deadkey) and ($neg xor grep $_ eq $deadkey, @prefix);
($recipe, $ARG) = ('Empty', [('Empty') x @$NN]);
}
if (length $ARG) {
if (exists $self->{layers}{$ARG}) {
$ARG = [($ARG) x @$NN];
} elsif (!ref $ARG) {
($ARG = $self->layer_recipe($ARG)) =~ s/^\s+// if exists $self->{layer_recipes}{my $a = $ARG};
warn "make_translated_layers: Using layout_recipe `$ARG' for layer '$a'\n" if debug_face_layout_recipes and exists $self->{layer_recipes}{$a};
($noid) = ($recipe =~ /^(NotId|NotSameKey)$/);
$ARG = $self->make_translated_layers($ARG, $face, $NN, $deadkey, $noid);
return $ARG if $noid;
}
} else {
$ARG = [map $self->{faces}{$face}{layers}[$_], @$NN];
$append = "#$face#";
}
[$self->make_translated_layers_tr($ARG, $recipe, $append, $deadkey, $face, $NN)]; # Either we saw (), or $recipe is not a face recipe!
}
sub massage_translated_layers ($$$$;$) {
my ($self, $in, $face, $NN, $deadkey) = (shift, shift, shift, shift, shift, '');
#warn "Massaging `$deadkey' for `$face':$N";
return $in unless my $r = $self->get_deep($self, 'faces', (my @p = split m(/), $face), '[Diacritic_if_undef]');
$r =~ s/^\s+//;
#warn " -> end recipe `$r'";
warn " mk_tr_lyrs 6" if debug_stacking_ord;
my $post = $self->make_translated_layers($r, $face, $NN, $deadkey);
warn " mk_tr_lyrs_st 1" if debug_stacking_ord;
return [$self->make_translated_layers_stack($in, $post)];
}
sub default_char ($$) {
my ($self, $F) = (shift, shift);
my $default = $self->get_deep($self, 'faces', $F, '[DeadChar_DefaultTranslation]');
$default =~ s/^\s+//, $default = $self->charhex2key($default) if defined $default;
$default;
}
sub create_inverted_face ($$$$$) {
my ($self, $F, $KK, $chain, $flip_AltGr) = (shift, shift, shift, shift, shift);
my $H = $self->{faces}{$F};
my $auto_chr = $H->{'[deadkeyInvAltGrKey]'}{$KK};
my $new_facename = $H->{'[deadkeyFaceInvAltGr]'}{$auto_chr};
my ($LL, %Map) = $H->{'[deadkeyLayers]'}{$KK};
$LL = $H->{layers} if $KK eq '';
%Map = ($flip_AltGr, [$chain->{$KK and $self->charhex2key($KK)}, undef, 1, 'AltGrInv-faces-chain'])
if defined $flip_AltGr and defined $chain->{$KK and $self->charhex2key($KK)};
warn " patch_face 0 f=$F k=$KK" if debug_stacking_ord;
$self->patch_face($LL, $new_facename, $H->{"[InvdeadkeyLayers]"}{$KK}, $KK, \%Map, $F, 'invert');
# warn "Joining <$F>, <$new_facename>";
$self->link_layers($F, $new_facename, 'skipfix', 'no-slot-warn');
if ($KK eq '' and defined $flip_AltGr) {
$H->{'[deadkeyFace]'}{$self->key2hex($flip_AltGr)} = $H->{'[deadkeyFaceInvAltGr]'}{$auto_chr};
}
if ($H->{"[InvdeadkeyLayers]"}{$KK}) { # There are overrides for the inverted face. Make a map for them...
#warn "Overriding face for inverted `$KK' in face $F; new_facename=$new_facename";
$H->{'[InvAltGrFace]'}{$KK} = "$new_facename\@override";
$self->{faces}{"$new_facename\@override"}{layers} = $H->{"[InvdeadkeyLayers]"}{$KK};
$self->link_layers($F, "$new_facename\@override", 'skipfix', 'no-slot-warn');
}
$new_facename;
}
sub auto_dead_can_wrap ($$) { # Call after all the manually set prefix key are already established, so one can avoid them
my ($self, $F) = (shift, shift);
$self->{faces}{$F}{'[ad_can_wrap]'}++
}
sub next_auto_dead ($$) {
my ($self, $H, $o) = (shift, shift);
unless ($H->{'[autodead_wrapped]'}) {
1 while $H->{'[auto_dead]'}{ $o = $H->{'[first_auto_dead]'}++ }++ and ($o < 0x1000 or not $H->{'[ad_can_wrap]'}); # Bug in kbdutool
$H->{'[first_auto_dead]'} = 0xa0 if $o >= 0x1000 and $H->{'[ad_can_wrap]'} and not $H->{'[autodead_wrapped]'}++;
}
if ($H->{'[autodead_wrapped]'}) { # This does not deal with manual assignment of inverted prefixes??? Inv_AltGr???
1 while $H->{'[auto_dead]'}{ $o = $H->{'[first_auto_dead]'}++ }++ or $H->{'[deadkeyFaceHexMap]'}{$self->key2hex(chr $o)};
# if ($o == 0x00a3) {
# warn "$o: Keys HexMap: ", join ', ', sort keys %{$H->{'[deadkeyFaceHexMap]'}};
# }
}
chr $o;
}
sub recipe2str ($$) {
(undef, my $recipe) = (shift, shift);
if ('ARRAY' eq ref $recipe) {
$recipe = [@$recipe]; # deep copy
s/\s+$//, s/^\s+// for @$recipe;
s/(?<![|,])$/ / for @$recipe[0..($#$recipe - 1)]; # Join by spaces unless after comma or |
$recipe = join '', @$recipe;
}
$recipe =~ s/^\s+//;
$recipe
}
sub scan_for_DeadKey_Maps ($) { # Makes a direct-access synonym, scan for DeadKey_Maps* keys
my ($self, %h, $expl) = (shift);
#Dumpvalue->new()->dumpValue($self);
my @F = grep m(^faces(/.*)?$), @{$self->{'[keys]'}};
for my $FF (@F) {
(my $F = $FF) =~ s(^faces/?)();
my(@FF, @HH) = split m(/), $FF;
next if @FF == 1 or $FF[-1] eq 'VK';
my @FF1 = @FF;
push(@HH, $self->get_deep($self, @FF1)), pop @FF1 while @FF1; # All the parents
my $H = $HH[0];
next if $H->{PartialFace};
$self->{faces}{$F} = $H if $F =~ m(/) and exists $H->{layers}; # Make a direct-access copy
#warn "Face section `${FF}'s parents: ", scalar @HH;
#warn "Mismatch of hashes for `$FF'" unless $self->{faces}{$F} == $H;
# warn "compositing: faces `$F'; -> <", (join '> <', %$H), ">";
for my $HH (@HH) {
for my $k ( keys %$HH ) {
# warn "\t`$k' -> `$HH->{$k}'";
next unless $k =~ m(^DeadKey_(Inv|Add)?Map([0-9a-f]{4,})?(?:_(\d+))?$)i;
#warn "\t`$k' -> `$HH->{$k}'";
my($inv, $key, $layers) = ($1 || '', $2, $3);
$key = $self->key2hex($self->charhex2key($key)) if defined $key; # get rid of uc/lc hex problem
# XXXX The problem is that the parent may define layers in different ways (_0,_1 or no); ignore it for now...
$H->{'[DeadKey__Maps]'}{$key || ''}{$inv}{(defined $layers) ? $layers : 'All'} ||= $HH->{$k};
}
}
}
}
#use Dumpvalue;
sub ensure_DeadKey_Map_by_recipe ($$$$;$$) {
my ($self, $F, $hexPrefix, $recipe, $layers, $inv) = (shift, shift, shift, shift, shift, shift || '');
my $H = $self->{faces}{$F};
return if $H->{"[${inv}deadkeyLayersCreated]"}{$hexPrefix}{$layers and "@$layers"}++;
#Dumpvalue->new()->dumpValue($self);
my $massage = !($recipe =~ s/\s+NoDefaultTranslation$//);
$layers ||= [ 0 .. $#{$self->{faces}{$F}{layers}} ];
#warn "Doing key `$hexPrefix' inv=`$inv' face=`$F', recipe=`$recipe'";
warn " mk_tr_lyrs 7 (F=$F, p=$hexPrefix)" if debug_stacking_ord;
my $new = $self->make_translated_layers($recipe, $F, $layers, $hexPrefix);
$new = $self->massage_translated_layers($new, $F, $layers, $hexPrefix) if $massage and not $inv;
for my $NN (0..$#$layers) { # Create a layer according to the spec
#warn "DeadKey Layer for face=$F; layer=$layer, k=$k:\n\t$HH->{$k}, key=`", ($hexPrefix||''),"'\n\t\t";
#$DEBUG = $hexPrefix eq '0192';
#print "Doing key `$hexPrefix' face=$F layer=`$layer' recipe=`$recipe'\n" if $DEBUG;
#Dumpvalue->new()->dumpValue($self->{layers}{$new}) if $DEBUG;
#warn "new=<<<", join('>>> <<<', @$new),'>>>';
$H->{"[${inv}deadkeyLayers]"}{$hexPrefix}[$layers->[$NN]] = $new->[$NN];
#warn "Face `$F', layer=$layer key=$hexPrefix\t=> `$new'" if $H->{layers}[$layer] =~ /00a9/i;
#Dumpvalue->new()->dumpValue($self->{layers}{$new}) if $self->charhex2key($hexPrefix) eq chr 0x00a9;
}
}
sub ensure_DeadKey_Map ($$$;$) {
my ($self, $F, $hexPrefix, $hexPrefixWas, %h, $expl) = (shift, shift, shift, shift);
$hexPrefixWas = $hexPrefix unless defined $hexPrefixWas;
my $H = $self->{faces}{$F};
my $v0 = $H->{'[DeadKey__Maps]'}{$hexPrefixWas};
for my $inv (sort keys %$v0) {
my $v1 = $v0->{$inv};
my $K = (($inv and "$inv $hexPrefix" eq "Inv 0000") ? '' : $hexPrefix);
for my $layers (sort keys %$v1) {
my $recipe = $self->recipe2str($v1->{$layers});
$layers = ($layers eq 'All' ? '' : [$layers]);
$self->ensure_DeadKey_Map_by_recipe($F, $K, $recipe, $layers, $inv);
}
}
}
sub create_DeadKey_Maps ($) {
my ($self, %h, $expl) = (shift);
#Dumpvalue->new()->dumpValue($self);
for my $F ($self->order_faces_4_massage) {
next if 'HASH' ne ref $self->{faces}{$F} or $F =~ /\bVK$/; # "parent" taking keys for a child
my $H = $self->{faces}{$F};
my $flip_AltGr = $H->{'[Flip_AltGr_Key]'};
$flip_AltGr = (defined $flip_AltGr) ? $self->charhex2key($flip_AltGr) : 'N/A';
# Treat first the specific maps (for one deadkey) then the deadkeys which were not seen via the universal map
for my $key (sort keys %{$H->{'[DeadKey__Maps]'}}) {
### my $v0 = $H->{'[DeadKey__Maps]'}{$key};
my @keys = (($key ne '')
? $key
: (grep {not $H->{'[DeadKey__Maps]'}{$_} and not $H->{'[ComposeKeys]'}{$_}}
map $self->key2hex($_), grep $_ ne $flip_AltGr, sort keys %{ $H->{'[DEAD]'} }));
$self->ensure_DeadKey_Map($F, $_, $key) for @keys;
}
}
}
#use Dumpvalue;
sub create_composite_layers ($) {
my ($self, %h, $expl) = (shift);
#Dumpvalue->new()->dumpValue($self);
for my $F (keys %{ $self->{faces} }) {
next if 'HASH' ne ref $self->{faces}{$F} or $F =~ /\bVK$/; # "parent" taking keys for a child
my $H = $self->{faces}{$F};
next if $H->{PartialFace};
next unless $H->{'[deadkeyLayers]'}; # Are we in a no-nonsense Face-hash with defined deadkeys?
#warn "Face: <", join( '> <', %$H), ">";
my $layerL = @{ $self->{layers}{ $H->{layers}[0] } }; # number of keys in the face (in the principal layer)
my $first_auto_dead = $H->{'[Auto_Diacritic_Start]'};
$H->{'[first_auto_dead]'} = ord $self->charhex2key($first_auto_dead) if defined $first_auto_dead;
for my $KK (sort keys %{$H->{'[deadkeyLayers]'}}) { # Given a deadkey: join layers into a face, and link to it
for my $layer ( 0 .. $#{ $H->{layers} } ) {
#warn "Checking for empty layers, Face `$face', layer=$layer key=$KK";
$self->{layers}{"[empty$layerL]"} ||= [map[], 1..$layerL], $H->{'[deadkeyLayers]'}{$KK}[$layer] = "[empty$layerL]"
unless defined $H->{'[deadkeyLayers]'}{$KK}[$layer]
}
# Join the syntetic layers (now well-formed) into a new synthetic face:
my $new_facename = "$F###$KK";
$self->{faces}{$new_facename}{layers} = $H->{'[deadkeyLayers]'}{$KK};
$H->{'[deadkeyFace]'}{$KK} = $new_facename;
#warn "Joining <$F>, <$new_facename>";
# $self->link_layers($F, $new_facename, 'skipfix', 'no-slot-warn'); # Now moved to link_composite_layers
}
}
$self
}
sub create_prefix_chains ($) {
my ($self, %h, $expl) = (shift);
my @F = grep m(^faces(/.*)?$), @{$self->{'[keys]'}};
for my $FF (@F) {
(my $F = $FF) =~ s(^faces/?)();
my(@FF, @HH) = split m(/), $FF;
next if @FF == 1 or $FF[-1] eq 'VK';
push(@HH, $self->get_deep($self, @FF)), pop @FF while @FF;
my($H, %KK) = $HH[0];
for my $chain ( @{ $H->{'[PrefixChains]'} || [] } ) {
(my $c = $chain) =~ s/^\s+//;
my @prefix = map { $_ and $self->charhex2key($_) } split /,/, $c, -1; # trailing empty means all are prefixes
length(my $trail_nonprefix = $prefix[-1]) or pop @prefix;
my $start = shift @prefix;
warn "PrefixChain for `$start' in font `$F' is empty" unless @prefix > 1;
for my $Kn (1..$#prefix) {
my($from, $to) = @prefix[$Kn-1, $Kn];
$KK{$from}{$start} = [$to, undef, $Kn != $#prefix || !$trail_nonprefix, 'PrefixChains'];
}
}
warn "... PrefixChains from(to1,to2) <$F>: ", join '|', map {$_ . '(' . join(',', sort keys %{$KK{$_}}) . ')'} sort keys %KK if keys %KK;
for my $K (sort keys %KK) {
my $KK = $self->key2hex($K);
die "Key `$KK=$K' in PrefixChain for font=`$F' is not a prefix" unless my $KF = $H->{'[deadkeyFace]'}{$KK};
my $new_facename = "$F*==>*Chain*$KK";
my $LL = $H->{'[deadkeyLayers]'}{$KK};
warn " patch_face 1" if debug_stacking_ord;
$self->patch_face($LL, $new_facename, undef, "chain-in-$KK", $KK{$K}, $F, !'invert');
$H->{'[deadkeyFace]'}{$KK} = $new_facename;
$H->{'[deadkeyLayers]'}{$KK} = $self->{faces}{$new_facename}{layers};
$self->coverage_face0($new_facename, 'after import');
}
}
$self
}
sub link_composite_layers ($) { # as above, but finish
my ($self, %h, $expl) = (shift);
my @F = grep m(^faces(/.*)?$), @{$self->{'[keys]'}};
for my $FF (@F) {
(my $F = $FF) =~ s(^faces/?)();
my(@FF, @HH) = split m(/), $FF;
next if @FF == 1 or $FF[-1] eq 'VK';
push(@HH, $self->get_deep($self, @FF)), pop @FF while @FF;
my $H = $HH[0];
for my $new_facename (sort values %{$H->{'[deadkeyFace]'}}) {
#warn "Joining <$F>, <$new_facename>";
$self->link_layers($F, $new_facename, 'skipfix', 'no-slot-warn');
}
}
$self
}
sub create_inverted_faces ($) {
my ($self) = (shift);
#Dumpvalue->new()->dumpValue($self);
for my $F (sort keys %{$self->{faces} }) {
next if 'HASH' ne ref $self->{faces}{$F} or $F =~ /\bVK$/; # "parent" taking keys for a child
my $H = $self->{faces}{$F};
next unless $H->{'[deadkeyLayers]'}; # Are we in a no-nonsense Face-hash with defined deadkeys?
my $expl = $H->{'[Explicit_AltGr_Invert]'} || [];
$expl = [], warn "Odd number of elements of Explicit_AltGr_Invert in face $F, ignore" if @$expl % 2;
$expl = {map $self->charhex2key($_), @$expl};
#warn "Face: <", join( '> <', %$H), ">";
my $layerL = @{ $self->{layers}{ $H->{layers}[0] } }; # number of keys in the face (in the principal layer)
for my $KK (sort keys %{$H->{'[deadkeyLayers]'}}) { # Create AltGr-inverted face if there is at least one key in the AltGr face:
my $LL = $H->{'[deadkeyLayers]'}{$KK};
# To check that a key is defined, we do not care about whether a shift-state is encoded as a string, or as an array:
next unless defined $H->{'[first_auto_dead]'} and grep defined, map $self->flatten_arrays($_), map $self->{layers}{$_}, @$LL[1..$#$LL];
$H->{'[deadkeyInvAltGrKey]'}{''} = $self->next_auto_dead($H) unless exists $H->{'[deadkeyInvAltGrKey]'}{''}; # Prefix key for principal invertred face
my $auto_chr = $H->{'[deadkeyInvAltGrKey]'}{$KK} =
((exists $expl->{$self->charhex2key($KK)}) ? $expl->{$self->charhex2key($KK)} : $self->next_auto_dead($H));
$H->{'[deadkeyFaceInvAltGr]'}{$auto_chr} = "$F##Inv#$KK";
$self->{faces}{ $H->{'[deadkeyFace]'}{$KK} }{'[invAltGr_Accessor]'} = $auto_chr;
}
next unless defined (my $flip_AltGr = $H->{'[Flip_AltGr_Key]'});
$flip_AltGr = $self->charhex2key($flip_AltGr);
$H->{'[deadkeyFaceInvAltGr]'}{ $H->{'[deadkeyInvAltGrKey]'}{''} } = "$F##Inv#" if exists $H->{'[deadkeyInvAltGrKey]'}{''};
my ($prev, %chain) = '';
for my $k ( @{ $H->{chainAltGr} || [] }) {
my $K = $self->charhex2key($k);
my $KK = $self->key2hex($K);
warn("Deadkey ` $K ' of face $F has no associated AltGr-inverted face"), next
unless exists $H->{'[deadkeyInvAltGrKey]'}{$KK};
$chain{$prev} = $H->{'[deadkeyInvAltGrKey]'}{$KK};
#warn "chain `$prev' --> `$K' => $H->{'[deadkeyInvAltGrKey]'}{$KK}";
# $H->{'[dead2_AltGr_chain]'}{(length $prev) ? $self->key2hex($prev) : ''}++;
$prev = $K;
}
$H->{'[have_AltGr_chain]'} = 1 if length $prev;
for my $KK (sort keys %{$H->{'[deadkeyInvAltGrKey]'}}) { # Now know which deadkeys take inversion, and via what prefix
my $new = $self->create_inverted_face($F, $KK, \%chain, $flip_AltGr);
$self->coverage_face0($new);
}
# We do not link the AltGr-inverted faces to the "parent" faces here. Currently, it should be done when
# outputting a kbd description...
}
$self
}
sub massage_flat_maps_extra_keys ($) {
my $self = shift;
my @F = grep m(^faces(/.*)?$), @{$self->{'[keys]'}};
my (@Fok, @Fok0, @Fnok);
for my $FF (@F) {
(my $F = $FF) =~ s(^faces/?)();
my(@FF, @HH, @FokF) = split m(/), $FF;
next if @FF == 1 or $FF[-1] eq 'VK';
push @Fok, $F; # Assumed base faces
my($H) = $self->get_deep($self, @FF);
my $Cov = $H->{'[coverageExtraInclPrefix]'};
## warn join ',', sort keys %$Cov;
for my $inv ('', 'Inv') {
for my $dead (sort keys %{$H->{"[FlatPrefixMap$inv]"}}) {
my($sk, @c) = ('');
for my $cHex (sort keys %{$H->{"[FlatPrefixMap$inv]"}{$dead}}) {
my $chr = $self->charhex2key($cHex);
my $to = $H->{"[FlatPrefixMap$inv]"}{$dead}{$cHex}; # key (documented)
my @to0 = @$to;
$to0[0] = $self->key2hex($to->[0]); # hex
$sk .= ",$cHex⇒$to0[0]", next unless $Cov->{$chr};
$H->{"[FlatPrefixMapFiltered$inv]"}{$dead}{$cHex} = \@to0;
push @c, "$cHex⇒$to0[0]";
$H->{"[FlatPrefixMapAccessibleHex]"}{$dead}{$to0[0]} = 1;
}
push @FokF, "$dead$inv⇠" . join ',', @c if @c;
push @Fnok, "$F→$dead$inv$sk" if length $sk;
}
}
push @Fok0, "\t... Flatmap $F:\t@FokF\n" if @FokF;
}
warn join '', "\tBase Faces: @Fok\n", @Fok0 if @Fok0 or @Fnok;
warn "\t... Flatmaps with no basekey: @Fnok\n" if @Fnok;
$self
}
#use Dumpvalue;
sub patch_face ($$$$$$$;$) { # flip layers paying attention to linked AltGr-inverted faces, and overrides
my ($self, $LL, $newname, $prefix, $mapId, $Map, $face, $inv, @K) = (shift, shift, shift, shift, shift, shift, shift, shift);
if (%$Map) { # Borrow from make_translated_layer_tr()
my $Tr = sub ($) { my $c = shift; defined $c or return $c; $c = $c->[0] if ref $c; my $o = $Map->{$c} ;
#warn "Tr: `$c' --> `$o'" if defined $o;
#$o
};
$Tr = $self->depth1_A_translator($Tr);
my $LLL = $self->{faces}{$face}{layers};
my $mod_name = ($inv ? 'AltGr' : '');
for my $n (0..$#$LL) { # Layer number
my $new_Name = "$face##Chain$mod_name#$n.." . $mapId;
#warn "AltGr-chaining: name=$new_Name; `$chainKey' => `$nextL'";
$self->{layers}{$new_Name} ||= [ map $Tr->($_), @{ $self->{layers}{ $LLL->[$n] } }];
push @K, $new_Name;
}
}
my @prefix = $prefix ? $prefix : ();
my @n1 = (0..$#$LL);
@n1 = map $self->flip_layer_N($_, $#$LL), @n1 if $inv;
my @invLL = @$LL[@n1];
push @prefix, \@K if @K;
if (not $mapId and $inv) { # remove unreachable stuff (as early as possible) to simplify inspection of coverage
my @oNames = @invLL; @invLL = ();
for my $li (0..$#oNames) {
my $oname = $oNames[$li];
my $nname = "$face##InvStrict$li#" . $oname;
$self->{layers}{$nname} = $self->deep_copy($self->{layers}{$oname});
push @invLL, $nname;
}
( run in 3.001 seconds using v1.01-cache-2.11-cpan-71847e10f99 )