[STUMP] patch to change from char to keysym key representation

[Matthew Kennedy]

The current key representation in stumpwm does not let you use keys
which do not map to characters (ie. #'xlib:keysym->character returns
NIL for their keysym).  Example keys that have no character mapping
are: Insert, F1-F12 etc.

The attached patch and new source file change stumpwm keys so that
they are represented by the keysym, not the character the keysym would
map to.

It has worked fine for me so far under SBCL 0.9.11 w/ CLX 0.7.2.

;; Copyright (C) 2003 Shawn Betts
;;
;;  This file is part of stumpwm.
;;
;; stumpwm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
 
;; stumpwm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
 
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA

;; Commentary:
;;
;; Mapping a keysym to a name is a client side activity in X11.  Some
;; of the code here was taken from the CMUCL Hemlocks code base.
;;
;; Code:

(in-package #:stumpwm)

(defvar *keysym-name-translations* (make-hash-table))
(defvar *name-keysym-translations* (make-hash-table :test #'equal))

(defun define-keysym (keysym name)
  (setf (gethash keysym *keysym-name-translations*) name
        (gethash name *name-keysym-translations*) keysym))

(defun name-keysym (name)
  "Return the keysym corresponding to NAME."
  (multiple-value-bind (value present-p)
      (gethash name *name-keysym-translations*)
    (declare (ignore present-p))
    value))

(defun keysym-name (keysym)
  "Return the name corresponding to KEYSYM."
  (multiple-value-bind (value present-p)
      (gethash keysym *keysym-name-translations*)
    (declare (ignore present-p))
    value))

(define-keysym 65288 "BackSpace")
(define-keysym 65289 "Tab")
(define-keysym 65290 "Linefeed")
(define-keysym 65307 "Escape")
(define-keysym 65293 "Return")
(define-keysym 65535 "Delete")
(define-keysym 32 "space")

(define-keysym 65470 "F1")
(define-keysym 65471 "F2")
(define-keysym 65472 "F3")
(define-keysym 65473 "F4")
(define-keysym 65474 "F5")
(define-keysym 65475 "F6")
(define-keysym 65476 "F7")
(define-keysym 65477 "F8")
(define-keysym 65478 "F9")
(define-keysym 65479 "F10")
(define-keysym 65480 "F11")
(define-keysym 65481 "F12")

(define-keysym 65406 "Mode_switch")

(define-keysym 65505 "Shift_L") 
(define-keysym 65506 "Shift_R")
(define-keysym 65507 "Control_L")
(define-keysym 65508 "Control_R")
(define-keysym 65509 "Caps_Lock")
(define-keysym 65510 "Shift_Lock")
(define-keysym 65511 "Meta_L")
(define-keysym 65512 "Meta_R")
(define-keysym 65513 "Alt_L")
(define-keysym 65514 "Alt_R")
(define-keysym 65515 "Super_L")
(define-keysym 65516 "Super_R")
(define-keysym 65517 "Hyper_L")
(define-keysym 65518 "Hyper_R")

(define-keysym 97 "a") (define-keysym 65 "A")
(define-keysym 98 "b") (define-keysym 66 "B")
(define-keysym 99 "c") (define-keysym 67 "C")
(define-keysym 100 "d") (define-keysym 68 "D")
(define-keysym 101 "e") (define-keysym 69 "E")
(define-keysym 102 "f") (define-keysym 70 "F")
(define-keysym 103 "g") (define-keysym 71 "G")
(define-keysym 104 "h") (define-keysym 72 "H")
(define-keysym 105 "i") (define-keysym 73 "I")
(define-keysym 106 "j") (define-keysym 74 "J")
(define-keysym 107 "k") (define-keysym 75 "K")
(define-keysym 108 "l") (define-keysym 76 "L")
(define-keysym 109 "m") (define-keysym 77 "M")
(define-keysym 110 "n") (define-keysym 78 "N")
(define-keysym 111 "o") (define-keysym 79 "O")
(define-keysym 112 "p") (define-keysym 80 "P")
(define-keysym 113 "q") (define-keysym 81 "Q")
(define-keysym 114 "r") (define-keysym 82 "R")
(define-keysym 115 "s") (define-keysym 83 "S")
(define-keysym 116 "t") (define-keysym 84 "T")
(define-keysym 117 "u") (define-keysym 85 "U")
(define-keysym 118 "v") (define-keysym 86 "V")
(define-keysym 119 "w") (define-keysym 87 "W")
(define-keysym 120 "x") (define-keysym 88 "X")
(define-keysym 121 "y") (define-keysym 89 "Y")
(define-keysym 122 "z") (define-keysym 90 "Z")

(define-keysym 49 "1") (define-keysym 33 "!")
(define-keysym 50 "2") (define-keysym 64 "@")
(define-keysym 51 "3") (define-keysym 35 "#")
(define-keysym 52 "4") (define-keysym 36 "$")
(define-keysym 53 "5") (define-keysym 37 "%")
(define-keysym 54 "6") (define-keysym 94 "^")
(define-keysym 55 "7") (define-keysym 38 "&")
(define-keysym 56 "8") (define-keysym 42 "*")
(define-keysym 57 "9") (define-keysym 40 "(")
(define-keysym 48 "0") (define-keysym 41 ")")

(define-keysym 96 "`") (define-keysym 126 "~")
(define-keysym 45 "-") (define-keysym 95 "_")
(define-keysym 61 "=") (define-keysym 43 "+")
(define-keysym 91 "[") (define-keysym 123 "{")
(define-keysym 93 "]") (define-keysym 125 "}")
(define-keysym 92 "\\") (define-keysym 124 "|")
(define-keysym 59 ";") (define-keysym 58 ":")
(define-keysym 39 "'") (define-keysym 34 "\"")
(define-keysym 44 ",") (define-keysym 60 "<")
(define-keysym 46 ".") (define-keysym 62 ">")
(define-keysym 47 "/") (define-keysym 63 "?")

? keysyms.lisp
Index: core.lisp
===================================================================
RCS file: /sources/stumpwm/stumpwm/core.lisp,v
retrieving revision 1.46
diff -u -r1.46 core.lisp
--- core.lisp   16 Apr 2006 22:12:10 -0000      1.46
+++ core.lisp   27 Apr 2006 08:08:58 -0000
@@ -303,7 +303,8 @@
 
 (defun grab-keys-on-window (win)
   (labels ((grabit (w key)
-                  (xlib:grab-key w (xlib:keysym->keycodes *display* 
(char->keysym (code-char (key-char key))))
+                  (xlib:grab-key w (xlib:keysym->keycodes *display* 
+                                                          (key-keysym key))
                                  :modifiers (x11-mods key) :owner-p t
                                  :sync-pointer-p nil :sync-keyboard-p t)))
     (maphash (lambda (k v)
@@ -1055,7 +1056,7 @@
                   :display *display*
                   :root (xlib:drawable-root win)
                   :window win
-                  :code (xlib:keysym->keycodes *display* (char->keysym 
(code-char (key-char key))))
+                  :code (xlib:keysym->keycodes *display* (key-keysym key))
                   :state (x11-mods key)))
 
 
Index: input.lisp
===================================================================
RCS file: /sources/stumpwm/stumpwm/input.lisp,v
retrieving revision 1.14
diff -u -r1.14 input.lisp
--- input.lisp  15 Apr 2006 01:36:45 -0000      1.14
+++ input.lisp  27 Apr 2006 08:08:58 -0000
@@ -29,8 +29,9 @@
 
 (defvar *input-map* 
   (let ((map (make-sparse-keymap)))
-    (define-key map (kbd (string #\Backspace)) 'input-delete-backward-char)
+    (define-key map (kbd "BackSpace") 'input-delete-backward-char)
     (define-key map (kbd "C-d") 'input-delete-forward-char)
+    (define-key map (kbd "Delete") 'input-delete-forward-char)
     (define-key map (kbd "C-f") 'input-forward-char)
     (define-key map (kbd "C-b") 'input-backward-char)
     (define-key map (kbd "C-a") 'input-move-beginning-of-line)
@@ -39,7 +40,7 @@
     (define-key map (kbd "C-u") 'input-kill-to-beginning)
     (define-key map (kbd "C-p") 'input-history-back)
     (define-key map (kbd "C-n") 'input-history-forward)
-    (define-key map (kbd (string #\Return)) 'input-submit)
+    (define-key map (kbd "Return") 'input-submit)
     (define-key map (kbd "C-g") 'input-abort)
     (define-key map t 'input-self-insert)
     map))
@@ -167,18 +168,17 @@
       (invert-rect screen win 0 0 (xlib:drawable-width win) 
(xlib:drawable-height win)))))
 
 (defun code-state->key (code state)
-  (let* ((mods (xlib:make-state-keys state))
-        (sym (xlib:keycode->keysym *display* code 0))
-        (upcase-sym (xlib:keycode->keysym *display* code 1))
-        ;; make sure there is such a keysym
-        (char (or (and sym upcase-sym
-                       (xlib:keysym->character *display* (if (find :shift 
mods) upcase-sym sym)))
-                  ;; some keysyms aren't mapped to characters (why not?)
-                  ;; so use this in that case.
-                  #\Null)))
-    (when char
-      (make-key :char (char-code char) :control (and (find :control mods) t) 
:shift (and (find :shift mods)
-                                                                               
         (eql sym upcase-sym))))))
+  (let* ((mods    (xlib:make-state-keys state))
+        (sym     (xlib:keycode->keysym *display* code 0))
+        (upsym   (xlib:keycode->keysym *display* code 1))
+        (shift-p (and (find :shift mods) t)))
+    ;; If a keysym has a shift modifier, then use the uppercase keysym
+    ;; and remove remove the shift modifier.
+    (make-key :keysym (if (and shift-p (not (eql sym upsym)))
+                         upsym
+                         sym)
+             :control (and (find :control mods) t)
+             :shift (and shift-p (eql sym upsym)))))
 
 (defun input-delete-backward-char (input key)
   (declare (ignore key))
@@ -270,14 +270,17 @@
   (throw 'abort nil))
 
 (defun input-self-insert (input key)
-  (if (key-mods-p key)
+  (let ((char (xlib:keysym->character *display* (key-keysym key))))
+    (if (or (key-mods-p key) (null char))
       :error
     (progn
       (vector-push-extend #\_ (input-line-string input))
       (replace (input-line-string input) (input-line-string input)
               :start2 (input-line-position input) :start1 (1+ 
(input-line-position input)))
-      (setf (char (input-line-string input) (input-line-position input)) 
(code-char (key-char key)))
-      (incf (input-line-position input)))))
+      (setf (char (input-line-string input) (input-line-position input))
+
+           char)
+      (incf (input-line-position input))))))
 
 (defun process-input (screen prompt input code state)
   "Process the key (code and state), given the current input
Index: kmap.lisp
===================================================================
RCS file: /sources/stumpwm/stumpwm/kmap.lisp,v
retrieving revision 1.5
diff -u -r1.5 kmap.lisp
--- kmap.lisp   15 Apr 2006 00:41:54 -0000      1.5
+++ kmap.lisp   27 Apr 2006 08:08:58 -0000
@@ -26,7 +26,7 @@
 (in-package stumpwm)
 
 (defstruct key
-  char shift control meta alt hyper super)
+  keysym shift control meta alt hyper super)
 
 (defun make-sparse-keymap ()
   (make-hash-table :test 'equalp))
@@ -80,14 +80,6 @@
                                 (#\S (list :shift t))
                                 (t (signal 'kbd-parse))))))
 
-(defun parse-char-name (string)
-  "Return the char-code of the char whose name is STRING."
-  (let ((ch (name-char string)))
-    (if ch
-       (char-code ch)
-       (and (= (length string) 1)
-            (char-code (char string 0))))))
-
 (defun parse-key (string)
   "Parse STRING and return a key structure."
   ;; FIXME: we want to return NIL when we get a kbd-parse error
@@ -95,10 +87,10 @@
     (let* ((p (when (> (length string) 2)
                (position #\- string :from-end t :end (- (length string) 1))))
           (mods (parse-mods string (if p (1+ p) 0)))
-          (ch (parse-char-name (subseq string (if p (1+ p) 0)))))
-      (and ch
-          (apply 'make-key :char ch mods))))
-  
+          (keysym (name-keysym (subseq string (if p (1+ p) 0)))))
+      (and keysym
+          (apply 'make-key :keysym keysym mods))))
+
 (defun parse-key-seq (keys)
   "KEYS is a key sequence. Parse it and return the list of keys."
   (mapcar 'parse-key (split-string keys)))
@@ -120,8 +112,9 @@
               (when (key-hyper key) "H-")))
 
 (defun print-key (key)
-  (let ((ch (code-char (key-char key))))
-    (format nil "~a~a" (print-mods key) (or (char-name ch) ch))))
+  (format nil "~a~a"
+         (print-mods key)
+         (keysym-name (key-keysym key))))
 
 (defun define-key (map key command)
   (setf (gethash key map) command))
Index: primitives.lisp
===================================================================
RCS file: /sources/stumpwm/stumpwm/primitives.lisp,v
retrieving revision 1.28
diff -u -r1.28 primitives.lisp
--- primitives.lisp     16 Apr 2006 22:04:44 -0000      1.28
+++ primitives.lisp     27 Apr 2006 08:08:58 -0000
@@ -28,7 +28,7 @@
 
 (defun char->keysym (ch)
   "Convert a char to a keysym"
-  (first (xlib:character->keysyms ch)))
+  (name-keysym (string ch)))
 
 
 ;;; Message Timer
@@ -228,21 +228,22 @@
 
 (defun is-modifier (keysym)
   "Return t if keycode is a modifier"
-  (member keysym (list (char->keysym :character-set-switch)
-                      (char->keysym :left-shift)
-                      (char->keysym :right-shift)
-                      (char->keysym :left-control)
-                      (char->keysym :right-control)
-                      (char->keysym :caps-lock)
-                      (char->keysym :shift-lock)
-                      (char->keysym :left-meta)
-                      (char->keysym :right-meta)
-                      (char->keysym :left-alt)
-                      (char->keysym :right-alt)
-                      (char->keysym :left-super)
-                      (char->keysym :right-super)
-                      (char->keysym :left-hyper)
-                      (char->keysym :right-hyper))))
+  (member keysym (mapcar #'name-keysym
+                        '("Mode_switch"
+                          "Shift_L"
+                          "Shift_R"
+                          "Control_L"
+                          "Control_R"
+                          "Caps_Lock"
+                          "Shift_Lock"
+                          "Meta_L"
+                          "Meta_R"
+                          "Alt_L"
+                          "Alt_R"
+                          "Super_L"
+                          "Super_R"
+                          "Hyper_L"
+                          "Hyper_R"))))
 
 (defun find-free-number (l)
   "Return a number that is not in the list l."
Index: stumpwm.asd
===================================================================
RCS file: /sources/stumpwm/stumpwm/stumpwm.asd,v
retrieving revision 1.7
diff -u -r1.7 stumpwm.asd
--- stumpwm.asd 15 Apr 2006 01:07:23 -0000      1.7
+++ stumpwm.asd 27 Apr 2006 08:08:58 -0000
@@ -18,12 +18,11 @@
   ;; :license "GNU General Public License"
   :description "A tiling, keyboard driven window manager" 
   :components ((:file "package")
-              (:file "primitives" :depends-on ("package"))
-              (:file "kmap" :depends-on ("primitives"))
-              (:file "input" :depends-on ("primitives" 
-                                          "kmap"))
-              (:file "core" :depends-on ("primitives"
-                                         "input"))
+              (:file "keysyms" :depends-on ("package"))
+              (:file "primitives" :depends-on ("package"))      
+              (:file "kmap" :depends-on ("primitives" "keysyms"))
+              (:file "input" :depends-on ("primitives" "keysyms" "kmap"))
+              (:file "core" :depends-on ("primitives" "input"))
               (:file "user" :depends-on ("primitives"
                                          "core"
                                          "input"))
Index: stumpwm.lisp
===================================================================
RCS file: /sources/stumpwm/stumpwm/stumpwm.lisp,v
retrieving revision 1.38
diff -u -r1.38 stumpwm.lisp
--- stumpwm.lisp        16 Apr 2006 21:37:40 -0000      1.38
+++ stumpwm.lisp        27 Apr 2006 08:08:59 -0000
@@ -120,7 +120,9 @@
         (setf *screen-list* (mapcar #'init-screen (xlib:display-roots 
*display*)))
         (xlib:access-error (c)
            (declare (ignore c))
-           (return-from stumpwm (princ "Another window manager is running."))))
+          (princ "Another window manager is running.")
+          (terpri)
+           (return-from stumpwm)))
        ;; Initialize the necessary atoms
        (init-atoms)
        (mapc 'process-existing-windows *screen-list*)
Index: user.lisp
===================================================================
RCS file: /sources/stumpwm/stumpwm/user.lisp,v
retrieving revision 1.34
diff -u -r1.34 user.lisp
--- user.lisp   16 Apr 2006 21:37:40 -0000      1.34
+++ user.lisp   27 Apr 2006 08:08:59 -0000
@@ -34,7 +34,7 @@
     (define-key m (kbd "C-e") "exec emacs")
     (define-key m (kbd "n") "next")
     (define-key m (kbd "C-n") "next")
-    (define-key m (kbd "Space") "next")
+    (define-key m (kbd "space") "next")
     (define-key m (kbd "p") "prev")
     (define-key m (kbd "C-p") "prev")
     (define-key m (kbd "w") "windows")
@@ -490,7 +490,7 @@
       (setf prefix i)
       (undefine-key *top-map* i))
     (define-key *top-map* key '*root-map*)
-    (let* ((meta (make-key :char (key-char key)))
+    (let* ((meta (make-key :keysym (key-keysym key)))
           (old-cmd (concatenate 'string "meta " (print-key prefix)))
           (cmd (concatenate 'string "meta " (print-key key))))
       (dolist (i (lookup-command *root-map* old-cmd))

Best regards,

-- 
Matthew Kennedy
Gentoo Linux Developer (Public Key 0x401903E0)