"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/modify-keys.pl" (24 Nov 2022, 47597 Bytes) of package /linux/misc/xterm-379.tgz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "modify-keys.pl" see the
Fossies "Dox" file reference documentation and the last
Fossies "Diffs" side-by-side code changes report:
376_vs_377.
1 #!/usr/bin/env perl
2 # $XTermId: modify-keys.pl,v 1.92 2022/11/24 12:43:26 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2019-2020,2022 by Thomas E. Dickey
7 #
8 # All Rights Reserved
9 #
10 # Permission is hereby granted, free of charge, to any person obtaining a
11 # copy of this software and associated documentation files (the
12 # "Software"), to deal in the Software without restriction, including
13 # without limitation the rights to use, copy, modify, merge, publish,
14 # distribute, sublicense, and/or sell copies of the Software, and to
15 # permit persons to whom the Software is furnished to do so, subject to
16 # the following conditions:
17 #
18 # The above copyright notice and this permission notice shall be included
19 # in all copies or substantial portions of the Software.
20 #
21 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
22 # OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24 # IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
25 # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26 # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27 # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
28 #
29 # Except as contained in this notice, the name(s) of the above copyright
30 # holders shall not be used in advertising or otherwise to promote the
31 # sale, use or other dealings in this Software without prior written
32 # authorization.
33 # -----------------------------------------------------------------------------
34 # Print a table to illustrate the modifyOtherKeys resource choices.
35 #
36 # Some of the key combinations are unavailable unless certain translations
37 # resource settings are suppressed. This command helped to verify those:
38 # xterm -xrm '*omitTranslation:fullscreen,scroll-lock,shift-fonts'
39 #
40 # Additionally, a test-script was written to exercise xterm when the
41 # "Allow SendEvents" feature is enabled, in combination with keys sent by
42 # commands like this:
43 # xdotool key --window XXX shift 2>/dev/null
44 #
45 # A curses application running in the target xterm showed the received data
46 # in the terminfo-style format used in this script.
47
48 # TODO factor in the backspace/delete meta/alt/escape resource-settings
49 # TODO show keycodes via "xmodmap -pk" as alternative to xkbcomp
50 # TODO show different sort-order (code, sym, xkb)
51 # TODO use U+xxxx codepoints in keysymdef.h for rendering plain text
52 # TODO optionally show 2**N, e.g., 4 (shift+control), 8 (shift+alt+control) or 16 (+meta) modifiers
53 # TODO optionally show -c (cursor) -e (edit) -f (function-keys) with modifiers
54
55 use strict;
56 use warnings;
57
58 use Getopt::Std;
59
60 $| = 1;
61
62 our ( $opt_d, $opt_h, $opt_k, $opt_K, $opt_l, $opt_m, $opt_o, $opt_u, $opt_v );
63
64 our $REPORT;
65 our @headers;
66 our @nolinks = ();
67 our ( $xkb_layout, $xkb_model );
68 our $keyfile = "/usr/include/X11/keysymdef.h";
69
70 our @keyNames; # xkb's notion of key-names (undocumented)
71 our %keySyms; # all keysyms, hashed by name
72 our %keyCodes; # all keysyms, hashed by keycode
73 our %uniCodes; # keysym Unicode values, hashed by keycode
74 our %uniNames; # keysym Unicode descriptions, hashed by keycode
75 our @keyTypes; # XkbKeyTypeRec
76 our @symCache; # keysyms defined in keysymdef.h which might be used
77 our @symMap; # index into symCache from keyNames
78 our %keysUsed; # report derived from @symMap, etc.
79 our %linkUsed; # check for uniqueness of html anchor-names
80
81 our $MAXMODS = 8; # maximum for modifier-param
82 our %Shifted; # map keycode to shifted-keycode seen by xterm
83
84 # imitate /usr/include/X11/X.h
85 our $ShiftMask = 1;
86 our $LockMask = 2;
87 our $ControlMask = 4;
88 our $AltMask = 8; # assume mod1=alt
89 our $MetaMask = 16; # assume mod2=meta
90
91 our %editKeys = qw(
92 XK_Delete 1
93 XK_Prior 1
94 XK_Next 1
95 XK_Insert 1
96 XK_Find 1
97 XK_Select 1
98 XK_KP_Delete 1
99 XK_KP_Insert 1
100 XK_ISO_Left_Tab 1
101 );
102
103 sub failed($) {
104 printf STDERR "%s\n", $_[0];
105 exit 1;
106 }
107
108 # prefer hex with 4 digit for hash keys
109 sub toCode($) {
110 my $value = shift;
111 $value = sprintf( "0x%04x", $value ) if ( $value =~ /^\d+$/ );
112 return $value;
113 }
114
115 sub codeOf($) {
116 my $value = shift;
117 my $result = 0;
118 &failed("missing keysym") unless ( defined $value );
119 if ( $value =~ /^\d+$/ ) {
120 $result = $value;
121 }
122 elsif ( $value =~ /^0x[[:xdigit:]]+$/i ) {
123 $result = hex $value;
124 }
125 elsif ( $value =~ /^XK_/ ) {
126 $result = hex $keySyms{$value};
127 }
128 else {
129 &failed("not a keysym: $value");
130 }
131 return $result;
132 }
133
134 # macros from <X11/Xutil.h>
135
136 sub IsKeypadKey($) {
137 my $code = &codeOf( $_[0] );
138 my $result = ( ( $code >= &codeOf("XK_KP_Space") )
139 and ( $code <= &codeOf("XK_KP_Equal") ) ) ? 1 : 0;
140 return $result;
141 }
142
143 sub IsPrivateKeypadKey($) {
144 my $code = &codeOf( $_[0] );
145 my $result =
146 ( ( $code >= 0x11000000 ) and ( $code <= 0x1100FFFF ) ) ? 1 : 0;
147 return $result;
148 }
149
150 sub IsCursorKey($) {
151 my $code = &codeOf( $_[0] );
152 my $result =
153 ( ( $code >= &codeOf("XK_Home") ) and ( $code < &codeOf("XK_Select") ) )
154 ? 1
155 : 0;
156 return $result;
157 }
158
159 sub IsPFKey($) {
160 my $code = &codeOf( $_[0] );
161 my $result =
162 ( ( $code >= &codeOf("XK_KP_F1") ) and ( $code <= &codeOf("XK_KP_F4") ) )
163 ? 1
164 : 0;
165 return $result;
166 }
167
168 sub IsFunctionKey($) {
169 my $code = &codeOf( $_[0] );
170 my $result =
171 ( ( $code >= &codeOf("XK_F1") ) and ( $code <= &codeOf("XK_F35") ) )
172 ? 1
173 : 0;
174 return $result;
175 }
176
177 sub IsMiscFunctionKey($) {
178 my $code = &codeOf( $_[0] );
179 my $result =
180 ( ( $code >= &codeOf("XK_Select") ) and ( $code <= &codeOf("XK_Break") ) )
181 ? 1
182 : 0;
183 return $result;
184 }
185
186 sub IsModifierKey($) {
187 my $code = &codeOf( $_[0] );
188 my $result = (
189 (
190 ( $code >= &codeOf("XK_Shift_L") )
191 and ( $code <= &codeOf("XK_Hyper_R") )
192 )
193 or ( ( $code >= &codeOf("XK_ISO_Lock") )
194 and ( $code <= &codeOf("XK_ISO_Level5_Lock") ) )
195 or ( $code == &codeOf("XK_Mode_switch") )
196 or ( $code == &codeOf("XK_Num_Lock") )
197 ) ? 1 : 0;
198 return $result;
199 }
200
201 # debugging/reporting
202
203 # Xutil.h's macros do not cover the whole range of special keys, which are not
204 # actually printable.
205 sub IsSpecialKey($) {
206 my $code = &codeOf( $_[0] );
207 my $result =
208 ( ( $code >= 0xff00 ) and ( $code <= 0xffff ) )
209 ? 1
210 : 0;
211 return $result;
212 }
213
214 sub VisibleChar($) {
215 my $ch = shift;
216 my $ord = ord $ch;
217 my $result = $ch;
218 if ( $ord < 32 ) {
219 if ( $ord == 8 ) {
220 $result = '\b';
221 }
222 elsif ( $ord == 9 ) {
223 $result = '\t';
224 }
225 elsif ( $ord == 10 ) {
226 $result = '\n';
227 }
228 elsif ( $ord == 12 ) {
229 $result = '\f';
230 }
231 elsif ( $ord == 13 ) {
232 $result = '\r';
233 }
234 elsif ( $ord == 27 ) {
235 $result = '\E';
236 }
237 else {
238 $result = sprintf( "^%c", $ord + 64 );
239 }
240 }
241 elsif ( $ord == 32 ) {
242 $result = '\s';
243 }
244 elsif ( $ord == 94 ) {
245 $result = '\^';
246 }
247 elsif ( $ord == 92 ) {
248 $result = '\\\\';
249 }
250 elsif ( $ord == 127 ) {
251 $result = '^?';
252 }
253 return $result;
254 }
255
256 sub IsShift($$) {
257 my $code = shift;
258 my $state = shift; # 0/1=normal, 2=shift
259 my $result = 0;
260 if ( ( ( $state - 1 ) & 1 ) != 0 ) {
261 if ( $Shifted{$code} ) {
262 return 1 if ( $Shifted{$code} ne $code );
263 }
264 }
265 return 0;
266 }
267
268 sub TypeOf($) {
269 my $code = &toCode( $_[0] );
270 my $result = "other";
271 $result = "special" if ( &IsSpecialKey($code) );
272 $result = "keypad" if ( &IsKeypadKey($code) );
273 $result = "*keypad" if ( &IsPrivateKeypadKey($code) );
274 $result = "cursor" if ( &IsCursorKey($code) );
275 $result = "pf-key" if ( &IsPFKey($code) );
276 $result = "func-key" if ( &IsFunctionKey($code) );
277 $result = "misc-key" if ( &IsMiscFunctionKey($code) );
278 $result = "edit-key" if ( &IsEditFunctionKey($code) );
279 $result = "modifier" if ( &IsModifierKey($code) );
280 return $result;
281 }
282
283 sub KeyToS($$) {
284 my $code = &codeOf( $_[0] );
285 my $state = $_[1];
286 my $result = "";
287
288 $code = &codeOf( $Shifted{ $_[0] } ) if ( &IsShift( $_[0], $state ) );
289 my $type = &TypeOf( &toCode($code) );
290
291 if ( $type ne "other" ) {
292 $result = ( $type eq "special" ) ? "-ignore-" : "?";
293 }
294 elsif ($opt_u) {
295 $result = sprintf( "\\E[%d;%du", $code, $state );
296 }
297 else {
298 $result = sprintf( "\\E[27;%d;%d~", $state, $code );
299 }
300 return $result;
301 }
302
303 sub ParamToQ($) {
304 my $param = shift;
305 my $result = shift;
306 $param--;
307 $result .= ( $param & 1 ) ? 's' : '-';
308 $result .= ( $param & 2 ) ? 'a' : '-';
309 $result .= ( $param & 4 ) ? 'c' : '-';
310 $result .= ( $param & 8 ) ? 'm' : '-';
311 return $result;
312 }
313
314 sub ParamToS($) {
315 my $param = shift;
316 my $result = "";
317 if ( $param-- > 1 ) {
318 $result .= "+Shift" if ( $param & 1 );
319 $result .= "+Alt" if ( $param & 2 );
320 $result .= "+Ctrl" if ( $param & 4 );
321 $result .= "+Meta" if ( $param & 8 );
322 $result =~ s/^\+//;
323 }
324 return $result;
325 }
326
327 sub StateToS($) {
328 my $state = shift;
329 my $result = "";
330 $result .= "+Shift" if ( $state & $ShiftMask );
331 $result .= "+Lock" if ( $state & $LockMask );
332 $result .= "+Ctrl" if ( $state & $ControlMask );
333 $result .= "+Alt" if ( $state & $AltMask );
334 $result .= "+Meta" if ( $state & $MetaMask );
335 $result =~ s/^\+//;
336 return $result;
337 }
338
339 # macros/functions in xterm's input.c
340
341 sub Masked($$) {
342 my $value = shift;
343 my $mask = shift;
344 my $result = ( ($value) & ( ~($mask) ) );
345 return $result;
346 }
347
348 sub IsPredefinedKey($) {
349 my $code = &codeOf( $_[0] );
350 my $result = 0;
351 if ( $keySyms{"XK_ISO_Lock"} ) {
352 $result =
353 ( $code >= &codeOf("XK_ISO_Lock") and $code <= &codeOf("XK_Delete") )
354 ? 1
355 : 0;
356 }
357 else {
358 $result =
359 ( $code >= &codeOf("XK_BackSpace") and $code <= &codeOf("XK_Delete") )
360 ? 1
361 : 0;
362 }
363 return $result;
364 }
365
366 sub IsTabKey($) {
367 my $code = &codeOf( $_[0] );
368 my $result = 0;
369 if ( $keySyms{"XK_ISO_Left_Tab"} ) {
370 $result =
371 ( $code == &codeOf("XK_Tab") || $code == &codeOf("XK_ISO_Left_Tab") );
372 }
373 else {
374 $result = ( $code == &codeOf("XK_Tab") ) ? 1 : 0;
375 }
376 return $result;
377 }
378
379 sub IsEditFunctionKey($) {
380 my $code = shift;
381 my $result = 0;
382 if ( $keyCodes{$code} ) {
383 my $name = $keyCodes{$code};
384 $result = 1 if ( $editKeys{$name} );
385 }
386 return $result;
387 }
388
389 sub IS_CTRL($) {
390 my $code = &codeOf( $_[0] );
391 my $result = ( $code < 32 || ( $code >= 0x7f && $code <= 0x9f ) );
392 return $result;
393 }
394
395 sub IsControlInput($) {
396 my $code = &codeOf( $_[0] );
397 my $result = 0;
398 $result = 1 if ( $code >= 0x40 && $code <= 0x7f );
399 return $result;
400 }
401
402 sub IsControlOutput($) {
403 my $code = shift;
404 my $result = 0;
405 $result = 1 if &IS_CTRL($code);
406 return $result;
407 }
408
409 sub IsControlAlias($$) {
410 my $code = shift;
411 my $state = shift;
412 my $result = 0;
413
414 $code = &toCode($code);
415 $code = &toCode( &AliasedKey($code) );
416 if ( hex $code < 256 ) {
417 $result = &IS_CTRL($code);
418
419 # In xterm, this function does not directly test evt_state, but relies
420 # upon kd.strbuf converted by Xutf8LookupString or XmbLookupString
421 # (ultimately in _XTranslateKeysym).
422 #
423 # See https://www.mail-archive.com/xorg@lists.x.org/msg04434.html
424 #
425 # xterm does its own special cases for XK_BackSpace
426 if ( $state & $ControlMask ) {
427 my $ch = chr &codeOf($code);
428 $result = 1 if ( &IsTabKey($code) );
429 $result = 1 if ( &IsControlInput($code) );
430 $result = 1 if ( $ch =~ /^[\/ 2-8]$/ );
431 }
432 }
433 return $result;
434 }
435
436 sub computeMaskedModifier($$) {
437 my $state = shift;
438 my $mask = shift;
439 my $result = &xtermStateToParam( &Masked( $state, $mask ) );
440 return $result;
441 }
442
443 sub xtermStateToParam($) {
444 my $state = shift;
445 my $modify_parm = 1;
446
447 $modify_parm += 1 if ( $state & $ShiftMask );
448 $modify_parm += 2 if ( $state & $AltMask );
449 $modify_parm += 4 if ( $state & $ControlMask );
450 $modify_parm += 8 if ( $state & $MetaMask );
451 $modify_parm = 0 if ( $modify_parm == 1 );
452 return $modify_parm;
453 }
454
455 sub ParamToState($) {
456 my $modify_parm = shift;
457 my $state = 0;
458 $modify_parm-- if ( $modify_parm > 0 );
459 $state |= $ShiftMask if ( $modify_parm & 1 );
460 $state |= $AltMask if ( $modify_parm & 2 );
461 $state |= $ControlMask if ( $modify_parm & 4 );
462 $state |= $MetaMask if ( $modify_parm & 8 );
463 return $state;
464 }
465
466 sub allowedCharModifiers($$) {
467 my $other_key = shift;
468 my $state = shift;
469 my $code = shift;
470 my $result = $state & ( $ShiftMask | $AltMask | $ControlMask | $MetaMask );
471
472 # If modifyOtherKeys is off or medium (0 or 1), moderate its effects by
473 # excluding the common cases for modifiers.
474 if ( $other_key <= 1 ) {
475 my $sym = $keyCodes{$code};
476 if ( &IsControlInput($code)
477 and &Masked( $result, $ControlMask ) == 0 )
478 {
479 # These keys are already associated with the control-key
480 if ( $other_key == 0 ) {
481 $result &= ~$ControlMask;
482 }
483 }
484 elsif ( $sym eq "XK_Tab" || $sym eq "XK_Return" ) {
485 #
486 }
487 elsif ( &IsControlAlias( $code, $state ) ) {
488
489 # Things like "^_" work here...
490 if ( &Masked( $result, ( $ControlMask | $ShiftMask ) ) == 0 ) {
491 if ( $sym =~ /^XK_[34578]$/ or $sym eq "XK_slash" ) {
492 $result = 0 if ( $state == $ControlMask );
493 }
494 else {
495 $result = 0;
496 }
497 }
498 }
499 elsif ( !&IsControlOutput($code) && !&IsPredefinedKey($code) ) {
500
501 # Printable keys are already associated with the shift-key
502 if ( !( $result & $ControlMask ) ) {
503 $result &= ~$ShiftMask;
504 }
505 }
506
507 # TODO:
508 # result = filterAltMeta(result,
509 # xw->work.meta_mods,
510 # TScreenOf(xw)->meta_sends_esc, kd);
511 # if (TScreenOf(xw)->alt_is_not_meta) {
512 # result = filterAltMeta(result,
513 # xw->work.alt_mods,
514 # TScreenOf(xw)->alt_sends_esc, kd);
515 # }
516 }
517 return $result;
518 }
519
520 # Some details are omitted (e.g., the backspace/delete toggle), but this gives
521 # the general sense of the corresponding function in xterm's input.c
522 sub ModifyOtherKeys($$$$) {
523 my $code = shift; # the keycode to test
524 my $other_key = shift; # "modifyOtherKeys" resource
525 my $modify_parm = shift; # 0=unmodified, 2=shift, etc
526 my $state = shift; # mask of modifiers, e.g., ControlMask
527 my $result = 0;
528
529 $modify_parm = 0 if ( $modify_parm == 1 );
530
531 if ( &IsModifierKey($code) ) {
532
533 # xterm filters out bare modifiers (ignore)
534 }
535 elsif (&IsFunctionKey($code)
536 or &IsEditFunctionKey($code)
537 or &IsKeypadKey($code)
538 or &IsCursorKey($code)
539 or &IsPFKey($code)
540 or &IsMiscFunctionKey($code)
541 or &IsPrivateKeypadKey($code) )
542 {
543 # Exclude the keys already covered by a modifier.
544 }
545 elsif ( $state > 0 ) {
546 my $sym = "";
547 $sym = $keyCodes{$code} if ( $keyCodes{$code} );
548
549 # TODO:
550 #if (IsBackarrowToggle(keyboard, kd->keysym, state)) {
551 # kd->keysym = XK_Delete;
552 # UIntClr(state, ControlMask);
553 #}
554 if ( !&IsPredefinedKey($code) ) {
555 $state = &allowedCharModifiers( $other_key, $state, $code );
556 }
557 if ( $state != 0 ) {
558 if ( $other_key == 1 ) {
559 if ( $sym eq "XK_BackSpace"
560 or $sym eq "XK_Delete" )
561 {
562 }
563 elsif ( $sym eq "XK_ISO_Left_Tab" ) {
564 $result = 1
565 if ( &computeMaskedModifier( $state, $ShiftMask ) );
566 }
567 elsif ($sym eq "XK_Return"
568 or $sym eq "XK_Tab" )
569 {
570 $result = ( $modify_parm != 0 );
571 }
572 else {
573 if ( &IsControlInput($code) ) {
574 if ( $state == $ControlMask or $state == $ShiftMask ) {
575 $result = 0;
576 }
577 else {
578 $result = ( $modify_parm != 0 );
579 }
580 }
581 elsif ( &IsControlAlias( $code, $state ) ) {
582 if ( $state == $ShiftMask ) {
583 $result = 0;
584 }
585 elsif ( &computeMaskedModifier( $state, $ControlMask ) )
586 {
587 $result = 1;
588 }
589 }
590 else {
591 $result = 1;
592 }
593 }
594 if ($result) { # second case in xterm's Input()
595 $result = 0
596 if ( &allowedCharModifiers( $other_key, $state, $code ) ==
597 0 );
598 }
599 }
600 elsif ( $other_key == 2 ) {
601 if ( $sym eq "XK_BackSpace" ) {
602
603 # strip ControlMask as per IsBackarrowToggle()
604 $result = 1
605 if ( &computeMaskedModifier( $state, $ControlMask ) );
606 }
607 elsif ( $sym eq "XK_Delete" ) {
608
609 $result = ( &xtermStateToParam($state) != 0 );
610 }
611 elsif ( $sym eq "XK_ISO_Left_Tab" ) {
612 $result = 1
613 if ( &computeMaskedModifier( $state, $ShiftMask ) );
614 }
615 elsif ($sym eq "XK_Escape"
616 or $sym eq "XK_Return"
617 or $sym eq "XK_Tab" )
618 {
619
620 $result = ( $modify_parm != 0 );
621 }
622 else {
623 if ( &IsControlInput($code) ) {
624 $result = 1;
625 }
626 elsif ( $state == $ShiftMask and $sym eq "XK_space" ) {
627 $result = 1;
628 }
629 elsif ( &computeMaskedModifier( $state, $ShiftMask ) ) {
630 $result = 1;
631 }
632 }
633 }
634 }
635 }
636 return $result;
637 }
638
639 # See IsControlAlias. This handles some of the special cases where the keycode
640 # seen or used by xterm is not the same as the actual keycode.
641 sub AliasedKey($) {
642 my $code = &toCode( $_[0] );
643 my $result = &codeOf($code);
644 my $sym = $keyCodes{$code};
645 if ($sym) {
646 $result = 8 if ( $sym eq "XK_BackSpace" );
647 $result = 9 if ( $sym eq "XK_Tab" );
648 $result = 13 if ( $sym eq "XK_Return" );
649 $result = 27 if ( $sym eq "XK_Escape" );
650 }
651 return $result;
652 }
653
654 # Returns a short display for shift/control/alt modifiers applied to the
655 # keycode to show which are affected by "modifyOtherKeys" at the given level in
656 # $other_key
657 sub CheckOtherKey($$) {
658 my $code = shift;
659 my $other_key = shift;
660 my $modified = 0;
661 my $result = "";
662 for my $modify_parm ( 1 .. $MAXMODS ) {
663 my $state = &ParamToState($modify_parm);
664 if ( &ModifyOtherKeys( $code, $other_key, $modify_parm, $state ) ) {
665 $modified++;
666 $result .= "*";
667 }
668 else {
669 $result .= "-";
670 }
671 }
672 return $modified ? $result : "-(skip)-";
673 }
674
675 # Use the return-string from CheckOtherKeys as a template for deciding which
676 # keys to render as escape-sequences.
677 sub ShowOtherKeys($$$) {
678 my $code = &AliasedKey( $_[0] );
679 my $mode = $_[1]; # modifyOtherKeys: 0, 1 or 2
680 my $show = $_[2];
681 my $type = &TypeOf( $_[0] );
682 my @result;
683
684 # index for $show[] can be tested with a bit-mask:
685 # 1 = shift
686 # 2 = alt
687 # 4 = ctrl
688 # 8 = meta
689 for my $c ( 0 .. length($show) - 1 ) {
690 my $rc = substr( $show, $c, 1 );
691 if ( $rc eq "*" ) {
692 $result[$c] = &KeyToS( &toCode($code), $c + 1 );
693 }
694 elsif ( $type eq "other" or ( $type eq "special" and $code < 256 ) ) {
695 my $map = $code;
696 my $tmp = &toCode($code);
697 my $chr = chr hex $tmp;
698 my $shift = ( $c & 1 );
699 my $cntrl = ( $c & 4 );
700
701 # TODO - can this be simplified using xkb groups?
702 if ( $chr =~ /^[`345678]$/ and ( $c & 4 ) != 0 ) {
703 if ($shift) {
704 $map = 30 if ( $chr eq "`" );
705 $map = ord "#" if ( $chr eq "3" );
706 $map = ord '$' if ( $chr eq "4" );
707 $map = ord "%" if ( $chr eq "5" );
708 $map = 30 if ( $chr eq "6" );
709 $map = ord "&" if ( $chr eq "7" );
710 $map = ord "*" if ( $chr eq "8" );
711 }
712 else {
713 $map = 0 if ( $chr eq "`" );
714 $map = 27 if ( $chr eq "3" );
715 $map = 28 if ( $chr eq "4" );
716 $map = 29 if ( $chr eq "5" );
717 $map = 30 if ( $chr eq "6" );
718 $map = 31 if ( $chr eq "7" );
719 $map = 127 if ( $chr eq "8" );
720 }
721 }
722 else {
723 $map = &codeOf( $Shifted{$tmp} )
724 if ( defined( $Shifted{$tmp} ) and $shift );
725 if ($cntrl) {
726 if ( $chr =~ /^[190:<=>.,+*()'&%\$#"!]$/ ) {
727
728 # ignore
729 }
730 elsif ( $chr =~ /^[2]$/ ) {
731 $map = 0;
732 }
733 elsif ( $chr =~ /^[:;]$/ ) {
734 $map = 27 if ( $mode > 0 );
735 }
736 elsif ( $chr eq '-' ) {
737 $map = 31 if ($shift);
738 }
739 elsif ( $chr eq '/' ) {
740 $map = $shift ? 127 : 31 if ( $mode == 0 );
741 $map = 31 if ( not $shift and $mode == 1 );
742 }
743 elsif ( $chr eq '?' ) {
744 $map = 127;
745 }
746 else {
747 $map = ( $code & 0x1f ) if ( $code < 128 );
748 }
749 }
750 }
751 $result[$c] = &VisibleChar( chr $map );
752 }
753 elsif ( $type eq "special" ) {
754 $result[$c] = "-ignore-";
755 }
756 else {
757 $result[$c] = sprintf( "%d:%s", $c + 1, $type );
758 }
759 }
760 return @result;
761 }
762
763 sub readfile($) {
764 my $data = shift;
765 my @data;
766 if ( open my $fp, $data ) {
767 @data = <$fp>;
768 close $fp;
769 chomp @data;
770 }
771 return @data;
772 }
773
774 sub readpipe($) {
775 my $cmd = shift;
776 return &readfile("$cmd 2>/dev/null |");
777 }
778
779 sub trim($) {
780 my $text = shift;
781 $text =~ s/^\s+//;
782 $text =~ s/\s+$//;
783 $text =~ s/\s+/ /g;
784 return $text;
785 }
786
787 sub html_ref($) {
788 my $header = shift;
789 my $anchor = lc &trim($header);
790 $anchor =~ s/\s/_/g;
791 return $anchor;
792 }
793
794 sub rightarrow() {
795 return $opt_h ? "→" : "->";
796 }
797
798 sub safe_html($) {
799 my $text = shift;
800 if ($opt_h) {
801 $text =~ s/\&/\&/g;
802 $text =~ s/\</\</g;
803 $text =~ s/\</\>/g;
804 if ( length($text) == 1 ) {
805 my $s = "";
806 for my $n ( 0 .. length($text) - 1 ) {
807 my $ch = substr( $text, $n, 1 );
808 my $ord = ord($ch);
809 $s .= sprintf( "&#%d;", $ord ) if ( $ord >= 128 );
810 $s .= $ch if ( $ord < 128 );
811 }
812 $text = $s;
813 }
814 }
815 return $text;
816 }
817
818 sub begin_report() {
819 if ($opt_o) {
820 open( $REPORT, '>', $opt_o ) or &failed("cannot open $opt_o");
821 select $REPORT;
822 }
823 if ($opt_h) {
824 printf <<EOF
825 <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN">
826
827 <html>
828 <head>
829 <meta name="generator" content="$0">
830
831 <title>XTERM - Modified "Other" Keys ($xkb_layout-$xkb_model)</title>
832 <meta http-equiv="Content-Type" content="text/html; charset=utf-8">
833 <meta name="keywords" content="xterm, special keys">
834 <meta name="description" content="This is an example of xterm's modifyOtherKeys feature">
835 </head>
836
837 <body>
838 EOF
839 ;
840 }
841 }
842
843 sub end_report() {
844 if ($opt_h) {
845 my $output = "output.html";
846 $output = $opt_o if ($opt_o);
847 printf <<EOF
848 <div class="nav">
849 <ul>
850 <li class="nav-top"><a href="$output">(top)</a></li>
851 EOF
852 ;
853 for my $h ( 0 .. $#headers ) {
854 printf "<li><a href=\"#%s\">%s</a></li>\n",
855 &html_ref( $headers[$h] ), $headers[$h];
856 }
857 printf <<EOF
858 </ul>
859 </div>
860 EOF
861 ;
862 }
863 if ($opt_o) {
864 select STDOUT;
865 close $REPORT;
866 }
867 }
868
869 sub begin_section($) {
870 my $header = shift;
871 $headers[ $#headers + 1 ] = $header;
872 if ($opt_h) {
873 printf "<h2><a name=\"%s\">%s</a></h2>\n", &html_ref($header), $header;
874 }
875 else {
876 printf "\n";
877 printf "%s:\n", $header;
878 }
879 printf STDERR "** %s\n", $header if ($opt_o);
880 }
881
882 sub begin_table() {
883 my $title = shift;
884 &begin_section($title);
885 if ($opt_h) {
886 printf "<table border=\"1\" summary=\"$title\">\n";
887 }
888 }
889
890 sub end_table() {
891 if ($opt_h) {
892 printf "</table>\n";
893 }
894 }
895
896 sub tt_cell($) {
897 my $text = shift;
898 return sprintf "<tt>%s</tt>", $text;
899 }
900
901 sub td_any($) {
902 my $text = shift;
903 return sprintf "<td>%s</td>", &tt_cell($text);
904 }
905
906 sub td_left($) {
907 my $text = shift;
908 return sprintf "<td align=\"left\">%s</td>", &tt_cell($text);
909 }
910
911 sub td_right($) {
912 my $text = shift;
913 return sprintf "<td align=\"right\">%s</td>", &tt_cell($text);
914 }
915
916 sub padded($$) {
917 my $size = shift;
918 my $text = shift;
919 $text = sprintf( "%*s", $size, $text ) if ( $size > 0 );
920 $text = sprintf( "%-*s", $size, $text ) if ( $size < 0 );
921 $text =~ s/ / /g if ($opt_h);
922 return $text;
923 }
924
925 sub print_head() {
926 my $argc = $#_;
927 if ($opt_h) {
928 printf "<tr>";
929 for ( my $n = 0 ; $n <= $argc ; $n += 2 ) {
930 my $size = $_[$n];
931 my $text = &padded( $size, $_[ $n + 1 ] );
932 printf "<th>%s</th>", $text;
933 }
934 printf "</tr>\n";
935 }
936 else {
937 for ( my $n = 0 ; $n <= $argc ; $n += 2 ) {
938 my $size = $_[$n];
939 my $text = &padded( $size, $_[ $n + 1 ] );
940 printf "%s", $text;
941 printf " " if ( $n < $argc );
942 }
943 printf "\n";
944 }
945 }
946
947 sub link_data($$) {
948 my $thisis = shift;
949 my $thatis = shift;
950 my $column = shift;
951 my $symbol = shift;
952 my %result;
953 $result{THISIS} = $thisis; # current table name
954 $result{THATIS} = $thatis; # name of target table for link
955 $result{COLUMN} = $column; # column counting from 0
956 $result{SYMBOL} = $symbol;
957 return \%result;
958 }
959
960 sub unique_link($$) {
961 my $thisis = shift;
962 my $symbol = shift;
963 my $unique = 0;
964 for my $n ( 0 .. length($symbol) - 1 ) {
965 $unique += ord substr( $symbol, $n, 1 );
966 }
967 return sprintf( "%s:%s.%x", $thisis, $symbol, $unique );
968 }
969
970 # print a row in the table, using pairs of lengths and strings:
971 # + Right-align lengths greater than zero and pad;
972 # + Left-align lengths less than zero, pad.
973 # + For the special case of zero, just left align without padding.
974 sub print_data() {
975 my $argc = $#_;
976 if ($opt_h) {
977 my @links = @{ $_[0] };
978 printf "<tr>";
979 my $col = 0;
980 for ( my $n = 1 ; $n <= $argc ; $n += 2 ) {
981 my $size = $_[$n];
982 my $text = &padded( $size, $_[ $n + 1 ] );
983 if ( $#links >= 0 ) {
984 for my $l ( 0 .. $#links ) {
985 my %obj = %{ $links[$l] }; # link_data
986 if ( $obj{COLUMN} == $col ) {
987 my $props = "";
988 my $value = &unique_link( $obj{THISIS}, $obj{SYMBOL} );
989
990 # The symbol-map from xkbcomp has duplicates because
991 # different modifier combinations can produce the same
992 # keysym. Since it appears that the slots that the
993 # user would expect are filled in first, just ignoring
994 # the duplicate works well enough.
995 if ( not $linkUsed{$value} ) {
996 $props .= " name=\"$value\"";
997 $linkUsed{$value} = 1;
998 }
999 $value = &unique_link( $obj{THATIS}, $obj{SYMBOL} );
1000 $props .= " href=\"#$value\"";
1001 my $tail = $text;
1002 $text =~ s/(\ )+$//;
1003 $tail = substr( $tail, length($text) );
1004 $text =
1005 sprintf( "<a %s>%s</a>%s", $props, $text, $tail );
1006 last;
1007 }
1008 }
1009 }
1010 printf "%s",
1011 ( $size > 0 ) ? &td_right($text)
1012 : ( $size == 0 ) ? &td_any($text)
1013 : &td_left($text);
1014 ++$col;
1015 }
1016 printf "</tr>\n";
1017 }
1018 else {
1019 for ( my $n = 1 ; $n <= $argc ; $n += 2 ) {
1020 my $size = $_[$n];
1021 my $text = &padded( $size, $_[ $n + 1 ] );
1022 printf "%s", $text;
1023 printf " " if ( $n < $argc );
1024 }
1025 printf "\n";
1026 }
1027 }
1028
1029 sub begin_preformatted($) {
1030 my $title = shift;
1031 &begin_section($title);
1032 printf "<pre>\n" if ($opt_h);
1033 }
1034
1035 sub end_preformatted() {
1036 printf "</pre>\n" if ($opt_h);
1037 }
1038
1039 sub do_localectl($) {
1040 my $report = shift;
1041 my $cmd = "localectl status";
1042 my @data = &readpipe($cmd);
1043 &begin_table("Output of $cmd") if ($report);
1044 for my $n ( 0 .. $#data ) {
1045
1046 # let command-line parameters override localectl output, for reports
1047 $data[$n] =~ s/^(\s+X11 Layout:\s+).*$/$1$opt_l/ if ($opt_l);
1048 $data[$n] =~ s/^(\s+X11 Model:\s+).*$/$1$opt_m/ if ($opt_m);
1049 my @fields = split /:\s*/, $data[$n];
1050 next unless ( $#fields == 1 );
1051 if ($report) {
1052 if ($opt_h) {
1053 printf "<tr>%s%s</tr>\n",
1054 &td_right( $fields[0] ),
1055 &td_left( $fields[1] );
1056 }
1057 else {
1058 printf "%s\n", $data[$n];
1059 }
1060 }
1061 $xkb_layout = $fields[1] if ( $fields[0] =~ /x11 layout/i );
1062 $xkb_model = $fields[1] if ( $fields[0] =~ /x11 model/i );
1063 }
1064 if ($report) {
1065 &end_table;
1066 }
1067 }
1068
1069 sub do_keysymdef() {
1070 my @data = &readfile($keyfile);
1071 my $lenSyms = 0;
1072 for my $n ( 0 .. $#data ) {
1073 my $value = &trim( $data[$n] );
1074 next unless ( $value =~ /^#define\s+XK_/ );
1075 my $name = $value;
1076 $name =~ s/^#define\s+//;
1077 $value = $name;
1078 $name =~ s/\s.*//;
1079 $value =~ s/^[^\s]+\s+//;
1080 my $note = $value;
1081 $value =~ s/\s.*//;
1082
1083 $note =~ s/^[^\s]+\s*//;
1084 if ( $note !~ /\b(alias|deprecated)\b/ ) {
1085
1086 if ( $note =~ /\/*.*\bU\+[[:xdigit:]]{4,8}.*\*\// ) {
1087 next if ( $note =~ /\(U\+/ );
1088 my $code = $note;
1089 $code =~ s/^.*\bU\+([[:xdigit:]]+).*/$1/;
1090 $note =~ s/^\/\*[([:space:]]*//;
1091 $note =~ s/[)[:space:]]*\*\/$//;
1092 $uniNames{$value} = $note;
1093 $uniCodes{$value} = hex $code;
1094 }
1095 }
1096 $lenSyms = length($name) if ( length($name) > $lenSyms );
1097 $value = lc $value;
1098 $keySyms{$name} = $value;
1099 $keyCodes{$value} = $name unless ( $keyCodes{$value} );
1100 printf "keySyms{$name} = '$value', keyCodes{$value} = $name\n"
1101 if ($opt_d);
1102 }
1103 my $tmpfile = $keyfile;
1104 $tmpfile =~ s/^.*\///;
1105 &begin_table("Symbols from $tmpfile");
1106 my @keys = keys %keySyms;
1107 &print_data( \@nolinks, 5, sprintf( "%d", $#keys ),
1108 0, sprintf( "keysyms are defined (longest %d)", $lenSyms ) );
1109 @keys = keys %keyCodes;
1110 &print_data( \@nolinks, 5, sprintf( "%d", $#keys ),
1111 0, "keycodes are defined" );
1112 @keys = keys %uniCodes;
1113 &print_data( \@nolinks, 5, sprintf( "%d", $#keys ),
1114 0, "keycodes are equated to Unicode" );
1115 &end_table;
1116 }
1117
1118 # For what it's worth, there is a C library (xkbfile) which could be used,
1119 # but there is no documentation and would not actually solve the problem at
1120 # hand.
1121 #
1122 # setxkbmap -model pc105 -layout us -print | xkbcomp - -C -o -
1123 sub do_xkbcomp() {
1124 my @data =
1125 &readpipe( "setxkbmap "
1126 . "-model $xkb_model "
1127 . "-layout $xkb_layout -print "
1128 . "| xkbcomp - -C -o -" );
1129 my $state = -1;
1130 my $type = {};
1131 for my $n ( 0 .. $#data ) {
1132 if ( $data[$n] =~ /static.*\bkeyNames\[.*{/ ) {
1133 $state = 0;
1134 next;
1135 }
1136 if ( $data[$n] =~ /static.*\bsymCache\[.*{/ ) {
1137 $state = 1;
1138 next;
1139 }
1140 if ( $data[$n] =~ /static.*\bsymMap\[.*{/ ) {
1141 $state = 2;
1142 next;
1143 }
1144 if ( $data[$n] =~ /static.*\bdflt_types\[.*{/ ) {
1145 $state = 3;
1146 next;
1147 }
1148 if ( $state >= 0 ) {
1149 if ( $data[$n] =~ /^\s*};/ ) {
1150 printf "# %s\n", $data[$n] if ($opt_d);
1151 $state = -1;
1152 next;
1153 }
1154 printf "* %s\n", $data[$n] if ($opt_d);
1155 }
1156
1157 # parse data in "keyNames[NUM_KEYS]"
1158 if ( $state == 0 ) {
1159 my $text = $data[$n];
1160 my $name;
1161 while ( $text =~ /^.*".*".*$/ ) {
1162 $text =~ s/^[^"]*//;
1163 $name = $text;
1164 $name =~ s/"\s+}.*//;
1165 $name =~ s/"//g;
1166 $keyNames[ $#keyNames + 1 ] = $name;
1167 printf "keyNames[%d] = '%s'\n", $#keyNames,
1168 $keyNames[$#keyNames]
1169 if ($opt_v);
1170 $text =~ s/^"[^"]*"//;
1171 }
1172 }
1173
1174 # parse data in "symCache[NUM_SYMBOLS]"
1175 elsif ( $state == 1 ) {
1176 my $text = $data[$n];
1177 my $name;
1178 while ( $text =~ /[[:alnum:]_]/ ) {
1179 $text =~ s/^[^[[:alnum:]_]*//;
1180 $name = $text;
1181 $name =~ s/[^[[:alnum:]_].*//;
1182 $symCache[ $#symCache + 1 ] = $name;
1183 printf "symCache[%d] = %s\n", $#symCache, $symCache[$#symCache]
1184 if ($opt_v);
1185 $text =~ s/^[[:alnum:]_]+//;
1186 }
1187 }
1188
1189 # parse data in "symMap[NUM_KEYS]"
1190 elsif ( $state == 2 ) {
1191 my $text = $data[$n];
1192 my $code;
1193 while ( $text =~ /[{].*[}]/ ) {
1194 my %obj;
1195 $text =~ s/^[^{]*[{]\s*//;
1196 $code = $text;
1197 $code =~ s/[^[[:alnum:]].*//;
1198 $text =~ s/[[:alnum:]]+\s*,\s*//;
1199 $obj{TYPE} = $code; # KeyType
1200 my %tmp = %{ $keyTypes[$code] };
1201 $tmp{USED} += 1;
1202 $keyTypes[$code] = \%tmp;
1203 $code = $text;
1204 $code =~ s/[^[[:alnum:]].*//;
1205 $text =~ s/[[:alnum:]]+\s*,\s*//;
1206 $obj{USED} = hex $code; # 0/1 for used/unused
1207 $code = $text;
1208 $code =~ s/[^[[:alnum:]].*//;
1209 $obj{CODE} = $code; # index in symCache[]
1210 $text =~ s/[[:alnum:]]+\s*//;
1211 $symMap[ $#symMap + 1 ] = \%obj;
1212 printf "symMap[%d] = {%d,%d,%d}\n", $#symMap, $obj{TYPE},
1213 $obj{USED}, $obj{CODE}
1214 if ($opt_v);
1215 }
1216 }
1217
1218 # parse data in "dflt_types[]"
1219 elsif ( $state == 3 ) {
1220 my $text = &trim( $data[$n] );
1221 if ( $text =~ /^\s*[}](,)?$/ ) {
1222 $type->{USED} = 0;
1223 $keyTypes[ $#keyTypes + 1 ] = $type;
1224 $type = {};
1225 }
1226 elsif ( $text =~ /^\d+,$/ ) {
1227 $text =~ s/,//;
1228 $type->{SIZE} = $text;
1229 }
1230 elsif ( $text =~ /^None,\s+lnames_[[:alnum:]_]+$/ ) {
1231 $text =~ s/^None,\s+lnames_//;
1232 $type->{NAME} = $text;
1233 }
1234 elsif ( $text =~ /^\s*[{].*[}],\s*$/ ) {
1235 $text =~ s/^\s*[{]\s*([^,]+),.*/$1/;
1236 $type->{MODS} = $text;
1237 }
1238 }
1239 }
1240 &begin_table("Summary from xkbcomp");
1241 &print_data( \@nolinks, 5, sprintf( "%d", $#keyNames + 1 ), 0, "keyNames" );
1242 &print_data( \@nolinks, 5, sprintf( "%d", $#keyTypes + 1 ), 0, "keyTypes" );
1243 &print_data( \@nolinks, 5, sprintf( "%d", $#symCache + 1 ), 0, "symCache" );
1244 &print_data( \@nolinks, 5, sprintf( "%d", $#symMap + 1 ), 0, "symMap" );
1245 &end_table;
1246 }
1247
1248 # Report keysymdef.h without the deprecated stuff, and sorted by keycode.
1249 sub report_keysymdef() {
1250 &begin_table("Key symbols");
1251 &print_head( 0, "Code", 0, "Category", 0, "Symbol" );
1252
1253 # sort by numeric keycode rather than string
1254 my @keyCodes = keys %keyCodes;
1255 my @sortCodes;
1256 for my $c ( 0 .. $#keyCodes ) {
1257 $sortCodes[$c] = sprintf "%08X", hex $keyCodes[$c];
1258 }
1259 @sortCodes = sort @sortCodes;
1260 for my $c ( 0 .. $#sortCodes ) {
1261 my $code = sprintf( "0x%04x", hex $sortCodes[$c] );
1262 my $sym = $keyCodes{$code};
1263 &print_data( \@nolinks, 9, $code, -8, &TypeOf($code), 0, $sym );
1264 }
1265 &end_table;
1266 }
1267
1268 sub report_key_types() {
1269 &begin_table("Key types");
1270 &print_head( 5, "Type", 5, "Used", 5, "Levels", 0, "Name" );
1271 for my $t ( 0 .. $#keyTypes ) {
1272 my %type = %{ $keyTypes[$t] };
1273 next if ( $type{USED} == 0 and not $opt_v );
1274 &print_data(
1275 \@nolinks, 5, sprintf( "%d", $t ), 5,
1276 sprintf( "%d", $type{USED} ), 5, sprintf( "%d", $type{SIZE} ), 0,
1277 $type{NAME}
1278 );
1279 }
1280 &end_table;
1281 }
1282
1283 sub report_modified_keys() {
1284 my @codes = sort keys %keysUsed;
1285 my $width = 14;
1286 &begin_table("Other modifiable keycodes");
1287 &print_head(
1288 0, "Code", 0, "Symbol", 0, "Actual",
1289 -$width, "Mode 0", -$width, "Mode 1", -$width, "Mode 2"
1290 );
1291 $width = 0 if ($opt_h);
1292 for my $c ( 0 .. $#codes ) {
1293 next unless ( $codes[$c] ne "" );
1294 my @links;
1295 my $sym = $keysUsed{ $codes[$c] };
1296 $links[0] = &link_data( "summary", "detailed", 1, $sym );
1297 &print_data(
1298 \@links,
1299 6, $codes[$c], #
1300 -20, $keysUsed{ $codes[$c] }, #
1301 -6, sprintf( "%d", hex $codes[$c] ), #
1302 -$width, &CheckOtherKey( $codes[$c], 0 ), #
1303 -$width, &CheckOtherKey( $codes[$c], 1 ), #
1304 -$width, &CheckOtherKey( $codes[$c], 2 )
1305 );
1306 }
1307 &end_table;
1308 &begin_preformatted("Modify-param to/from state");
1309 for my $param ( 0 .. $MAXMODS ) {
1310 my $state = &ParamToState($param);
1311 my $check = &xtermStateToParam($state);
1312 printf " PARAM %d %s %d %s %d (%s)\n", $param, &rightarrow, #
1313 $state, &rightarrow, #
1314 $check, &ParamToS($param);
1315 }
1316 &end_preformatted;
1317 &begin_preformatted("State to/from modify-param");
1318 for my $state ( 0 .. 15 ) {
1319 my $param = &xtermStateToParam($state);
1320 my $check = &ParamToState($param);
1321 printf " STATE %d %s %d %s %d (%s)\n", #
1322 $state, &rightarrow, #
1323 $param, &rightarrow, #
1324 $check, &StateToS($state);
1325 }
1326 &end_preformatted;
1327 }
1328
1329 # Make a report showing user- and program-modes.
1330 sub report_otherkey_escapes() {
1331 my @codes = sort keys %keysUsed;
1332 my $width = 14;
1333 &begin_table("Other modified-key escapes");
1334 &print_head(
1335 0, "Code", 0, "Symbol", 0, "Actual",
1336 -$width, "Mode 0", -$width, "Mode 1", -$width, "Mode 2"
1337 );
1338 $width = 0 if ($opt_h);
1339 for my $c ( 0 .. $#codes ) {
1340 next unless ( $codes[$c] ne "" );
1341 my $level0 = &CheckOtherKey( $codes[$c], 0 );
1342 my $level1 = &CheckOtherKey( $codes[$c], 1 );
1343 my $level2 = &CheckOtherKey( $codes[$c], 2 );
1344 my @level0 = &ShowOtherKeys( $codes[$c], 0, $level0 );
1345 my @level1 = &ShowOtherKeys( $codes[$c], 1, $level1 );
1346 my @level2 = &ShowOtherKeys( $codes[$c], 2, $level2 );
1347 my @links;
1348 my $sym = $keysUsed{ $codes[$c] };
1349 $links[0] = &link_data( "detailed", "symmap", 1, $sym );
1350 &print_data(
1351 \@links, #
1352 -6, $codes[$c], #
1353 -20, $keysUsed{ $codes[$c] }, #
1354 -6, sprintf( "%d", hex $codes[$c] ), #
1355 -$width, $level0, #
1356 -$width, $level1, #
1357 -$width, $level2
1358 );
1359
1360 for my $r ( 0 .. $#level0 ) {
1361 &print_data(
1362 \@nolinks, #
1363 -6, &ParamToQ( $r + 1 ), #
1364 -20, "", #
1365 -6, "", #
1366 -$width, &safe_html( $level0[$r] ), #
1367 -$width, &safe_html( $level1[$r] ), #
1368 -$width, &safe_html( $level2[$r] )
1369 );
1370 }
1371 }
1372 &end_table;
1373 }
1374
1375 sub report_keys_used() {
1376 &begin_table("Key map");
1377 &print_head(
1378 5, "Type", #
1379 0, "Level", #
1380 0, "Name", #
1381 6, "Code", #
1382 0,
1383 "Symbol"
1384 );
1385 for my $m ( 0 .. $#symMap ) {
1386 my %obj = %{ $symMap[$m] };
1387 next unless ( $obj{USED} );
1388 my $sym = $symCache[ $obj{CODE} ];
1389 next if ( $sym eq "NoSymbol" );
1390 my $code = "";
1391 $code = $keySyms{$sym} if ( $keySyms{$sym} );
1392 next if ( $code eq "" );
1393 $keysUsed{$code} = $sym;
1394 my %type = %{ $keyTypes[ $obj{TYPE} ] };
1395 my @links;
1396 $links[0] = &link_data( "symmap", "summary", 4, $sym );
1397 &print_data(
1398 \@links,
1399 5, sprintf( "%d", $obj{TYPE} ), #
1400 5, sprintf( "1/%d", $type{SIZE} ), #
1401 -4, $keyNames[$m], #
1402 6, $code, #
1403 0, $sym
1404 );
1405
1406 my $base = $code;
1407 $Shifted{$code} = $code unless ( $Shifted{$code} );
1408
1409 for my $t ( 1 .. $type{SIZE} - 1 ) {
1410 $sym = $symCache[ $obj{CODE} + $t ];
1411 if ( $keySyms{$sym} ) {
1412 $code = $keySyms{$sym};
1413 $keysUsed{$code} = $sym;
1414 $links[0] = &link_data( "symmap", "summary", 4, $sym );
1415 }
1416 else {
1417 $code = "";
1418 @links = ();
1419 }
1420 &print_data(
1421 \@links,
1422 5, "", #
1423 5, sprintf( "%d/%d", $t + 1, $type{SIZE} ), #
1424 -4, "", #
1425 6, $code, #
1426 0, $sym
1427 );
1428 @links = ();
1429
1430 # The shift-modifier could be used in custom groups, but the only
1431 # built-in ones that appear relevant are TWO_LEVEL and ALPHABETIC,
1432 # which have two levels. This records the shifted code for a given
1433 # base.
1434 if ( $type{SIZE} == 2
1435 and $type{MODS}
1436 and index( $type{MODS}, "ShiftMask" ) >= 0 )
1437 {
1438 if ( $t == 1 ) {
1439 $Shifted{$base} = $code;
1440 }
1441 elsif ( not $Shifted{$code} ) {
1442 $Shifted{$code} = $code;
1443 }
1444 }
1445 }
1446 }
1447 &end_table;
1448 }
1449
1450 sub KeyClasses($) {
1451 my $hex = shift;
1452 my $alias = &IsControlAlias( $hex, $ControlMask ) ? "alias" : "";
1453 my $cntrl = &IS_CTRL($hex) ? "cntrl" : "";
1454 my $ctl_i = &IsControlInput($hex) ? "ctl_i" : "";
1455 my $ctl_o = &IsControlOutput($hex) ? "ctl_o" : "";
1456 my $this = sprintf( "%-5s %-5s %-5s %-5s %-8s",
1457 $alias, $cntrl, $ctl_i, $ctl_o, &TypeOf($hex) );
1458 }
1459
1460 sub report_key_classes() {
1461 &begin_table("Keycode-classes");
1462 my $base = -1;
1463 my $last = "";
1464 my $next = 65535;
1465 my $form = " [%8s .. %-8s] %s\n";
1466 &print_head( 0, "First", 0, "Last", 0, "Classes" ) if ($opt_h);
1467 for my $code ( 0 .. $next ) {
1468 my $hex = &toCode($code);
1469 my $this = &KeyClasses($hex);
1470 if ( $base < 0 ) {
1471 $base = 0;
1472 $last = $this;
1473 }
1474 elsif ( $this ne $last ) {
1475 printf $form, &toCode($base), &toCode( $code - 1 ), $last
1476 unless ($opt_h);
1477 &print_data( \@nolinks, 0, &toCode($base), 0, &toCode( $code - 1 ),
1478 0, $last )
1479 if ($opt_h);
1480 $base = $code;
1481 $last = $this;
1482 }
1483 }
1484 printf $form, &toCode($base), &toCode($next), $last unless ($opt_h);
1485 &print_data( \@nolinks, 0, &toCode($base), 0, &toCode($next), 0, $last )
1486 if ($opt_h);
1487 &end_table;
1488 }
1489
1490 sub main::HELP_MESSAGE() {
1491 printf STDERR <<EOF
1492 Usage: $0 [options]
1493
1494 Options:
1495 -d debug
1496 -h write report with html-markup
1497 -k dump keysyms/keycodes from $keyfile
1498 -K dump keycode-classes
1499 -l XXX use XXX for Xkb layout (default $xkb_layout)
1500 -m XXX use XXX for Xkb model (default $xkb_model)
1501 -o XXX write report to the file XXX.
1502 -u use CSI u format for escapes
1503 -v verbose
1504
1505 EOF
1506 ;
1507 exit 1;
1508 }
1509
1510 binmode( STDOUT, ":utf8" );
1511
1512 &do_localectl(0);
1513
1514 $Getopt::Std::STANDARD_HELP_VERSION = 1;
1515 &getopts('dhKkl:m:o:uv') || &main::HELP_MESSAGE;
1516 $opt_v = 1 if ($opt_d);
1517
1518 &begin_report;
1519
1520 &do_localectl(1);
1521
1522 $xkb_layout = $opt_l if ($opt_l);
1523 $xkb_model = $opt_m if ($opt_m);
1524
1525 &do_keysymdef;
1526 &report_keysymdef if ($opt_k);
1527
1528 &do_xkbcomp;
1529
1530 &report_key_classes if ($opt_K);
1531
1532 &report_key_types;
1533 &report_keys_used;
1534 &report_modified_keys;
1535 &report_otherkey_escapes;
1536
1537 &end_report;
1538
1539 1;