view release on metacpan or  search on metacpan

lib/UI/KeyboardLayout.pm  view on Meta::CPAN

our $VERSION;
$VERSION = "0.7901";

binmode $DB::OUT, ':utf8' if $DB::OUT;		# (older) Perls had "Wide char in Print" in debugger otherwise
binmode $DB::LINEINFO, ':utf8' if $DB::LINEINFO;		# (older) Perls had "Wide char in Print" in debugger otherwise

use strict;
use utf8;
BEGIN { my $n = ($ENV{UI_KEYBOARDLAYOUT_DEBUG} || 0); 
	if ($n =~ /^0x/i) {
	  $n = hex $n;
	} else {
	  $n += 0;
	}
	eval "sub debug() { $n }";
	#		1			2			4		8		0x10	0x20
	my @dbg = (qw( debug_face_layout_recipes debug_GUESS_MASSAGE debug_OPERATOR debug_import debug_stacking debug_noid ),
	#		0x40			0x80		0x100	0x200		0x400		0x800		0x1000
		   qw(warnSORTEDLISTS printSORTEDLISTS warnSORTCOMPOSE warnDO_COMPOSE warnCACHECOMP dontCOMPOSE_CACHE warnUNRES),
	#		0x2000			0x4000		 0x8000		0x10000
		   qw(debug_STACKING	printSkippedComposeKey	warnReached  debug_stacking_ord),
		   '_debug_PERL_dollar1_scoping');
	my $c = 0;		# printSORTEDLISTS: Dumpvalue to STDOUT (implementation detail!)
	my @dbg_b = map $n & (1<<$_), 0..31;
	for (@dbg) {
	  eval "sub $_ () {$dbg_b[$c++]}";
	}
}
sub debug_PERL_dollar1_scoping ()		 { debug & 0x1000000 }

my $ctrl_after = 1;	# In "pairs of nonShift/Shift-columns" (1 simplifies output of BACK/ESCAPE/RETURN/CANCEL)
my $create_alpha_ctrl = 2;	# Separate Ctrl and Ctrl-Shift ???
my %start_SEC = (FKEYS => [96, 24, sub { my($self,$u,$v)=@_; 'F' . (1+$u-$v->[0]) }],
		 ARROWS => [128, 16,
		 	    sub { my($self,$u,$v)=@_;
		 	          (qw(HOME UP PRIOR DIVIDE LEFT CLEAR RIGHT MULTIPLY END DOWN NEXT SUBTRACT INSERT DELETE RETURN ADD))[$u-$v->[0]]}],
		 NUMPAD => [144, 16,
		 	    sub { my($self,$u,$v)=@_;
		 	          ((map { ($_ > 10 ? 'F' : "NUMPAD") . $_} 7..9,14,4..6,15,1..3,16,0), 'DECIMAL')[$u-$v->[0]]}]);
my $LAST_SEC = -1e100;
$LAST_SEC < $_->[0] + $_->[1] and $LAST_SEC = $_->[0] + $_->[1] for values %start_SEC;

my $maxEntityLen = 111;		# Avoid overflow of prefix char above 0fff in kbdutool (but now can channel them to smaller values)
my $avoid_overlong_synonims_Entity = 20;	# These two are currently disabled

sub toU($) { substr+(qq(\x{fff}).shift),1 }	# Some bullshit one must do to make perl's Unicode 8-bit-aware (!)

#use subs qw(chr lc);
use subs qw(chr lc uc ucfirst);

#BEGIN { *CORE::GLOGAL::chr = sub ($) { toU CORE::chr shift };
#        *CORE::GLOGAL::lc  = sub ($)  { CORE::lc  toU shift };
#}
### Remove ß ẞ :
## my %fix = qw( ԥ Ԥ ԧ Ԧ ӏ Ӏ ɀ Ɀ ꙡ Ꙡ ꞑ Ꞑ  ꞧ Ꞧ  ɋ Ɋ  ꞩ Ꞩ  ȿ Ȿ  ꞓ Ꞓ  ꞥ Ꞥ );		# Perl 5.8.8 uc is wrong with palochka, 5.10 with z with swash tail
my %fix = qw( ԥ Ԥ ԧ Ԧ ӏ Ӏ ɀ Ɀ ꙡ Ꙡ ꞑ Ꞑ  ꞧ Ꞧ  ɋ Ɋ  ß ẞ  ꞩ Ꞩ  ȿ Ȿ  ꞓ Ꞓ  ꞥ Ꞥ  ℊ Ɡ  ϳ Ϳ );		# Perl 5.8.8 uc is wrong with palochka, 5.10 with z with swash tail
my %unfix = reverse %fix;

