X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cfc198e540dac946e528477c421f395c56d0cc05..d6046e457f578c8494afdd0f3a7ab1282927be13:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index ba43161181..583ab54fbc 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.9945 +;; Version: 1.9951 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -34,34 +34,17 @@ (eval-when-compile (require 'cl)) ;;; Compatibility. + +(defun widget-event-point (event) + "Character position of the end of event if that exists, or nil." + (posn-point (event-end event))) + +(defalias 'widget-read-event 'read-event) (eval-and-compile (autoload 'pp-to-string "pp") (autoload 'Info-goto-node "info") - - (when (string-match "XEmacs" emacs-version) - (condition-case nil - (require 'overlay) - (error (load-library "x-overlay")))) - - (if (string-match "XEmacs" emacs-version) - (defun widget-event-point (event) - "Character position of the end of event if that exists, or nil." - (if (mouse-event-p event) - (event-point event) - nil)) - (defun widget-event-point (event) - "Character position of the end of event if that exists, or nil." - (posn-point (event-end event)))) - - (defalias 'widget-read-event (if (string-match "XEmacs" emacs-version) - 'next-event - 'read-event)) - - ;; The following should go away when bundled with Emacs. - (condition-case () - (require 'custom) - (error nil)) + (autoload 'finder-commentary "finder" nil t) (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) ;; We have the old custom-library, hack around it! @@ -82,45 +65,7 @@ (and (eventp event) (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3)) (or (memq 'click (event-modifiers event)) - (memq 'drag (event-modifiers event)))))) - - (unless (fboundp 'functionp) - ;; Missing from Emacs 19.34 and earlier. - (defun functionp (object) - "Non-nil of OBJECT is a type of object that can be called as a function." - (or (subrp object) (byte-code-function-p object) - (eq (car-safe object) 'lambda) - (and (symbolp object) (fboundp object))))) - - (unless (fboundp 'error-message-string) - ;; Emacs function missing in XEmacs. - (defun error-message-string (obj) - "Convert an error value to an error message." - (let ((buf (get-buffer-create " *error-message*"))) - (erase-buffer buf) - (display-error obj buf) - (buffer-string buf))))) - -(when (let ((a "foo")) - (put-text-property 1 2 'foo 1 a) - (put-text-property 1 2 'bar 2 a) - (set-text-properties 1 2 nil a) - (text-properties-at 1 a)) - ;; XEmacs 20.2 and earlier had a buggy set-text-properties. - (defun set-text-properties (start end props &optional buffer-or-string) - "Completely replace properties of text from START to END. -The third argument PROPS is the new property list. -The optional fourth argument, BUFFER-OR-STRING, -is the string or buffer containing the text." - (map-extents #'(lambda (extent ignored) - (remove-text-properties - start end - (list (extent-property extent 'text-prop) - nil) - buffer-or-string) - nil) - buffer-or-string start end nil nil 'text-prop) - (add-text-properties start end props buffer-or-string))) + (memq 'drag (event-modifiers event))))))) ;;; Customization. @@ -193,32 +138,22 @@ This exists as a variable so it can be set locally in certain buffers.") "Face used for editable fields spanning only a single line." :group 'widget-faces) -(defvar widget-single-line-display-table - (let ((table (make-display-table))) - (aset table 9 "^I") - (aset table 10 "^J") - table) - "Display table used for single-line editable fields.") +;;; This causes display-table to be loaded, and not usefully. +;;;(defvar widget-single-line-display-table +;;; (let ((table (make-display-table))) +;;; (aset table 9 "^I") +;;; (aset table 10 "^J") +;;; table) +;;; "Display table used for single-line editable fields.") -(when (fboundp 'set-face-display-table) - (set-face-display-table 'widget-single-line-field-face - widget-single-line-display-table)) +;;;(when (fboundp 'set-face-display-table) +;;; (set-face-display-table 'widget-single-line-field-face +;;; widget-single-line-display-table)) ;;; Utility functions. ;; ;; These are not really widget specific. -(defsubst widget-plist-member (plist prop) - ;; Return non-nil if PLIST has the property PROP. - ;; PLIST is a property list, which is a list of the form - ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. - ;; Unlike `plist-get', this allows you to distinguish between a missing - ;; property and a property with the value nil. - ;; The value is actually the tail of PLIST whose car is PROP. - (while (and plist (not (eq (car plist) prop))) - (setq plist (cdr (cdr plist)))) - plist) - (defun widget-princ-to-string (object) ;; Return string representation of OBJECT, any Lisp object. ;; No quoting characters are used; no delimiters are printed around @@ -267,23 +202,6 @@ minibuffer." ;; We are in Emacs-19, pressed by the mouse (x-popup-menu event (list title (cons "" items)))) - ((and (< (length items) widget-menu-max-size) - event (fboundp 'popup-menu) window-system) - ;; We are in XEmacs, pressed by the mouse - (let ((val (get-popup-menu-response - (cons title - (mapcar - (function - (lambda (x) - (if (stringp x) - (vector x nil nil) - (vector (car x) (list (car x)) t)))) - items))))) - (setq val (and val - (listp (event-object val)) - (stringp (car-safe (event-object val))) - (car (event-object val)))) - (cdr (assoc val items)))) (widget-menu-minibuffer-flag ;; Read the choice of name from the minibuffer. (setq items (widget-remove-if 'stringp items)) @@ -325,17 +243,35 @@ minibuffer." (error "None of the choices is currently meaningful")) (define-key map [?\C-g] 'keyboard-quit) (define-key map [t] 'keyboard-quit) + (define-key map [?\M-\C-v] 'scroll-other-window) + (define-key map [?\M--] 'negative-argument) (setcdr map (nreverse (cdr map))) - ;; Unread a SPC to lead to our new menu. - (setq unread-command-events (cons ?\ unread-command-events)) ;; Read a char with the menu, and return the result ;; that corresponds to it. (save-window-excursion - (display-buffer (get-buffer " widget-choose")) - (let ((cursor-in-echo-area t)) - (setq value - (lookup-key overriding-terminal-local-map - (read-key-sequence title) t)))) + (let ((buf (get-buffer " widget-choose"))) + (display-buffer buf) + (let ((cursor-in-echo-area t) + keys + (char 0) + (arg 1)) + (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 keys (read-key-sequence title)) + (setq value (lookup-key overriding-terminal-local-map keys t) + char (string-to-char (substring keys 1))) + (cond ((eq value 'scroll-other-window) + (let ((minibuffer-scroll-window (get-buffer-window buf))) + (if (> 0 arg) + (scroll-other-window-down (window-height minibuffer-scroll-window)) + (scroll-other-window)) + (setq arg 1))) + ((eq value 'negative-argument) + (setq arg -1)) + (t + (setq arg 1))))))) (when (eq value 'keyboard-quit) (error "Canceled")) value)))) @@ -352,18 +288,6 @@ minibuffer." ;; ;; These functions are for specifying text properties. -(defun widget-specify-none (from to) - ;; Clear all text properties between FROM and TO. - (set-text-properties from to nil)) - -(defun widget-specify-text (from to) - ;; Default properties. - (add-text-properties from to (list 'read-only t - 'front-sticky t - 'rear-nonsticky nil - 'start-open nil - 'end-open nil))) - (defcustom widget-field-add-space (or (< emacs-major-version 20) (and (eq emacs-major-version 20) @@ -378,9 +302,9 @@ size field." :group 'widgets) (defcustom widget-field-use-before-change - (or (> emacs-minor-version 34) - (>= emacs-major-version 20) - (string-match "XEmacs" emacs-version)) + (and (or (> emacs-minor-version 34) + (> emacs-major-version 19)) + (not (string-match "XEmacs" emacs-version))) "Non-nil means use `before-change-functions' to track editable fields. This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. Using before hooks also means that the :notify function can't know the @@ -390,7 +314,6 @@ new value." (defun widget-specify-field (widget from to) "Specify editable button for WIDGET between FROM and TO." - (put-text-property from to 'read-only nil) ;; Terminating space is not part of the field, but necessary in ;; order for local-map to work. Remove next sexp if local-map works ;; at the end of the overlay. @@ -401,14 +324,6 @@ new value." (widget-field-add-space (insert-and-inherit " "))) (setq to (point))) - (if (or widget-field-add-space - (null (widget-get widget :size))) - (add-text-properties (1- to) to - '(front-sticky nil start-open t read-only to)) - (add-text-properties to (1+ to) - '(front-sticky nil start-open t read-only to))) - (add-text-properties (1- from) from - '(rear-nonsticky t end-open t read-only from)) (let ((map (widget-get widget :keymap)) (face (or (widget-get widget :value-face) 'widget-field-face)) (help-echo (widget-get widget :help-echo)) @@ -424,7 +339,26 @@ new value." (overlay-put overlay 'keymap map) (overlay-put overlay 'face face) (overlay-put overlay 'balloon-help help-echo) - (overlay-put overlay 'help-echo help-echo))) + (overlay-put overlay 'help-echo help-echo)) + (widget-specify-secret widget)) + +(defun widget-specify-secret (field) + "Replace text in FIELD with value of `:secret', if non-nil." + (let ((secret (widget-get field :secret)) + (size (widget-get field :size))) + (when secret + (let ((begin (widget-field-start field)) + (end (widget-field-end field))) + (when size + (while (and (> end begin) + (eq (char-after (1- end)) ?\ )) + (setq end (1- end)))) + (while (< begin end) + (let ((old (char-after begin))) + (unless (eq old secret) + (subst-char-in-region begin (1+ begin) old secret) + (put-text-property begin (1+ begin) 'secret old)) + (setq begin (1+ begin)))))))) (defun widget-specify-button (widget from to) "Specify button for WIDGET between FROM and TO." @@ -461,8 +395,10 @@ new value." (defun widget-specify-doc (widget from to) ;; Specify documentation for WIDGET between FROM and TO. - (add-text-properties from to (list 'widget-doc widget - 'face widget-documentation-face))) + (let ((overlay (make-overlay from to nil t nil))) + (overlay-put overlay 'widget-doc widget) + (overlay-put overlay 'face widget-documentation-face) + (widget-put widget :doc-overlay overlay))) (defmacro widget-specify-insert (&rest form) ;; Execute FORM without inheriting any text properties. @@ -474,7 +410,6 @@ new value." after-change-functions) (insert "<>") (narrow-to-region (- (point) 2) (point)) - (widget-specify-none (point-min) (point-max)) (goto-char (1+ (point-min))) (setq result (progn (,@ form))) (delete-region (point-min) (1+ (point-min))) @@ -526,27 +461,6 @@ new value." "Return the type of WIDGET, a symbol." (car widget)) -(defun widget-put (widget property value) - "In WIDGET set PROPERTY to VALUE. -The value can later be retrived with `widget-get'." - (setcdr widget (plist-put (cdr widget) property value))) - -(defun widget-get (widget property) - "In WIDGET, get the value of PROPERTY. -The value could either be specified when the widget was created, or -later with `widget-put'." - (let ((missing t) - value tmp) - (while missing - (cond ((setq tmp (widget-plist-member (cdr widget) property)) - (setq value (car (cdr tmp)) - missing nil)) - ((setq tmp (car widget)) - (setq widget (get tmp 'widget-type))) - (t - (setq missing nil)))) - value)) - (defun widget-get-indirect (widget property) "In WIDGET, get the value of PROPERTY. If the value is a symbol, return its binding. @@ -564,12 +478,6 @@ Otherwise, just return the value." (widget-member (get (car widget) 'widget-type) property)) (t nil))) -;;;###autoload -(defun widget-apply (widget property &rest args) - "Apply the value of WIDGET's PROPERTY to the widget itself. -ARGS are passed as extra arguments to the function." - (apply (widget-get widget property) widget args)) - (defun widget-value (widget) "Extract the current value of WIDGET." (widget-apply widget @@ -581,6 +489,11 @@ ARGS are passed as extra arguments to the function." :value-set (widget-apply widget :value-to-internal value))) +(defun widget-default-get (widget) + "Extract the default value of WIDGET." + (or (widget-get widget :value) + (widget-apply widget :default-get))) + (defun widget-match-inline (widget vals) ;; In WIDGET, match the start of VALS. (cond ((widget-get widget :inline) @@ -887,8 +800,7 @@ The optional ARGS are additional keyword arguments." before-change-functions after-change-functions (from (point))) - (apply 'insert args) - (widget-specify-text from (point)))) + (apply 'insert args))) (defun widget-convert-text (type from to &optional button-from button-to @@ -902,7 +814,6 @@ Optional ARGS are extra keyword arguments for TYPE." (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) (from (copy-marker from)) (to (copy-marker to))) - (widget-specify-text from to) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) @@ -925,6 +836,7 @@ button end points." (to (widget-get widget :to)) (button (widget-get widget :button-overlay)) (sample (widget-get widget :sample-overlay)) + (doc (widget-get widget :doc-overlay)) (field (widget-get widget :field-overlay)) (children (widget-get widget :children))) (set-marker from nil) @@ -933,6 +845,8 @@ button end points." (delete-overlay button)) (when sample (delete-overlay sample)) + (when doc + (delete-overlay doc)) (when field (delete-overlay field)) (mapcar 'widget-leave-text children))) @@ -1003,8 +917,9 @@ Recommended as a parent keymap for modes using widgets.") :group 'widget-faces) (defun widget-button-click (event) - "Invoke button below mouse pointer." + "Invoke the button that the mouse is pointing at, and move there." (interactive "@e") + (mouse-set-point event) (cond ((and (fboundp 'event-glyph) (event-glyph event)) (widget-glyph-click event)) @@ -1086,7 +1001,7 @@ Recommended as a parent keymap for modes using widgets.") (if (eq extent (event-glyph-extent last)) (set-extent-property extent 'end-glyph down-glyph) (set-extent-property extent 'end-glyph up-glyph)) - (setq last (next-event event))) + (setq last (read-event event))) ;; Release glyph. (when down-glyph (set-extent-property extent 'end-glyph up-glyph)) @@ -1126,6 +1041,12 @@ POS defaults to the value of (point)." widget)) nil))) +(defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version) + "If non-nil, use overlay change functions to tab around in the buffer. +This is much faster, but doesn't work reliably on Emacs 19.34." + :type 'boolean + :group 'widgets) + (defun widget-move (arg) "Move point to the ARG next field or button. ARG may be negative to move backward." @@ -1136,9 +1057,12 @@ ARG may be negative to move backward." new) ;; Forward. (while (> arg 0) - (if (eobp) - (goto-char (point-min)) - (forward-char 1)) + (cond ((eobp) + (goto-char (point-min))) + (widget-use-overlay-change + (goto-char (next-overlay-change (point)))) + (t + (forward-char 1))) (and (eq pos (point)) (eq arg number) (error "No buttons or fields found")) @@ -1149,9 +1073,12 @@ ARG may be negative to move backward." (setq old new))))) ;; Backward. (while (< arg 0) - (if (bobp) - (goto-char (point-max)) - (backward-char 1)) + (cond ((bobp) + (goto-char (point-max))) + (widget-use-overlay-change + (goto-char (previous-overlay-change (point)))) + (t + (backward-char 1))) (and (eq pos (point)) (eq arg number) (error "No buttons or fields found")) @@ -1184,19 +1111,25 @@ With optional ARG, move across that many fields." "Go to beginning of field or beginning of line, whichever is first." (interactive) (let* ((field (widget-field-find (point))) - (start (and field (widget-field-start field)))) - (if (and start (not (eq start (point)))) - (goto-char start) - (call-interactively 'beginning-of-line)))) + (start (and field (widget-field-start field))) + (bol (save-excursion + (beginning-of-line) + (point)))) + (goto-char (if start + (max start bol) + bol)))) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first." (interactive) (let* ((field (widget-field-find (point))) - (end (and field (widget-field-end field)))) - (if (and end (not (eq end (point)))) - (goto-char end) - (call-interactively 'end-of-line)))) + (end (and field (widget-field-end field))) + (eol (save-excursion + (end-of-line) + (point)))) + (goto-char (if end + (min end eol) + eol)))) (defun widget-kill-line () "Kill to end of field or end of line, whichever is first." @@ -1250,14 +1183,7 @@ When not inside a field, move to the previous button or field." (set-marker from nil) (set-marker to nil)))) (widget-clear-undo) - ;; We need to maintain text properties and size of the editing fields. - (make-local-variable 'after-change-functions) - (setq after-change-functions - (if widget-field-list '(widget-after-change) nil)) - (when widget-field-use-before-change - (make-local-variable 'before-change-functions) - (setq before-change-functions - (if widget-field-list '(widget-before-change) nil)))) + (widget-add-change)) (defvar widget-field-last nil) ;; Last field containing point. @@ -1302,13 +1228,30 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (setq found field)))) found)) -(defun widget-before-change (from &rest ignore) +(defun widget-before-change (from to) ;; This is how, for example, a variable changes its state to `modified'. ;; when it is being edited. - (condition-case nil - (let ((field (widget-field-find from))) - (widget-apply field :notify field)) - (error (debug "Before Change")))) + (unless inhibit-read-only + (let ((from-field (widget-field-find from)) + (to-field (widget-field-find to))) + (cond ((not (eq from-field to-field)) + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Change should be restricted to a single field")) + ((null from-field) + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Attempt to change text outside editable field")) + (widget-field-use-before-change + (condition-case nil + (widget-apply from-field :notify from-field) + (error (debug "Before Change")))))))) + +(defun widget-add-change () + (make-local-hook 'post-command-hook) + (remove-hook 'post-command-hook 'widget-add-change t) + (make-local-hook 'before-change-functions) + (add-hook 'before-change-functions 'widget-before-change nil t) + (make-local-hook 'after-change-functions) + (add-hook 'after-change-functions 'widget-after-change nil t)) (defun widget-after-change (from to old) ;; Adjust field size and text properties. @@ -1318,8 +1261,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (when field (unless (eq field other) (debug "Change in different fields")) - (let ((size (widget-get field :size)) - (secret (widget-get field :secret))) + (let ((size (widget-get field :size))) (when size (let ((begin (widget-field-start field)) (end (widget-field-end field))) @@ -1341,19 +1283,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too." (while (and (eq (preceding-char) ?\ ) (> (point) begin)) (delete-backward-char 1))))))) - (when secret - (let ((begin (widget-field-start field)) - (end (widget-field-end field))) - (when size - (while (and (> end begin) - (eq (char-after (1- end)) ?\ )) - (setq end (1- end)))) - (while (< begin end) - (let ((old (char-after begin))) - (unless (eq old secret) - (subst-char-in-region begin (1+ begin) old secret) - (put-text-property begin (1+ begin) 'secret old)) - (setq begin (1+ begin))))))) + (widget-specify-secret field)) (widget-apply field :notify field))) (error (debug "After Change")))) @@ -1421,6 +1351,7 @@ Optional EVENT is the event that triggered the action." :delete 'widget-default-delete :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline + :default-get 'widget-default-default-get :menu-tag-get 'widget-default-menu-tag-get :validate (lambda (widget) nil) :active 'widget-default-active @@ -1504,7 +1435,6 @@ If that does not exists, call the value of `widget-complete-field'." (widget-apply widget :value-create))) (let ((from (copy-marker (point-min))) (to (copy-marker (point-max)))) - (widget-specify-text from to) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) @@ -1570,6 +1500,7 @@ If that does not exists, call the value of `widget-complete-field'." (inactive-overlay (widget-get widget :inactive)) (button-overlay (widget-get widget :button-overlay)) (sample-overlay (widget-get widget :sample-overlay)) + (doc-overlay (widget-get widget :doc-overlay)) before-change-functions after-change-functions (inhibit-read-only t)) @@ -1580,6 +1511,8 @@ If that does not exists, call the value of `widget-complete-field'." (delete-overlay button-overlay)) (when sample-overlay (delete-overlay sample-overlay)) + (when doc-overlay + (delete-overlay doc-overlay)) (when (< from to) ;; Kludge: this doesn't need to be true for empty formats. (delete-region from to)) @@ -1615,6 +1548,10 @@ If that does not exists, call the value of `widget-complete-field'." (widget-value widget) (list (widget-value widget)))) +(defun widget-default-default-get (widget) + ;; Get `:value'. + (widget-get widget :value)) + (defun widget-default-menu-tag-get (widget) ;; Use tag or value for menus. (or (widget-get widget :menu-tag) @@ -1799,8 +1736,27 @@ If END is omitted, it defaults to the length of LIST." (defun widget-url-link-action (widget &optional event) "Open the url specified by WIDGET." - (require 'browse-url) - (funcall browse-url-browser-function (widget-value widget))) + (browse-url (widget-value widget))) + +;;; The `function-link' Widget. + +(define-widget 'function-link 'link + "A link to an Emacs function." + :action 'widget-function-link-action) + +(defun widget-function-link-action (widget &optional event) + "Show the function specified by WIDGET." + (describe-function (widget-value widget))) + +;;; The `variable-link' Widget. + +(define-widget 'variable-link 'link + "A link to an Emacs variable." + :action 'widget-variable-link-action) + +(defun widget-variable-link-action (widget &optional event) + "Show the variable specified by WIDGET." + (describe-variable (widget-value widget))) ;;; The `file-link' Widget. @@ -1822,6 +1778,16 @@ If END is omitted, it defaults to the length of LIST." "Find the Emacs Library file specified by WIDGET." (find-file (locate-library (widget-value widget)))) +;;; The `emacs-commentary-link' Widget. + +(define-widget 'emacs-commentary-link 'link + "A link to Commentary in an Emacs Lisp library file." + :action 'widget-emacs-commentary-link-action) + +(defun widget-emacs-commentary-link-action (widget &optional event) + "Find the Commentary section of the Emacs file specified by WIDGET." + (finder-commentary (widget-value widget))) + ;;; The `editable-field' Widget. (define-widget 'editable-field 'default @@ -1959,6 +1925,7 @@ If END is omitted, it defaults to the length of LIST." :value-delete 'widget-children-value-delete :value-get 'widget-choice-value-get :value-inline 'widget-choice-value-inline + :default-get 'widget-choice-default-get :mouse-down-action 'widget-choice-mouse-down-action :action 'widget-choice-action :error "Make a choice" @@ -1970,21 +1937,30 @@ If END is omitted, it defaults to the length of LIST." ;; Insert the first choice that matches the value. (let ((value (widget-get widget :value)) (args (widget-get widget :args)) + (explicit (widget-get widget :explicit-choice)) + (explicit-value (widget-get widget :explicit-choice-value)) current) - (while args - (setq current (car args) - args (cdr args)) - (when (widget-apply current :match value) - (widget-put widget :children (list (widget-create-child-value - widget current value))) - (widget-put widget :choice current) - (setq args nil - current nil))) - (when current - (let ((void (widget-get widget :void))) - (widget-put widget :children (list (widget-create-child-and-convert - widget void :value value))) - (widget-put widget :choice void))))) + (if (and explicit (eq value explicit-value)) + (progn + ;; If the user specified the choice for this value, + ;; respect that choice as long as the value is the same. + (widget-put widget :children (list (widget-create-child-value + widget explicit value))) + (widget-put widget :choice explicit)) + (while args + (setq current (car args) + args (cdr args)) + (when (widget-apply current :match value) + (widget-put widget :children (list (widget-create-child-value + widget current value))) + (widget-put widget :choice current) + (setq args nil + current nil))) + (when current + (let ((void (widget-get widget :void))) + (widget-put widget :children (list (widget-create-child-and-convert + widget void :value value))) + (widget-put widget :choice void)))))) (defun widget-choice-value-get (widget) ;; Get value of the child widget. @@ -1994,6 +1970,10 @@ If END is omitted, it defaults to the length of LIST." ;; Get value of the child widget. (widget-apply (car (widget-get widget :children)) :value-inline)) +(defun widget-choice-default-get (widget) + ;; Get default for the first choice. + (widget-default-get (car (widget-get widget :args)))) + (defcustom widget-choice-toggle nil "If non-nil, a binary choice will just toggle between the values. Otherwise, the user will explicitly have to choose between the values @@ -2033,6 +2013,7 @@ when he invoked the menu." (old (widget-get widget :choice)) (tag (widget-apply widget :menu-tag-get)) (completion-ignore-case (widget-get widget :case-fold)) + this-explicit current choices) ;; Remember old value. (if (and old (not (widget-apply widget :validate))) @@ -2059,11 +2040,19 @@ when he invoked the menu." (cons (cons (widget-apply current :menu-tag-get) current) choices))) + (setq this-explicit t) (widget-choose tag (reverse choices) event)))) (when current - (widget-value-set widget - (widget-apply current :value-to-external - (widget-get current :value))) + ;; 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. + (when this-explicit + (widget-put widget :explicit-choice current) + (widget-put widget :explicit-choice-value (widget-get widget :value))) + (let ((value (widget-default-get current))) + (widget-value-set widget + (widget-apply current :value-to-external value))) (widget-setup) (widget-apply widget :notify widget event))) (run-hook-with-args 'widget-edit-functions widget)) @@ -2609,8 +2598,6 @@ when he invoked the menu." (when (< (widget-get child :entry-from) (widget-get widget :from)) (set-marker (widget-get widget :from) (widget-get child :entry-from))) - (widget-specify-text (widget-get child :entry-from) - (widget-get child :entry-to)) (if (eq (car children) before) (widget-put widget :children (cons child children)) (while (not (eq (car (cdr children)) before)) @@ -2675,7 +2662,10 @@ when he invoked the menu." (if conv (setq child (widget-create-child-value widget type value)) - (setq child (widget-create-child widget type)))) + (setq child (widget-create-child-value + widget type + (widget-apply type :value-to-external + (widget-default-get type)))))) (t (error "Unknown escape `%c'" escape))))) (widget-put widget @@ -2684,7 +2674,6 @@ when he invoked the menu." (widget-get widget :buttons)))) (let ((entry-from (copy-marker (point-min))) (entry-to (copy-marker (point-max)))) - (widget-specify-text entry-from entry-to) (set-marker-insertion-type entry-from t) (set-marker-insertion-type entry-to nil) (widget-put child :entry-from entry-from) @@ -2702,6 +2691,7 @@ when he invoked the menu." :value-create 'widget-group-value-create :value-delete 'widget-children-value-delete :value-get 'widget-editable-list-value-get + :default-get 'widget-group-default-get :validate 'widget-children-validate :match 'widget-group-match :match-inline 'widget-group-match-inline) @@ -2728,6 +2718,10 @@ when he invoked the menu." children)) (widget-put widget :children (nreverse children)))) +(defun widget-group-default-get (widget) + ;; Get the default of the components. + (mapcar 'widget-default-get (widget-get widget :args))) + (defun widget-group-match (widget values) ;; Match if the components match. (and (listp values) @@ -2929,6 +2923,17 @@ link for that string." :format "%v\n%h" :documentation-property 'variable-documentation) +(define-widget 'other 'sexp + "Matches any value, but doesn't let the user edit the value. +This is useful as last item in a `choice' widget. +You should use this widget type with a default value, +as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT). +If the user selects this alternative, that specifies DEFAULT +as the value." + :tag "Other" + :format "%t%n" + :value 'other) + (defvar widget-string-prompt-value-history nil "History of input to `widget-string-prompt-value'.") @@ -2943,7 +2948,8 @@ link for that string." "A regular expression." :match 'widget-regexp-match :validate 'widget-regexp-validate - :value-face 'widget-single-line-field-face + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face :tag "Regexp") (defun widget-regexp-match (widget value) @@ -2969,7 +2975,8 @@ It will read a file name from the minibuffer when invoked." :complete-function 'widget-file-complete :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" - :value-face 'widget-single-line-field-face + ;; Doesn't work well with terminating newline. + ;; :value-face 'widget-single-line-field-face :tag "File") (defun widget-file-complete () @@ -3031,7 +3038,7 @@ It will read a directory name from the minibuffer when invoked." "History of input to `widget-symbol-prompt-value'.") (define-widget 'symbol 'editable-field - "A lisp symbol." + "A Lisp symbol." :value nil :tag "Symbol" :format "%{%t%}: %v" @@ -3063,7 +3070,7 @@ It will read a directory name from the minibuffer when invoked." "History of input to `widget-function-prompt-value'.") (define-widget 'function 'sexp - "A lisp function." + "A Lisp function." :complete-function 'lisp-complete-symbol :prompt-value 'widget-field-prompt-value :prompt-internal 'widget-symbol-prompt-internal @@ -3077,7 +3084,7 @@ It will read a directory name from the minibuffer when invoked." (define-widget 'variable 'symbol ;; Should complete on variables. - "A lisp variable." + "A Lisp variable." :prompt-match 'boundp :prompt-history 'widget-variable-prompt-value-history :tag "Variable") @@ -3118,7 +3125,7 @@ It will read a directory name from the minibuffer when invoked." ) (define-widget 'sexp 'editable-field - "An arbitrary lisp expression." + "An arbitrary Lisp expression." :tag "Lisp expression" :format "%{%t%}: %v" :value nil @@ -3241,12 +3248,12 @@ To use this type, you must define :match or :match-alternatives." (integerp value)))) (define-widget 'list 'group - "A lisp list." + "A Lisp list." :tag "List" :format "%{%t%}:\n%v") (define-widget 'vector 'group - "A lisp vector." + "A Lisp vector." :tag "Vector" :format "%{%t%}:\n%v" :match 'widget-vector-match @@ -3386,14 +3393,13 @@ To use this type, you must define :match or :match-alternatives." (message "Making completion list...done"))))) (defun widget-color-sample-face-get (widget) - (let ((symbol (intern (concat "fg:" (widget-value widget))))) - (if (string-match "XEmacs" emacs-version) - (prog1 symbol - (or (find-face symbol) - (set-face-foreground (make-face symbol) (widget-value widget)))) - (condition-case nil - (facemenu-get-face symbol) - (error 'default))))) + (let* ((value (condition-case nil + (widget-value widget) + (error (widget-get widget :value)))) + (symbol (intern (concat "fg:" value)))) + (condition-case nil + (facemenu-get-face symbol) + (error 'default)))) (defvar widget-color-choice-list nil) ;; Variable holding the possible colors. @@ -3401,10 +3407,8 @@ To use this type, you must define :match or :match-alternatives." (defun widget-color-choice-list () (unless widget-color-choice-list (setq widget-color-choice-list - (if (fboundp 'read-color-completion-table) - (read-color-completion-table) - (mapcar '(lambda (color) (list color)) - (x-defined-colors))))) + (mapcar '(lambda (color) (list color)) + (x-defined-colors)))) widget-color-choice-list) (defvar widget-color-history nil @@ -3414,14 +3418,21 @@ To use this type, you must define :match or :match-alternatives." ;; Prompt for a color. (let* ((tag (widget-apply widget :menu-tag-get)) (prompt (concat tag ": ")) - (answer (cond ((string-match "XEmacs" emacs-version) - (read-color prompt)) - ((fboundp 'x-defined-colors) - (completing-read (concat tag ": ") - (widget-color-choice-list) - nil nil nil 'widget-color-history)) - (t - (read-string prompt (widget-value widget)))))) + (value (widget-value widget)) + (start (widget-field-start widget)) + (pos (cond ((< (point) start) + 0) + ((> (point) (+ start (length value))) + (length value)) + (t + (- (point) start)))) + (answer (if (commandp 'read-color) + (read-color prompt) + (completing-read (concat tag ": ") + (widget-color-choice-list) + nil nil + (cons value pos) + 'widget-color-history)))) (unless (zerop (length answer)) (widget-value-set widget answer) (widget-setup) @@ -3450,7 +3461,7 @@ Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" (select-window win) (let* ((result (compute-motion (window-start win) '(0 . 0) - (window-end win) + (point-max) where (window-width win) (cons (window-hscroll) 0)