From 6ae7b50f0b4400934a85eaaa45190d9e1c6f11d4 Mon Sep 17 00:00:00 2001
From: layer <layer>
Date: Wed, 6 Jun 2007 17:15:06 +0000
Subject: [PATCH] 2007-05-16  Andreas Fuchs  <afuchs@franz.com>

---
 ChangeLog.n              |  9 ++++++-
 tk-silica/xt-silica.lisp | 57 +++++++++++++++++++++++++++++++++++-----
 xlib/xlib-funs.lisp      |  8 +++++-
 3 files changed, 66 insertions(+), 8 deletions(-)

diff --git a/ChangeLog.n b/ChangeLog.n
index 4b57e57c..96bde7c0 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -1,3 +1,10 @@
+2007-05-16  Andreas Fuchs  <afuchs@franz.com>
+
+	* xlib/xlib-funs.lisp: new function xkeycodetokeysym
+        * tk-silica/xt-silica.lisp: find out the meta/super/hyper mod
+          bits from the X server, then use the bit masks in
+          state->modifiers.
+
 2007-05-17    <layer@HOBART>
 
 	* aclpc/acl-class.lisp: bug17020: clim process browser in win64
@@ -6178,4 +6185,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile
 	Lots of other stuff
 
 *******************************************************************************
-$Revision: 2.34 $
+$Revision: 2.35 $
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index de2f1b44..c29521cd 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-silica.lisp,v 2.9 2007/04/17 21:45:54 layer Exp $
+;; $Id: xt-silica.lisp,v 2.10 2007/06/06 17:15:06 layer Exp $
 
 (in-package :xm-silica)
 
@@ -87,7 +87,6 @@
 		(make-instance 'tk::gcontext :drawable pixmap))
 	    (tk::destroy-pixmap pixmap))))))
 
-
 (defmethod restart-port ((port xt-port))
   (let ((process (port-process port)))
     (when process
@@ -99,7 +98,9 @@
 	     :priority 1000)
        #'port-event-loop port))
     (setf (getf (mp:process-property-list process) :no-interrupts) t)
-    (setf (port-process port) process)))
+    (setf (port-process port) process))
+    ;; Find out the modifier->modbit mapping on the display.
+    (setup-modifier-key-mapping port))
 
 (defparameter *use-color* t)		; For debugging monochrome
 
@@ -1430,15 +1431,59 @@ setup."
       character
     (excl::old-code-char (char-code character) bits)))
 
+(defvar +super-modifier-mask+ 0)
+(defvar +hyper-modifier-mask+ 0)
+(defvar +meta-modifier-mask+ 0)
+
+(defun setup-modifier-key-mapping (port)
+  (let* ((display (slot-value port 'tk-silica::display))
+         (modifier-map (x11:xgetmodifiermapping display))
+         (mods (x11:xmodifierkeymap-modifiermap modifier-map))
+         (max-keypermod (x11:xmodifierkeymap-max-keypermod modifier-map))
+         (skip-modbits 3)     ; assuming that shift, lock, control are
+                              ; always bound to sane values.
+         )
+    (labels ((translate-key (key &aux keysym)
+               (loop for index from 0 below max-keypermod
+                     do (setf keysym (x11:xkeycodetokeysym display key index))
+                     while (zerop keysym)
+                     
+                     finally  (return keysym))))
+      (unwind-protect
+          ;; "The modifiermap member of the XModifierKeymap structure
+          ;; contains 8 sets of max_keypermod KeyCodes" -- XGetModifierMap(3X11)
+          (loop for i from skip-modbits to 8
+                for mod-keyword in `(,x11:mod1mask ,x11:mod2mask ,x11:mod3mask
+                                         ,x11:mod4mask ,x11:mod5mask)
+                do (loop for j from 0 below max-keypermod
+                         for key = (sys:memref-int mods
+                                                   (+ (* i max-keypermod) j)
+                                       0 :unsigned-byte)
+                         unless (zerop key)
+                           do (case (translate-key key)
+                                ((#.x11:XK-Meta-L #.x11:XK-Meta-R)
+                                 (setf +meta-modifier-mask+ mod-keyword))
+                                ((#.x11:XK-Super-L #.x11:XK-Super-R)
+                                 (setf +super-modifier-mask+ mod-keyword))
+                                ((#.x11:XK-Hyper-L #.x11:XK-Hyper-R)
+                                 (setf +hyper-modifier-mask+ mod-keyword)))))
+        (x11:xfreemodifiermap modifier-map)))
+    (values +meta-modifier-mask+ +super-modifier-mask+ +hyper-modifier-mask+)))
+
 (defun state->modifiers (x)
   (declare (optimize (speed 3) (safety 0))
 	   (fixnum x))
+  ;; 2007-05-09/asf This is not entirely optimal yet: In recent linux
+  ;; distributions (Ubuntu, specifically), Hyper and Super cause the
+  ;; same modifier bit to be set on x events. Maybe it would be better
+  ;; to observe the press/release events of modifier keys (this could
+  ;; also enable sticky ESC to be Meta, the way emacs has it).
   (logior
    (if (logtest x x11:shiftmask) +shift-key+ 0)
    (if (logtest x x11:controlmask) +control-key+ 0)
-   (if (logtest x x11:mod1mask) +meta-key+ 0)
-   (if (logtest x x11:mod2mask) +super-key+ 0)
-   (if (logtest x x11:mod3mask) +hyper-key+ 0)))
+   (if (logtest x +meta-modifier-mask+) +meta-key+ 0)
+   (if (logtest x +super-modifier-mask+) +super-key+ 0)
+   (if (logtest x +hyper-modifier-mask+) +hyper-key+ 0)))
 
 (defmethod get-application-resources ((port xt-port))
   (multiple-value-bind (names classes)
diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp
index a04a9584..80e64f7f 100644
--- a/xlib/xlib-funs.lisp
+++ b/xlib/xlib-funs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xlib-funs.lisp,v 2.8 2007/04/17 21:45:54 layer Exp $
+;; $Id: xlib-funs.lisp,v 2.9 2007/06/06 17:15:06 layer Exp $
 
 ;;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
@@ -1382,6 +1382,12 @@
    (keysyms (:pointer keysym))
    (nkeycodes int))
 
+(def-exported-foreign-function (xkeycodetokeysym (:return-type int)
+                                                 (:name "XKeycodeToKeysym"))
+   (dpy (:pointer display))
+   (keycode int)
+   (index int))
+
 (def-exported-foreign-function (xsetselectionowner (:name "XSetSelectionOwner"))
    (dpy (:pointer display))
    (selection :unsigned-32bit)
-- 
GitLab