sub chr($)  { local $^W = 0; toU CORE::chr shift }	# Avoid illegal character 0xfffe etc warnings...
sub lc($)   { my $in = shift; $unfix{$in} || CORE::lc toU $in }
sub uc($)   { my $in = shift;   $fix{$in} || CORE::uc toU $in }
sub ucfirst($)   { my $in = shift;   $fix{$in} || CORE::ucfirst toU $in }

# We use this for printing, not for reading (so we can use //o AFTER the UCD is read)
my $rxCombining = qr/\p{NonspacingMark}/;	# The initial version matches what Perl knows
my $rxZW = qr/\p{Line_Break: ZW}|[\xAD\x{200b}-\x{200f}\x{2060}-\x{2064}\x{fe00}-\x{fe0f}]/;

sub rxCombining { $rxCombining }

=pod

=encoding UTF-8

=head1 NAME

UI::KeyboardLayout - Module for designing keyboard layouts

=head1 SYNOPSIS

  #!/usr/bin/perl -wC31
  use UI::KeyboardLayout; 
  use strict;

  # Download from http://www.unicode.org/Public/UNIDATA/
  UI::KeyboardLayout::->set_NamesList("$ENV{HOME}/Downloads/NamesList.txt"); 

  UI::KeyboardLayout::->set__value('ComposeFiles',	# CygWin too
				  ['/usr/share/X11/locale/en_US.UTF-8/Compose']);
  # http://cgit.freedesktop.org/xorg/proto/xproto/plain/keysymdef.h
  UI::KeyboardLayout::->set__value('KeySyms',
				  ['/usr/share/X11/include/keysymdef.h']);
  UI::KeyboardLayout::->set__value('EntityFiles',
				  ["$ENV{HOME}/Downloads/bycodes.html"]);
  UI::KeyboardLayout::->set__value('rfc1345Files',
				  ["$ENV{HOME}/Downloads/rfc1345.html"]);
  
  my $i = do {local $/; open $in, '<', 'MultiUni.kbdd' or die; <$in>}; 
  # Init from in-memory copy of the configfile
  # Combines new()->parse_add_configfile()->massage_full():
  my $k = UI::KeyboardLayout:: -> new_from_configfile_string($i)
             -> fill_win_template( 1, [qw(faces CyrillicPhonetic)] ); 
  print $k;	# optional arguments 'dummy' (and possibly 'dummyname')
		# to fill_win_template() to make an 'extra-dummy' version
  
  open my $f, '<', "$ENV{HOME}/Downloads/NamesList.txt" or die;
  my $k = UI::KeyboardLayout::->new();
  my ($d,$c,$names,$blocks,$extraComb,$uniVersion) = $k->parse_NameList($f);
  close $f or die;
  $k->print_decompositions($d);
  $k->print_compositions  ($c);
  # selected print
  $l->print_compositions_ch_filter( [qw(<super> <pseudo-fake-super> <pseudo-manual-superize>)] ); 
  
  UI::KeyboardLayout::->set_NamesList("$ENV{HOME}/Downloads/NamesList.txt", 
  				      "$ENV{HOME}/Downloads/DerivedAge.txt"); 
  my $l = UI::KeyboardLayout::->new(); 
  $l->print_compositions; 
  $l->print_decompositions;

  UI::KeyboardLayout::->set_NamesList("$ENV{HOME}/Downloads/NamesList-6.1.0d8.txt", 
  				      "$ENV{HOME}/Downloads/DerivedAge-6.1.0d13.txt"));