diff options
Diffstat (limited to 'lisp/wid-edit.el')
| -rw-r--r-- | lisp/wid-edit.el | 89 |
1 files changed, 77 insertions, 12 deletions
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 1f0b8e746c7..0735c467439 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -403,7 +403,8 @@ new value.") ;; We want to avoid the face with image buttons. (unless (widget-get widget :suppress-face) (overlay-put overlay 'face (widget-apply widget :button-face-get)) - (overlay-put overlay 'mouse-face widget-mouse-face)) + (overlay-put overlay 'mouse-face + (widget-apply widget :mouse-face-get))) (overlay-put overlay 'pointer 'hand) (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo))) @@ -1391,6 +1392,7 @@ The value of the :type attribute should be an unconverted widget type." :offset 0 :format-handler 'widget-default-format-handler :button-face-get 'widget-default-button-face-get + :mouse-face-get 'widget-default-mouse-face-get :sample-face-get 'widget-default-sample-face-get :delete 'widget-default-delete :copy 'identity @@ -1535,6 +1537,14 @@ If that does not exists, call the value of `widget-complete-field'." (widget-apply parent :button-face-get) widget-button-face)))) +(defun widget-default-mouse-face-get (widget) + ;; Use :mouse-face or widget-mouse-face + (or (widget-get widget :mouse-face) + (let ((parent (widget-get widget :parent))) + (if parent + (widget-apply parent :mouse-face-get) + widget-mouse-face)))) + (defun widget-default-sample-face-get (widget) ;; Use :sample-face. (widget-get widget :sample-face)) @@ -3161,28 +3171,83 @@ It reads a directory name from an editable text field." (widget-apply widget :notify widget event) (widget-setup))) +;;; 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) + map)) (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))) - 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)) + (read-event))) + (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))) + 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)) + value)) + +(defun widget-key-sequence-value-to-external (widget value) + (if (stringp value) + (if (string-match "\\`[[:space:]]*\\'" value) + widget-key-sequence-default-value + (read-kbd-macro value)) + value)) + (define-widget 'sexp 'editable-field "An arbitrary Lisp expression." |