X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0d30b33766e277a5bff6eabc9da5afdaebd8b32a..7e5d77dc2ca1d4064cba18955ab2c50766f62fa8:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 1198eff55b..fc64dd5f36 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,7 +1,7 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; ;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005 Free Software Foundation, Inc. +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -58,6 +58,8 @@ ;;; Code: +(defvar widget) + ;;; Compatibility. (defun widget-event-point (event) @@ -401,10 +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)) - ; Text terminals cannot change mouse pointer shape, so use mouse - ; face instead. - (or (display-graphic-p) - (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))) @@ -658,6 +658,14 @@ button is pressed or inactive, respectively. These are currently ignored." tag 'mouse-face widget-button-pressed-face))) (insert tag))) +(defun widget-move-and-invoke (event) + "Move to where you click, and if it is an active field, invoke it." + (interactive "e") + (mouse-set-point event) + (let ((pos (widget-event-point event))) + (if (and pos (get-char-property pos 'button)) + (widget-button-click event)))) + ;;; Buttons. (defgroup widget-button nil @@ -841,13 +849,18 @@ button end points." ;;; Keymap and Commands. +;;;###autoload +(defalias 'advertised-widget-backward 'widget-backward) + ;;;###autoload (defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\t" 'widget-forward) - (define-key map [(shift tab)] 'widget-backward) + (define-key map "\e\t" 'widget-backward) + (define-key map [(shift tab)] 'advertised-widget-backward) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) + (define-key map [down-mouse-1] 'widget-button-click) (define-key map "\C-m" 'widget-button-press) map) "Keymap containing useful binding for buffers containing widgets. @@ -903,71 +916,79 @@ Recommended as a parent keymap for modes using widgets.") "Invoke the button that the mouse is pointing at." (interactive "e") (if (widget-event-point event) - (let* ((pos (widget-event-point event)) + (let* ((oevent event) + (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1))) + (pos (widget-event-point event)) (start (event-start event)) (button (get-char-property pos 'button (and (windowp (posn-window start)) (window-buffer (posn-window start)))))) - (if button - ;; Mouse click on a widget button. Do the following - ;; in a save-excursion so that the click on the button - ;; doesn't change point. - (save-selected-window - (select-window (posn-window (event-start event))) - (save-excursion - (goto-char (posn-point (event-start event))) - (let* ((overlay (widget-get button :button-overlay)) - (face (overlay-get overlay 'face)) - (mouse-face (overlay-get overlay 'mouse-face))) - (unwind-protect - ;; Read events, including mouse-movement events - ;; until we receive a release event. Highlight/ - ;; unhighlight the button the mouse was initially - ;; on when we move over it. - (save-excursion - (when face ; avoid changing around image - (overlay-put overlay - 'face widget-button-pressed-face) - (overlay-put overlay - 'mouse-face widget-button-pressed-face)) - (unless (widget-apply button :mouse-down-action event) - (let ((track-mouse t)) - (while (not (widget-button-release-event-p event)) - (setq event (read-event) - pos (widget-event-point event)) - (if (and pos - (eq (get-char-property pos 'button) - button)) - (when face - (overlay-put overlay - 'face - widget-button-pressed-face) - (overlay-put overlay - 'mouse-face - widget-button-pressed-face)) - (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face))))) - - ;; When mouse is released over the button, run - ;; its action function. - (when (and pos - (eq (get-char-property pos 'button) button)) - (widget-apply-action button event))) - (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-face)))) - - (unless (pos-visible-in-window-p (widget-event-point event)) - (mouse-set-point event) - (beginning-of-line) - (recenter)) - ) - + (when (or (null button) + (catch 'button-press-cancelled + ;; Mouse click on a widget button. Do the following + ;; in a save-excursion so that the click on the button + ;; doesn't change point. + (save-selected-window + (select-window (posn-window (event-start event))) + (save-excursion + (goto-char (posn-point (event-start event))) + (let* ((overlay (widget-get button :button-overlay)) + (pressed-face (or (widget-get button :pressed-face) + widget-button-pressed-face)) + (face (overlay-get overlay 'face)) + (mouse-face (overlay-get overlay 'mouse-face))) + (unwind-protect + ;; Read events, including mouse-movement + ;; events, waiting for a release event. If we + ;; began with a mouse-1 event and receive a + ;; movement event, that means the user wants + ;; to perform drag-selection, so cancel the + ;; button press and do the default mouse-1 + ;; action. For mouse-2, just highlight/ + ;; unhighlight the button the mouse was + ;; initially on when we move over it. + (save-excursion + (when face ; avoid changing around image + (overlay-put overlay 'face pressed-face) + (overlay-put overlay 'mouse-face pressed-face)) + (unless (widget-apply button :mouse-down-action event) + (let ((track-mouse t)) + (while (not (widget-button-release-event-p event)) + (setq event (read-event)) + (when (and mouse-1 (mouse-movement-p event)) + (push event unread-command-events) + (setq event oevent) + (throw 'button-press-cancelled t)) + (setq pos (widget-event-point event)) + (if (and pos + (eq (get-char-property pos 'button) + button)) + (when face + (overlay-put overlay 'face pressed-face) + (overlay-put overlay 'mouse-face pressed-face)) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face))))) + + ;; When mouse is released over the button, run + ;; its action function. + (when (and pos + (eq (get-char-property pos 'button) button)) + (widget-apply-action button event))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face)))) + + ;; This loses if the widget action switches windows. -- cyd + ;; (unless (pos-visible-in-window-p (widget-event-point event)) + ;; (mouse-set-point event) + ;; (beginning-of-line) + ;; (recenter)) + ) + nil)) (let ((up t) command) ;; Mouse click not on a widget button. Find the global ;; command to run, and check whether it is bound to an ;; up event. - (mouse-set-point event) - (if (memq (event-basic-type event) '(mouse-1 down-mouse-1)) + (if mouse-1 (cond ((setq command ;down event (lookup-key widget-global-map [down-mouse-1])) (setq up nil)) @@ -1194,22 +1215,24 @@ When not inside a field, move to the previous button or field." ;; or if a special `boundary' field has been added after the widget ;; field. (if (overlayp overlay) - (if (and (not (eq (with-current-buffer - (widget-field-buffer widget) - (save-restriction - ;; `widget-narrow-to-field' can be - ;; active when this function is called - ;; from an change-functions hook. So - ;; temporarily remove field narrowing - ;; before to call `get-char-property'. - (widen) - (get-char-property (overlay-end overlay) - 'field))) - 'boundary)) - (or widget-field-add-space - (null (widget-get widget :size)))) - (1- (overlay-end overlay)) - (overlay-end overlay)) + ;; Don't proceed if overlay has been removed from buffer. + (when (overlay-buffer overlay) + (if (and (not (eq (with-current-buffer + (widget-field-buffer widget) + (save-restriction + ;; `widget-narrow-to-field' can be + ;; active when this function is called + ;; from an change-functions hook. So + ;; temporarily remove field narrowing + ;; before to call `get-char-property'. + (widen) + (get-char-property (overlay-end overlay) + 'field))) + 'boundary)) + (or widget-field-add-space + (null (widget-get widget :size)))) + (1- (overlay-end overlay)) + (overlay-end overlay))) (cdr overlay)))) (defun widget-field-find (pos) @@ -1383,6 +1406,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 @@ -1527,6 +1551,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)) @@ -1956,13 +1988,14 @@ the earlier input." (args (widget-get widget :args)) (explicit (widget-get widget :explicit-choice)) current) - (if (and explicit (equal value (widget-get widget :explicit-choice-value))) + (if explicit (progn ;; If the user specified the choice for this value, - ;; respect that choice as long as the value is the same. + ;; respect that choice. (widget-put widget :children (list (widget-create-child-value widget explicit value))) - (widget-put widget :choice explicit)) + (widget-put widget :choice explicit) + (widget-put widget :explicit-choice nil)) (while args (setq current (car args) args (cdr args)) @@ -2048,13 +2081,10 @@ when he invoked the menu." (setq this-explicit t) (widget-choose tag (reverse choices) event)))) (when current - ;; If this was an explicit user choice, - ;; record the choice, and the record the value it was made for. - ;; widget-choice-value-create will respect this choice, - ;; as long as the value is the same. + ;; If this was an explicit user choice, record the choice, + ;; so that widget-choice-value-create will respect it. (when this-explicit - (widget-put widget :explicit-choice current) - (widget-put widget :explicit-choice-value (widget-get widget :value))) + (widget-put widget :explicit-choice current)) (widget-value-set widget (widget-default-get current)) (widget-setup) (widget-apply widget :notify widget event))) @@ -2155,7 +2185,8 @@ when he invoked the menu." (when sibling (if (widget-value widget) (widget-apply sibling :activate) - (widget-apply sibling :deactivate))))) + (widget-apply sibling :deactivate)) + (widget-clear-undo)))) ;;; The `checklist' Widget. @@ -2981,7 +3012,7 @@ as the value." (define-widget 'file 'string "A file widget. -It will read a file name from the minibuffer when invoked." +It reads a file name from an editable text field." :complete-function 'widget-file-complete :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" @@ -2993,12 +3024,12 @@ It will read a file name from the minibuffer when invoked." "Perform completion on file name preceding point." (interactive) (let* ((end (point)) - (beg (save-excursion - (skip-chars-backward "^ ") - (point))) + (beg (widget-field-start widget)) (pattern (buffer-substring beg end)) (name-part (file-name-nondirectory pattern)) - (directory (file-name-directory pattern)) + ;; I think defaulting to root is right + ;; because these really should be absolute file names. + (directory (or (file-name-directory pattern) "/")) (completion (file-name-completion name-part directory))) (cond ((eq completion t)) ((null completion) @@ -3012,7 +3043,8 @@ It will read a file name from the minibuffer when invoked." (with-output-to-temp-buffer "*Completions*" (display-completion-list (sort (file-name-all-completions name-part directory) - 'string<))) + 'string<) + name-part)) (message "Making completion list...%s" "done"))))) (defun widget-file-prompt-value (widget prompt value unbound) @@ -3020,7 +3052,7 @@ It will read a file name from the minibuffer when invoked." (abbreviate-file-name (if unbound (read-file-name prompt) - (let ((prompt2 (format "%s (default %s) " prompt value)) + (let ((prompt2 (format "%s (default %s): " prompt value)) (dir (file-name-directory value)) (file (file-name-nondirectory value)) (must-match (widget-get widget :must-match))) @@ -3033,7 +3065,7 @@ It will read a file name from the minibuffer when invoked." ;;; (file (file-name-nondirectory value)) ;;; (menu-tag (widget-apply widget :menu-tag-get)) ;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ") +;;; (answer (read-file-name (concat menu-tag " (default " value "): ") ;;; dir nil must-match file))) ;;; (widget-value-set widget (abbreviate-file-name answer)) ;;; (widget-setup) @@ -3042,7 +3074,7 @@ It will read a file name from the minibuffer when invoked." ;; Fixme: use file-name-as-directory. (define-widget 'directory 'file "A directory widget. -It will read a directory name from the minibuffer when invoked." +It reads a directory name from an editable text field." :tag "Directory") (defvar widget-symbol-prompt-value-history nil @@ -3110,7 +3142,7 @@ It will read a directory name from the minibuffer when invoked." (interactive) (lisp-complete-symbol 'boundp)) :tag "Variable") - + (defvar widget-coding-system-prompt-value-history nil "History of input to `widget-coding-system-prompt-value'.") @@ -3137,10 +3169,10 @@ It will read a directory name from the minibuffer when invoked." "Read coding-system from minibuffer." (if (widget-get widget :base-only) (intern - (completing-read (format "%s (default %s) " prompt value) + (completing-read (format "%s (default %s): " prompt value) (mapcar #'list (coding-system-list t)) nil nil nil coding-system-history)) - (read-coding-system (format "%s (default %s) " prompt value) value))) + (read-coding-system (format "%s (default %s): " prompt value) value))) (defun widget-coding-system-action (widget &optional event) (let ((answer @@ -3153,6 +3185,84 @@ It will read a directory name from the minibuffer when invoked." (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'.") + +(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 key sequence." + :prompt-value 'widget-field-prompt-value + :prompt-internal 'widget-symbol-prompt-internal +; :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) + :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." :tag "Lisp expression" @@ -3546,7 +3656,7 @@ example: ;; Fixme: match (define-widget 'color 'editable-field "Choose a color name (with sample)." - :format "%t: %v (%{sample%})\n" + :format "%{%t%}: %v (%{sample%})\n" :size 10 :tag "Color" :value "black" @@ -3571,7 +3681,8 @@ example: (t (message "Making completion list...") (with-output-to-temp-buffer "*Completions*" - (display-completion-list (all-completions prefix list nil))) + (display-completion-list (all-completions prefix list nil) + prefix)) (message "Making completion list...done"))))) (defun widget-color-sample-face-get (widget)