X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/80a7a1bff5f11ce9635e7d28398d0874a68a410a..8d892d7fef218001fa8ef828db4a5a864448f950:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 8029fb3d5a..9c391ab117 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,6 +1,7 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; -;; Copyright (C) 1996,97,1999,2000,01,02,2003, 2004 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -20,8 +21,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Wishlist items (from widget.texi): @@ -89,28 +90,32 @@ :group 'widgets :group 'faces) -(defvar widget-documentation-face 'widget-documentation-face +(defvar widget-documentation-face 'widget-documentation "Face used for documentation strings in widgets. This exists as a variable so it can be set locally in certain buffers.") -(defface widget-documentation-face '((((class color) - (background dark)) - (:foreground "lime green")) - (((class color) - (background light)) - (:foreground "dark green")) - (t nil)) +(defface widget-documentation '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) "Face used for documentation text." :group 'widget-documentation :group 'widget-faces) +;; backward compatibility alias +(put 'widget-documentation-face 'face-alias 'widget-documentation) -(defvar widget-button-face 'widget-button-face +(defvar widget-button-face 'widget-button "Face used for buttons in widgets. This exists as a variable so it can be set locally in certain buffers.") -(defface widget-button-face '((t (:weight bold))) +(defface widget-button '((t (:weight bold))) "Face used for widget buttons." :group 'widget-faces) +;; backward compatibility alias +(put 'widget-button-face 'face-alias 'widget-button) (defcustom widget-mouse-face 'highlight "Face used for widget buttons when the mouse is above them." @@ -120,33 +125,37 @@ This exists as a variable so it can be set locally in certain buffers.") ;; TTY gets special definitions here and in the next defface, because ;; the gray colors defined for other displays cause black text on a black ;; background, at least on light-background TTYs. -(defface widget-field-face '((((type tty)) - :background "yellow3" - :foreground "black") - (((class grayscale color) - (background light)) - :background "gray85") - (((class grayscale color) - (background dark)) - :background "dim gray") - (t - :slant italic)) +(defface widget-field '((((type tty)) + :background "yellow3" + :foreground "black") + (((class grayscale color) + (background light)) + :background "gray85") + (((class grayscale color) + (background dark)) + :background "dim gray") + (t + :slant italic)) "Face used for editable fields." :group 'widget-faces) - -(defface widget-single-line-field-face '((((type tty)) - :background "green3" - :foreground "black") - (((class grayscale color) - (background light)) - :background "gray85") - (((class grayscale color) - (background dark)) - :background "dim gray") - (t - :slant italic)) +;; backward-compatibility alias +(put 'widget-field-face 'face-alias 'widget-field) + +(defface widget-single-line-field '((((type tty)) + :background "green3" + :foreground "black") + (((class grayscale color) + (background light)) + :background "gray85") + (((class grayscale color) + (background dark)) + :background "dim gray") + (t + :slant italic)) "Face used for editable fields spanning only a single line." :group 'widget-faces) +;; backward-compatibility alias +(put 'widget-single-line-field-face 'face-alias 'widget-single-line-field) ;;; This causes display-table to be loaded, and not usefully. ;;;(defvar widget-single-line-display-table @@ -267,7 +276,7 @@ minibuffer." (while (not (or (and (>= char ?0) (< char next-digit)) (eq value 'keyboard-quit))) ;; Unread a SPC to lead to our new menu. - (setq unread-command-events (cons ?\ unread-command-events)) + (setq unread-command-events (cons ?\s unread-command-events)) (setq keys (read-key-sequence title)) (setq value (lookup-key overriding-terminal-local-map keys t) @@ -325,8 +334,9 @@ new value.") (insert-and-inherit " "))) (setq to (point))) (let ((keymap (widget-get widget :keymap)) - (face (or (widget-get widget :value-face) 'widget-field-face)) + (face (or (widget-get widget :value-face) 'widget-field)) (help-echo (widget-get widget :help-echo)) + (follow-link (widget-get widget :follow-link)) (rear-sticky (or (not widget-field-add-space) (widget-get widget :size)))) (if (functionp help-echo) @@ -339,10 +349,13 @@ new value.") ;; one character. (let ((overlay (make-overlay (1- to) to nil t nil))) (overlay-put overlay 'field 'boundary) + ;; We need the real field for tabbing. + (overlay-put overlay 'real-field widget) ;; Use `local-map' here, not `keymap', so that normal editing ;; works in the field when, say, Custom uses `suppress-keymap'. (overlay-put overlay 'local-map keymap) (overlay-put overlay 'face face) + (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo)) (setq to (1- to)) (setq rear-sticky t)) @@ -352,6 +365,7 @@ new value.") (overlay-put overlay 'field widget) (overlay-put overlay 'local-map keymap) (overlay-put overlay 'face face) + (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo))) (widget-specify-secret widget)) @@ -364,7 +378,7 @@ new value.") (end (widget-field-end field))) (when size (while (and (> end begin) - (eq (char-after (1- end)) ?\ )) + (eq (char-after (1- end)) ?\s)) (setq end (1- end)))) (while (< begin end) (let ((old (char-after begin))) @@ -376,6 +390,7 @@ new value.") (defun widget-specify-button (widget from to) "Specify button for WIDGET between FROM and TO." (let ((overlay (make-overlay from to nil t nil)) + (follow-link (widget-get widget :follow-link)) (help-echo (widget-get widget :help-echo))) (widget-put widget :button-overlay overlay) (if (functionp help-echo) @@ -385,8 +400,13 @@ new value.") (overlay-put overlay 'evaporate t) ;; 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 '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 'pointer 'hand) + (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo))) (defun widget-mouse-help (window overlay point) @@ -422,24 +442,20 @@ new value.") (prog1 (progn ,@form) (goto-char (point-max)))))) -(defface widget-inactive-face '((((class grayscale color) - (background dark)) - (:foreground "light gray")) - (((class grayscale color) - (background light)) - (:foreground "dim gray")) - (t - (:slant italic))) +(defface widget-inactive + '((t :inherit shadow)) "Face used for inactive widgets." :group 'widget-faces) +;; backward-compatibility alias +(put 'widget-inactive-face 'face-alias 'widget-inactive) (defun widget-specify-inactive (widget from to) "Make WIDGET inactive for user modifications." (unless (widget-get widget :inactive) (let ((overlay (make-overlay from to nil t nil))) - (overlay-put overlay 'face 'widget-inactive-face) + (overlay-put overlay 'face 'widget-inactive) ;; This is disabled, as it makes the mouse cursor change shape. - ;; (overlay-put overlay 'mouse-face 'widget-inactive-face) + ;; (overlay-put overlay 'mouse-face 'widget-inactive) (overlay-put overlay 'evaporate t) (overlay-put overlay 'priority 100) (overlay-put overlay 'modification-hooks '(widget-overlay-inactive)) @@ -622,7 +638,7 @@ extension (xpm, xbm, gif, jpg, or png) located in ;; Oh well. nil))) -(defvar widget-button-pressed-face 'widget-button-pressed-face +(defvar widget-button-pressed-face 'widget-button-pressed "Face used for pressed buttons in widgets. This exists as a variable so it can be set locally in certain buffers.") @@ -781,8 +797,8 @@ The optional ARGS are additional keyword arguments." &optional button-from button-to &rest args) "Return a widget of type TYPE with endpoint FROM TO. -Optional ARGS are extra keyword arguments for TYPE. -and TO will be used as the widgets end points. If optional arguments +No text will be inserted to the buffer, instead the text between FROM +and TO will be used as the widgets end points. If optional arguments BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets button end points. Optional ARGS are extra keyword arguments for TYPE." @@ -871,13 +887,17 @@ Recommended as a parent keymap for modes using widgets.") (call-interactively (lookup-key widget-global-map (this-command-keys)))))) -(defface widget-button-pressed-face - '((((class color)) +(defface widget-button-pressed + '((((min-colors 88) (class color)) + (:foreground "red1")) + (((class color)) (:foreground "red")) (t (:weight bold :underline t))) "Face used for pressed buttons." :group 'widget-faces) +;; backward-compatibility alias +(put 'widget-button-pressed-face 'face-alias 'widget-button-pressed) (defun widget-button-click (event) "Invoke the button that the mouse is pointing at." @@ -904,14 +924,14 @@ Recommended as a parent keymap for modes using widgets.") ;; until we receive a release event. Highlight/ ;; unhighlight the button the mouse was initially ;; on when we move over it. - (let ((track-mouse t)) - (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) + (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)) @@ -926,13 +946,13 @@ Recommended as a parent keymap for modes using widgets.") 'mouse-face widget-button-pressed-face)) (overlay-put overlay 'face face) - (overlay-put overlay 'mouse-face mouse-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)))) + ;; 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)))) @@ -942,28 +962,28 @@ Recommended as a parent keymap for modes using widgets.") (recenter)) ) - (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)) - (cond ((setq command ;down event - (lookup-key widget-global-map [down-mouse-1])) - (setq up nil)) - ((setq command ;up event - (lookup-key widget-global-map [mouse-1])))) + (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)) (cond ((setq command ;down event - (lookup-key widget-global-map [down-mouse-2])) + (lookup-key widget-global-map [down-mouse-1])) (setq up nil)) ((setq command ;up event - (lookup-key widget-global-map [mouse-2]))))) - (when up - ;; Don't execute up events twice. - (while (not (widget-button-release-event-p event)) - (setq event (read-event)))) - (when command - (call-interactively command))))) + (lookup-key widget-global-map [mouse-1])))) + (cond ((setq command ;down event + (lookup-key widget-global-map [down-mouse-2])) + (setq up nil)) + ((setq command ;up event + (lookup-key widget-global-map [mouse-2]))))) + (when up + ;; Don't execute up events twice. + (while (not (widget-button-release-event-p event)) + (setq event (read-event)))) + (when command + (call-interactively command))))) (message "You clicked somewhere weird."))) (defun widget-button-press (pos &optional event) @@ -1085,14 +1105,23 @@ the field." :type 'function :group 'widgets) +(defun widget-narrow-to-field () + "Narrow to field." + (interactive) + (let ((field (widget-field-find (point)))) + (if field + (narrow-to-region (line-beginning-position) (line-end-position))))) + (defun widget-complete () "Complete content of editable field from point. When not inside a field, move to the previous button or field." (interactive) (let ((field (widget-field-find (point)))) (if field - (widget-apply field :complete) - (error "Not in an editable field")))) + (save-restriction + (widget-narrow-to-field) + (widget-apply field :complete)) + (error "Not in an editable field")))) ;;; Setting up the buffer. @@ -1140,7 +1169,7 @@ When not inside a field, move to the previous button or field." "Return the widget field at POS, or nil if none." (let ((field (get-char-property (or pos (point)) 'field))) (if (eq field 'boundary) - nil + (get-char-property (or pos (point)) 'real-field) field))) (defun widget-field-buffer (widget) @@ -1165,9 +1194,17 @@ 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 (get-char-property (overlay-end overlay) - 'field - (widget-field-buffer widget)) + (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)))) @@ -1177,7 +1214,7 @@ When not inside a field, move to the previous button or field." (defun widget-field-find (pos) "Return the field at POS. -Unlike (get-char-property POS 'field) this, works with empty fields too." +Unlike (get-char-property POS 'field), this works with empty fields too." (let ((fields widget-field-list) field found) (while fields @@ -1227,7 +1264,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." ;; Field too small. (save-excursion (goto-char end) - (insert-char ?\ (- (+ begin size) end)))) + (insert-char ?\s (- (+ begin size) end)))) ((> (- end begin) size) ;; Field too large and (if (or (< (point) (+ begin size)) @@ -1238,7 +1275,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (setq begin (point))) (save-excursion (goto-char end) - (while (and (eq (preceding-char) ?\ ) + (while (and (eq (preceding-char) ?\s) (> (point) begin)) (delete-backward-char 1))))))) (widget-specify-secret field)) @@ -1398,7 +1435,7 @@ If that does not exists, call the value of `widget-complete-field'." ((eq escape ?n) (when (widget-get widget :indent) (insert ?\n) - (insert-char ? (widget-get widget :indent)))) + (insert-char ?\s (widget-get widget :indent)))) ((eq escape ?t) (let ((image (widget-get widget :tag-glyph)) (tag (widget-get widget :tag))) @@ -1462,7 +1499,7 @@ If that does not exists, call the value of `widget-complete-field'." (when doc-text (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) ;; The `*' in the beginning is redundant. (when (eq (aref doc-text 0) ?*) (setq doc-text (substring doc-text 1))) @@ -1694,6 +1731,7 @@ If END is omitted, it defaults to the length of LIST." "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix + :follow-link "\C-m" :help-echo "Follow the link." :format "%[%t%]") @@ -1714,7 +1752,7 @@ If END is omitted, it defaults to the length of LIST." :action 'widget-url-link-action) (defun widget-url-link-action (widget &optional event) - "Open the url specified by WIDGET." + "Open the URL specified by WIDGET." (browse-url (widget-value widget))) ;;; The `function-link' Widget. @@ -1754,7 +1792,7 @@ If END is omitted, it defaults to the length of LIST." :action 'widget-emacs-library-link-action) (defun widget-emacs-library-link-action (widget &optional event) - "Find the Emacs Library file specified by WIDGET." + "Find the Emacs library file specified by WIDGET." (find-file (locate-library (widget-value widget)))) ;;; The `emacs-commentary-link' Widget. @@ -1835,7 +1873,7 @@ the earlier input." (insert value) (and size (< (length value) size) - (insert-char ?\ (- size (length value)))) + (insert-char ?\s (- size (length value)))) (unless (memq widget widget-field-list) (setq widget-field-new (cons widget widget-field-new))) (move-marker (cdr overlay) (point)) @@ -1868,7 +1906,7 @@ the earlier input." (while (and size (not (zerop size)) (> to from) - (eq (char-after (1- to)) ?\ )) + (eq (char-after (1- to)) ?\s)) (setq to (1- to))) (let ((result (buffer-substring-no-properties from to))) (when secret @@ -1918,13 +1956,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)) @@ -2010,13 +2049,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))) @@ -2149,7 +2185,7 @@ when he invoked the menu." If the item is checked, CHOSEN is a cons whose cdr is the value." (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (widget-specify-insert (let* ((children (widget-get widget :children)) (buttons (widget-get widget :buttons)) @@ -2329,7 +2365,7 @@ Return an alist of (TYPE MATCH)." ;; (setq type (widget-convert type)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (widget-specify-insert (let* ((value (widget-get widget :value)) (children (widget-get widget :children)) @@ -2507,7 +2543,7 @@ Return an alist of (TYPE MATCH)." ;; (let ((widget-push-button-gui widget-editable-list-gui)) (cond ((eq escape ?i) (and (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (apply 'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) @@ -2619,7 +2655,7 @@ Return an alist of (TYPE MATCH)." (widget-specify-insert (save-excursion (and (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (insert (widget-get widget :entry-format))) ;; Parse % escapes in format. (while (re-search-forward "%\\(.\\)" nil t) @@ -2683,7 +2719,7 @@ Return an alist of (TYPE MATCH)." value (cdr answer)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ?\ (widget-get widget :indent))) + (insert-char ?\s (widget-get widget :indent))) (push (cond ((null answer) (widget-create-child widget arg)) ((widget-get arg :inline) @@ -2822,7 +2858,7 @@ link for that string." (narrow-to-region from to) (goto-char (point-min)) (while (search-forward "\n" nil t) - (insert-char ?\ indent))))))) + (insert-char ?\s indent))))))) ;;; The `documentation-string' Widget. @@ -2842,7 +2878,7 @@ link for that string." (let ((before (substring doc 0 (match-beginning 0))) (after (substring doc (match-beginning 0))) button) - (insert before ?\ ) + (insert before ?\s) (widget-documentation-link-add widget start (point)) (setq button (widget-create-child-and-convert @@ -2856,7 +2892,7 @@ link for that string." (when shown (setq start (point)) (when (and indent (not (zerop indent))) - (insert-char ?\ indent)) + (insert-char ?\s indent)) (insert after) (widget-documentation-link-add widget start (point))) (widget-put widget :buttons (list button))) @@ -2922,7 +2958,7 @@ as the value." :match 'widget-regexp-match :validate 'widget-regexp-validate ;; Doesn't work well with terminating newline. - ;; :value-face 'widget-single-line-field-face + ;; :value-face 'widget-single-line-field :tag "Regexp") (defun widget-regexp-match (widget value) @@ -2948,7 +2984,7 @@ It will read a file name from the minibuffer when invoked." :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" ;; Doesn't work well with terminating newline. - ;; :value-face 'widget-single-line-field-face + ;; :value-face 'widget-single-line-field :tag "File") (defun widget-file-complete () @@ -3042,7 +3078,7 @@ It will read a directory name from the minibuffer when invoked." (defvar widget-function-prompt-value-history nil "History of input to `widget-function-prompt-value'.") -(define-widget 'function 'sexp +(define-widget 'function 'restricted-sexp "A Lisp function." :complete-function (lambda () (interactive) @@ -3153,6 +3189,8 @@ It will read a directory name from the minibuffer when invoked." (setq err "Empty sexp -- use `nil'?") (unless (widget-apply widget :match (read (current-buffer))) (setq err (widget-get widget :type-error)))) + ;; Allow whitespace after expression. + (skip-syntax-forward "\\s-") (if (and (not (eobp)) (not err)) (setq err (format "Junk at end of expression: %s" @@ -3555,7 +3593,7 @@ example: (widget-apply widget :notify widget event)))) (defun widget-color-notify (widget child &optional event) - "Update the sample, and notofy the parent." + "Update the sample, and notify the parent." (overlay-put (widget-get widget :sample-overlay) 'face (widget-apply widget :sample-face-get)) (widget-default-notify widget child event))