Mercurial > emacs
diff lisp/wid-edit.el @ 17550:d6545cfb6c5a
Synched with custom 1.90.
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Thu, 24 Apr 1997 16:53:55 +0000 |
parents | 8af9d46a055e |
children | 0df9495348e7 |
line wrap: on
line diff
--- a/lisp/wid-edit.el Thu Apr 24 02:58:11 1997 +0000 +++ b/lisp/wid-edit.el Thu Apr 24 16:53:55 1997 +0000 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: extensions -;; Version: 1.84 +;; Version: 1.90 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -32,8 +32,7 @@ (require 'widget) -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl)) ;;; Compatibility. @@ -75,7 +74,7 @@ ;; We have the old custom-library, hack around it! (defmacro defgroup (&rest args) nil) (defmacro defcustom (var value doc &rest args) - `(defvar ,var ,value ,doc)) + (` (defvar (, var) (, value) (, doc)))) (defmacro defface (&rest args) nil) (define-widget-keywords :prefix :tag :load :link :options :type :group) (when (fboundp 'copy-face) @@ -134,7 +133,7 @@ (defface widget-field-face '((((class grayscale color) (background light)) - (:background "light gray")) + (:background "gray85")) (((class grayscale color) (background dark)) (:background "dark gray")) @@ -184,7 +183,9 @@ "Choose an item from a list. First argument TITLE is the name of the list. -Second argument ITEMS is an alist (NAME . VALUE). +Second argument ITEMS is an list whose members are either + (NAME . VALUE), to indicate selectable items, or just strings to + indicate unselectable items. Optional third argument EVENT is an input event. The user is asked to choose between each NAME from the items alist, @@ -205,7 +206,9 @@ (mapcar (function (lambda (x) - (vector (car x) (list (car x)) t))) + (if (stringp x) + (vector x nil nil) + (vector (car x) (list (car x)) t)))) items))))) (setq val (and val (listp (event-object val)) @@ -213,6 +216,7 @@ (car (event-object val)))) (cdr (assoc val items)))) (t + (setq items (remove-if 'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) (if (stringp val) (let ((try (try-completion val items))) @@ -235,6 +239,22 @@ (throw 'child child))) nil))) +;;; Helper functions. +;; +;; These are widget specific. + +;;;###autoload +(defun widget-prompt-value (widget prompt &optional value unbound) + "Prompt for a value matching WIDGET, using PROMPT. +The current value is assumed to be VALUE, unless UNBOUND is non-nil." + (unless (listp widget) + (setq widget (list widget))) + (setq widget (widget-convert widget)) + (let ((answer (widget-apply widget :prompt-value prompt value unbound))) + (unless (widget-apply widget :match answer) + (error "Value does not match %S type." (car widget))) + answer)) + ;;; Widget text specifications. ;; ;; These functions are for specifying text properties. @@ -388,7 +408,8 @@ (defmacro widget-specify-insert (&rest form) ;; Execute FORM without inheriting any text properties. - `(save-restriction + (` + (save-restriction (let ((inhibit-read-only t) result after-change-functions) @@ -396,11 +417,11 @@ (narrow-to-region (- (point) 2) (point)) (widget-specify-none (point-min) (point-max)) (goto-char (1+ (point-min))) - (setq result (progn ,@form)) + (setq result (progn (,@ form))) (delete-region (point-min) (1+ (point-min))) (delete-region (1- (point-max)) (point-max)) (goto-char (point-max)) - result))) + result)))) (defface widget-inactive-face '((((class grayscale color) (background dark)) @@ -418,7 +439,8 @@ (unless (widget-get widget :inactive) (let ((overlay (make-overlay from to nil t nil))) (overlay-put overlay 'face 'widget-inactive-face) - (overlay-put overlay 'evaporate 't) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'priority 100) (overlay-put overlay (if (string-match "XEmacs" emacs-version) 'read-only 'modification-hooks) '(widget-overlay-inactive)) @@ -503,7 +525,7 @@ (if (widget-apply widget :active) (widget-apply widget :action event) (error "Attempt to perform action on inactive widget"))) - + ;;; Glyphs. (defcustom widget-glyph-directory (concat data-directory "custom/") @@ -800,8 +822,9 @@ (t (error "No buttons or fields found")))))) (setq button (widget-at (point))) - (if (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) + (if (or (and button (widget-get button :tab-order) + (< (widget-get button :tab-order) 0)) + (and button (not (widget-apply button :active)))) (setq arg (1+ arg)))))) (while (< arg 0) (if (= (point-min) (point)) @@ -838,8 +861,9 @@ (button (goto-char button)) (field (goto-char field))) (setq button (widget-at (point))) - (if (and button (widget-get button :tab-order) - (< (widget-get button :tab-order) 0)) + (if (or (and button (widget-get button :tab-order) + (< (widget-get button :tab-order) 0)) + (and button (not (widget-apply button :active)))) (setq arg (1- arg))))) (widget-echo-help (point)) (run-hooks 'widget-move-hook)) @@ -1016,7 +1040,8 @@ :activate 'widget-specify-active :deactivate 'widget-default-deactivate :action 'widget-default-action - :notify 'widget-default-notify) + :notify 'widget-default-notify + :prompt-value 'widget-default-prompt-value) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." @@ -1087,7 +1112,8 @@ (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) - (widget-put widget :to to)))) + (widget-put widget :to to))) + (widget-clear-undo)) (defun widget-default-format-handler (widget escape) ;; We recognize the %h escape by default. @@ -1149,7 +1175,8 @@ ;; Kludge: this doesn't need to be true for empty formats. (delete-region from to)) (set-marker from nil) - (set-marker to nil))) + (set-marker to nil)) + (widget-clear-undo)) (defun widget-default-value-set (widget value) ;; Recreate widget with new value. @@ -1194,6 +1221,14 @@ ;; Pass notification to parent. (widget-default-action widget event)) +(defun widget-default-prompt-value (widget prompt value unbound) + ;; Read an arbitrary value. Stolen from `set-variable'. +;; (let ((initial (if unbound +;; nil +;; ;; It would be nice if we could do a `(cons val 1)' here. +;; (prin1-to-string (custom-quote value)))))) + (eval-minibuffer prompt )) + ;;; The `item' Widget. (define-widget 'item 'default @@ -1297,7 +1332,17 @@ (defun widget-info-link-action (widget &optional event) "Open the info node specified by WIDGET." - (Info-goto-node (widget-value widget))) + (Info-goto-node (widget-value widget)) + ;; Steal button release event. + (if (and (fboundp 'button-press-event-p) + (fboundp 'next-command-event)) + ;; XEmacs + (and event + (button-press-event-p event) + (next-command-event)) + ;; Emacs + (when (memq 'down (event-modifiers event)) + (read-event)))) ;;; The `url-link' Widget. @@ -1507,11 +1552,8 @@ (widget-value-set widget (widget-apply current :value-to-external (widget-get current :value))) - (widget-apply widget :notify widget event) - (widget-setup))) - ;; Notify parent. - (widget-apply widget :notify widget event) - (widget-clear-undo)) + (widget-apply widget :notify widget event) + (widget-setup)))) (defun widget-choice-validate (widget) ;; Valid if we have made a valid choice. @@ -1567,7 +1609,7 @@ ;; Toggle value. (widget-value-set widget (not (widget-value widget))) (widget-apply widget :notify widget event)) - + ;;; The `checkbox' Widget. (define-widget 'checkbox 'toggle @@ -2222,9 +2264,14 @@ (define-widget 'const 'item "An immutable sexp." + :prompt-value 'widget-const-prompt-value :format "%t\n%d") -(define-widget 'function-item 'item +(defun widget-const-prompt-value (widget prompt value unbound) + ;; Return the value of the const. + (widget-value widget)) + +(define-widget 'function-item 'const "An immutable function name." :format "%v\n%h" :documentation-property (lambda (symbol) @@ -2232,28 +2279,67 @@ (documentation symbol t) (error nil)))) -(define-widget 'variable-item 'item +(define-widget 'variable-item 'const "An immutable variable name." :format "%v\n%h" :documentation-property 'variable-documentation) (define-widget 'string 'editable-field "A string" + :prompt-value 'widget-string-prompt-value :tag "String" :format "%[%t%]: %v") +(defvar widget-string-prompt-value-history nil + "History of input to `widget-string-prompt-value'.") + +(defun widget-string-prompt-value (widget prompt value unbound) + ;; Read a string. + (read-string prompt (if unbound nil (cons value 1)) + 'widget-string-prompt-value-history)) + (define-widget 'regexp 'string "A regular expression." - ;; Should do validation. + :match 'widget-regexp-match + :validate 'widget-regexp-validate :tag "Regexp") +(defun widget-regexp-match (widget value) + ;; Match valid regexps. + (and (stringp value) + (condition-case data + (prog1 t + (string-match value "")) + (error nil)))) + +(defun widget-regexp-validate (widget) + "Check that the value of WIDGET is a valid regexp." + (let ((val (widget-value widget))) + (condition-case data + (prog1 nil + (string-match val "")) + (error (widget-put widget :error (error-message-string data)) + widget)))) + (define-widget 'file 'string "A file widget. It will read a file name from the minibuffer when activated." + :prompt-value 'widget-file-prompt-value :format "%[%t%]: %v" :tag "File" :action 'widget-file-action) +(defun widget-file-prompt-value (widget prompt value unbound) + ;; Read file from minibuffer. + (abbreviate-file-name + (if unbound + (read-file-name prompt) + (let ((prompt2 (concat prompt "(default `" value "') ")) + (dir (file-name-directory value)) + (file (file-name-nondirectory value)) + (must-match (widget-get widget :must-match))) + (read-file-name prompt2 dir nil must-match file))))) + (defun widget-file-action (widget &optional event) ;; Read a file name from the minibuffer. (let* ((value (widget-value widget)) @@ -2303,7 +2389,8 @@ :validate 'widget-sexp-validate :match (lambda (widget value) t) :value-to-internal 'widget-sexp-value-to-internal - :value-to-external (lambda (widget value) (read value))) + :value-to-external (lambda (widget value) (read value)) + :prompt-value 'widget-sexp-prompt-value) (defun widget-sexp-value-to-internal (widget value) ;; Use pp for printer representation. @@ -2337,6 +2424,24 @@ (error (widget-put widget :error (error-message-string data)) widget))))) +(defvar widget-sexp-prompt-value-history nil + "History of input to `widget-sexp-prompt-value'.") + +(defun widget-sexp-prompt-value (widget prompt value unbound) + ;; Read an arbitrary sexp. + (let ((found (read-string prompt + (if unbound nil (cons (prin1-to-string value) 1)) + 'widget-sexp-prompt-value))) + (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) + (erase-buffer) + (insert found) + (goto-char (point-min)) + (let ((answer (read buffer))) + (unless (eobp) + (error "Junk at end of expression: %s" + (buffer-substring (point) (point-max)))) + answer)))) + (define-widget 'integer 'sexp "An integer." :tag "Integer" @@ -2354,7 +2459,8 @@ :value 0 :size 1 :format "%{%t%}: %v\n" - :type-error "This field should contain a character" + :valid-regexp "\\`.\\'" + :error "This field should contain a single character" :value-to-internal (lambda (widget value) (if (integerp value) (char-to-string value) @@ -2432,8 +2538,20 @@ (define-widget 'boolean 'toggle "To be nil or non-nil, that is the question." :tag "Boolean" + :prompt-value 'widget-boolean-prompt-value :format "%{%t%}: %[%v%]\n") +(defun widget-boolean-prompt-value (widget prompt value unbound) + ;; Toggle a boolean. + (cond (unbound + (y-or-n-p prompt)) + (value + (message "Off") + nil) + (t + (message "On") + t))) + ;;; The `color' Widget. (define-widget 'color-item 'choice-item