[PATCH] Input Unicode code points with control shift u

GTK does this, and I think it’s a reasonable binding. It is a shame that
there’s no easy way to do it on the TTY.

diff -r 8139bdf8db04 lisp/ChangeLog
--- a/lisp/ChangeLog	Sun Aug 03 20:25:03 2014 +0100
+++ b/lisp/ChangeLog	Tue Aug 05 00:17:51 2014 +0100
@@ -1,3 +1,17 @@
+2014-08-05  Aidan Kehoe  <[email protected]>
+
+	* keymap.el:
+	* keymap.el (event-apply-modifiers):
+	When a character keysym has case information, apply the shift
+	modifier to it by upcasing it.
+	* keymap.el (synthesize-keysym):
+	Document this a little.
+	* keymap.el (synthesize-unicode-codepoint): New.
+	Like #'synthesize-keysym, but synthesizing a Unicode codepoint.
+	* keymap.el (function-key-map-parent): Bind control shift u to
+	synthesize a Unicode character input, as does GTK+ and as
+	specified by ISO 14755.	
+
 2014-07-14  Aidan Kehoe  <[email protected]>
 
 	* simple.el (raw-append-message):
diff -r 8139bdf8db04 lisp/keymap.el
--- a/lisp/keymap.el	Sun Aug 03 20:25:03 2014 +0100
+++ b/lisp/keymap.el	Tue Aug 05 00:17:51 2014 +0100
@@ -445,7 +445,7 @@
   "Return the next key event, with a list of modifiers applied.
 LIST describes the names of these modifier, a list of symbols.
 `function-key-map' is scanned for prefix bindings."
-  (let (events binding)
+  (let (events binding key-sequence-list-description symbol-name)
     ;; read keystrokes scanning `function-key-map'
     (while (keymapp
 	    (setq binding
@@ -465,11 +465,21 @@
 		(mapcar 'character-to-event (cdr events))))
       (setq unread-command-events (cdr events)))
     ;; add modifiers LIST to the first keystroke or event
+    (setf key-sequence-list-description
+          (aref (key-sequence-list-description (car events)) 0))
+    (if (and (member 'shift list)
+	     (symbolp (car (last key-sequence-list-description)))
+             (eql 1 (length
+                     (setq symbol-name
+                           (symbol-name
+                            (car (last key-sequence-list-description))))))
+             (not (eql (aref symbol-name 0) (upcase (aref symbol-name 0)))))
+        (setf (car (last key-sequence-list-description))
+              (intern (upcase symbol-name))
+              list (remove* 'shift list)))
     (vector
      (append list
-             (set-difference (aref (key-sequence-list-description (car events))
-                                   0)
-                             list :stable t)))))
+             (set-difference key-sequence-list-description list :stable t)))))
 
 (defun event-apply-modifier (symbol)
   "Return the next key event, with a single modifier applied.
@@ -480,6 +490,10 @@
   "Read a sequence of characters, and return the corresponding keysym.
 The characters must be ?-, or ?_, or have word syntax.  Reading is
 terminated by RET (which is discarded)."
+  ;; This has the disadvantage that only X11 keysyms (and space, backspace
+  ;; and friends, together with the trivial one-character keysyms) are
+  ;; recognised, and then only on a build with X11 support which has had an
+  ;; X11 frame open at some point.
   (let ((continuep t)
 	event char list)
     (while continuep
@@ -501,6 +515,32 @@
 	     (error "Event has no character equivalent: %s" event))))
     (vector (intern (concat "" (nreverse list))))))
 
+(defun synthesize-unicode-codepoint (ignore-prompt)
+  "Read a sequence of hexadecimal digits and return a one-char keyboard macro.
+
+The character has the Unicode code point corresponding to those hexadecimal
+digits."
+  (symbol-macrolet ((first-prompt "Unicode hex input: u"))
+    (let* ((prompt first-prompt) (integer 0)
+           (extent (make-extent (1- (length first-prompt))
+                                (length first-prompt) prompt))
+	   character digit-char-p)
+      (setf (extent-face extent) 'underline
+	    (extent-property extent 'duplicable) t)
+      (while (not (member (setq character
+				;; Discard non-enter non-hex-digit characters,
+				;; as GTK does.
+				(read-char-exclusive prompt))
+			  '(?\r ?\n)))
+        (when (setq digit-char-p (digit-char-p character 16))
+          (setq integer (logior (lsh integer 4) digit-char-p)
+                prompt (concat prompt (list character)))
+          (if (>= integer #x110000)
+              (error 'args-out-of-range "Not a Unicode code point" integer))
+          (set-extent-endpoints extent (1- (length first-prompt))
+                                (length prompt) prompt)))
+      (vector (list (decode-char 'ucs integer))))))
+
 (define-key function-key-map-parent [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?s] 'event-apply-super-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?m] 'event-apply-meta-modifier)
@@ -508,6 +548,7 @@
 (define-key function-key-map-parent [?\C-x ?@ ?c] 'event-apply-control-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?a] 'event-apply-alt-modifier)
 (define-key function-key-map-parent [?\C-x ?@ ?k] 'synthesize-keysym)
+(define-key function-key-map-parent [(control U)] 'synthesize-unicode-codepoint)
 
 ;; The autoloads for the compose map, and their bindings in
 ;; function-key-map-parent are used by GTK as well as X11. And Julian


-- 
‘Liston operated so fast that he once accidentally amputated an assistant’s 
fingers along with a patient’s leg, […] The patient and the assistant both 
died of sepsis, and a spectator reportedly died of shock, resulting in the 
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)

_______________________________________________
XEmacs-Patches mailing list
[email protected]
http://lists.xemacs.org/mailman/listinfo/xemacs-patches