Commit 0f5642c2 authored by Kim F. Storm's avatar Kim F. Storm
Browse files

(key-sequence): Rework widget to read key binding

using `kbd' syntax.  Use C-q to insert literal key, event, or code.
(widget-key-sequence-default-value): Default value for empty sequence.
(widget-key-sequence-map): New map for reading key binding.  Bind C-q.
(widget-key-sequence-read-event): New command for C-q.
(widget-key-sequence-validate, widget-key-sequence-value-to-internal)
(widget-key-sequence-value-to-external): New functions.
parent 6df19241
......@@ -3161,28 +3161,83 @@ It reads a directory name from an editable text field."
(widget-apply widget :notify widget event)
;;; I'm not sure about what this is good for? KFS.
(defvar widget-key-sequence-prompt-value-history nil
"History of input to `widget-key-sequence-prompt-value'.")
;; This mostly works, but I am pretty sure it needs more change
;; to be 100% correct. I don't know what the change should be -- rms.
(defvar widget-key-sequence-default-value [ignore]
"Default value for an empty key sequence.")
(defvar widget-key-sequence-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map widget-field-keymap)
(define-key map [(control ?q)] 'widget-key-sequence-read-event)
(define-widget 'key-sequence 'restricted-sexp
"A Lisp function."
"A key sequence."
:prompt-value 'widget-field-prompt-value
:prompt-internal 'widget-symbol-prompt-internal
:prompt-match 'fboundp
; :prompt-match 'fboundp ;; What was this good for? KFS
:prompt-history 'widget-key-sequence-prompt-value-history
:action 'widget-field-action
:match-alternatives '(stringp vectorp)
:validate (lambda (widget)
(unless (or (stringp (widget-value widget))
(vectorp (widget-value widget)))
(widget-put widget :error (format "Invalid key sequence: %S"
(widget-value widget)))
:value 'ignore
:format "%{%t%}: %v"
:validate 'widget-key-sequence-validate
:value-to-internal 'widget-key-sequence-value-to-internal
:value-to-external 'widget-key-sequence-value-to-external
:value widget-key-sequence-default-value
:keymap widget-key-sequence-map
:help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value"
:tag "Key sequence")
(defun widget-key-sequence-read-event (ev)
(interactive (list
(let ((inhibit-quit t) quit-flag)
(read-event "Insert KEY, EVENT, or CODE: "))))
(let ((ev2 (and (memq 'down (event-modifiers ev))
(tr (and (keymapp function-key-map)
(lookup-key function-key-map (vector ev)))))
(when (and (integerp ev)
(or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix))))
(and (<= ?a (downcase ev))
(< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix))))))
(setq unread-command-events (cons ev unread-command-events)
ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix))
tr nil)
(if (and (integerp ev) (not (char-valid-p ev)))
(insert (char-to-string ev)))) ;; throw invalid char error
(setq ev (key-description (list ev)))
(when (arrayp tr)
(setq tr (key-description (list (aref tr 0))))
(if (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr))
(setq ev tr ev2 nil)))
(insert (if (= (char-before) ?\s) "" " ") ev " ")
(if ev2
(insert (key-description (list ev2)) " "))))
(defun widget-key-sequence-validate (widget)
(unless (or (stringp (widget-value widget))
(vectorp (widget-value widget)))
(widget-put widget :error (format "Invalid key sequence: %S"
(widget-value widget)))
(defun widget-key-sequence-value-to-internal (widget value)
(if (widget-apply widget :match value)
(if (equal value widget-key-sequence-default-value)
(key-description value))
(defun widget-key-sequence-value-to-external (widget value)
(if (stringp value)
(if (string-match "\\`[[:space:]]*\\'" value)
(read-kbd-macro value))
(define-widget 'sexp 'editable-field
"An arbitrary Lisp expression."
2006-01-04 Kim F. Storm <>
* .gdbinit: Undo last change. Instead, look at Vsystem_type to
determine which breakpoints to set.
2006-01-03 Stefan Monnier <>
* keymap.c (describe_map_compare): Yet another int/Lisp_Object mixup.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment