From 6aaedd123065d146fee819d3d1f0e26433185c5b Mon Sep 17 00:00:00 2001 From: Per Abrahamsen Date: Sat, 14 Jun 1997 10:21:01 +0000 Subject: Synched with 1.9914. --- lisp/cus-edit.el | 137 +++++++++++++++++++++++++---------------- lisp/wid-browse.el | 4 +- lisp/wid-edit.el | 176 ++++++++++++++++++++++++++++++++++++++++------------- 3 files changed, 220 insertions(+), 97 deletions(-) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 7d545ba68e..701a5a8c0f 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.9908 +;; Version: 1.9914 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -246,6 +246,16 @@ :group 'customize :group 'faces) +(defgroup custom-buffer nil + "Control the customize buffers." + :prefix "custom-" + :group 'customize) + +(defgroup custom-menu nil + "Control how the customize menus." + :prefix "custom-" + :group 'customize) + (defgroup abbrev-mode nil "Word abbreviations mode." :group 'abbrev) @@ -401,7 +411,7 @@ WIDGET is the widget to apply the filter entries of MENU on." (defcustom custom-unlispify-menu-entries t "Display menu entries as words instead of symbols if non nil." - :group 'customize + :group 'custom-menu :type 'boolean) (defun custom-unlispify-menu-entry (symbol &optional no-suffix) @@ -440,7 +450,7 @@ WIDGET is the widget to apply the filter entries of MENU on." (defcustom custom-unlispify-tag-names t "Display tag names as words instead of symbols if non nil." - :group 'customize + :group 'custom-buffer :type 'boolean) (defun custom-unlispify-tag-name (symbol) @@ -518,49 +528,59 @@ if that fails, the doc string with `custom-guess-doc-alist'." ;;; Sorting. -(defcustom custom-buffer-sort-predicate 'custom-buffer-sort-alphabetically +(defcustom custom-buffer-sort-predicate 'ignore "Function used for sorting group members in buffers. The value should be useful as a predicate for `sort'. The list to be sorted is the value of the groups `custom-group' property." - :type '(radio (function-item custom-buffer-sort-alphabetically) + :type '(radio (const :tag "Unsorted" ignore) + (const :tag "Alphabetic" custom-sort-items-alphabetically) (function :tag "Other")) - :group 'customize) + :group 'custom-buffer) -(defun custom-buffer-sort-alphabetically (a b) - "Return t iff is A should be before B. -A and B should be members of a `custom-group' property. -The members are sorted alphabetically, except that all groups are -sorted after all non-groups." - (cond ((and (eq (nth 1 a) 'custom-group) - (not (eq (nth 1 b) 'custom-group))) - nil) - ((and (eq (nth 1 b) 'custom-group) - (not (eq (nth 1 a) 'custom-group))) - t) - (t - (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))))) +(defcustom custom-buffer-order-predicate 'custom-sort-groups-last + "Function used for sorting group members in buffers. +The value should be useful as a predicate for `sort'. +The list to be sorted is the value of the groups `custom-group' property." + :type '(radio (const :tag "Groups first" custom-sort-groups-first) + (const :tag "Groups last" custom-sort-groups-last) + (function :tag "Other")) + :group 'custom-buffer) -(defcustom custom-menu-sort-predicate 'custom-menu-sort-alphabetically +(defcustom custom-menu-sort-predicate 'ignore "Function used for sorting group members in menus. The value should be useful as a predicate for `sort'. The list to be sorted is the value of the groups `custom-group' property." - :type '(radio (function-item custom-menu-sort-alphabetically) + :type '(radio (const :tag "Unsorted" ignore) + (const :tag "Alphabetic" custom-sort-items-alphabetically) (function :tag "Other")) - :group 'customize) + :group 'custom-menu) -(defun custom-menu-sort-alphabetically (a b) - "Return t iff is A should be before B. -A and B should be members of a `custom-group' property. -The members are sorted alphabetically, except that all groups are -sorted before all non-groups." - (cond ((and (eq (nth 1 a) 'custom-group) - (not (eq (nth 1 b) 'custom-group))) - t) - ((and (eq (nth 1 b) 'custom-group) - (not (eq (nth 1 a) 'custom-group))) - nil) - (t - (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))))) +(defcustom custom-menu-order-predicate 'custom-sort-groups-first + "Function used for sorting group members in menus. +The value should be useful as a predicate for `sort'. +The list to be sorted is the value of the groups `custom-group' property." + :type '(radio (const :tag "Groups first" custom-sort-groups-first) + (const :tag "Groups last" custom-sort-groups-last) + (function :tag "Other")) + :group 'custom-menu) + +(defun custom-sort-items-alphabetically (a b) + "Return t iff A is alphabetically before B and the same custom type. +A and B should be members of a `custom-group' property." + (and (eq (nth 1 a) (nth 1 b)) + (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))))) + +(defun custom-sort-groups-first (a b) + "Return t iff A a custom group and B is a not. +A and B should be members of a `custom-group' property." + (and (eq (nth 1 a) 'custom-group) + (not (eq (nth 1 b) 'custom-group)))) + +(defun custom-sort-groups-last (a b) + "Return t iff B a custom group and A is a not. +A and B should be members of a `custom-group' property." + (and (eq (nth 1 b) 'custom-group) + (not (eq (nth 1 a) 'custom-group)))) ;;; Custom Mode Commands. @@ -897,7 +917,7 @@ that option." "If non-nil, only show a single reset button in customize buffers. This button will have a menu with all three reset operations." :type 'boolean - :group 'customize) + :group 'custom-buffer) (defun custom-buffer-create-internal (options) (message "Creating customization buffer...") @@ -1017,38 +1037,49 @@ Reset all visible items in this buffer to their standard settings." ;;; The `custom-magic' Widget. +(defgroup custom-magic-faces nil + "Faces used by the magic button." + :group 'custom-faces + :group 'custom-buffer) + (defface custom-invalid-face '((((class color)) (:foreground "yellow" :background "red")) (t (:bold t :italic t :underline t))) - "Face used when the customize item is invalid.") + "Face used when the customize item is invalid." + :group 'custom-magic-faces) (defface custom-rogue-face '((((class color)) (:foreground "pink" :background "black")) (t (:underline t))) - "Face used when the customize item is not defined for customization.") + "Face used when the customize item is not defined for customization." + :group 'custom-magic-faces) (defface custom-modified-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t :bold))) - "Face used when the customize item has been modified.") + "Face used when the customize item has been modified." + :group 'custom-magic-faces) (defface custom-set-face '((((class color)) (:foreground "blue" :background "white")) (t (:italic t))) - "Face used when the customize item has been set.") + "Face used when the customize item has been set." + :group 'custom-magic-faces) (defface custom-changed-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t))) - "Face used when the customize item has been changed.") + "Face used when the customize item has been changed." + :group 'custom-magic-faces) (defface custom-saved-face '((t (:underline t))) - "Face used when the customize item has been saved.") + "Face used when the customize item has been saved." + :group 'custom-magic-faces) (defconst custom-magic-alist '((nil "#" underline "\ uninitialized, you should not see this.") @@ -1123,7 +1154,7 @@ If non-nil and not the symbol `long', only show first word." :type '(choice (const :tag "no" nil) (const short) (const long)) - :group 'customize) + :group 'custom-buffer) (defcustom custom-magic-show-hidden '(option face) "Control whether the state button is shown for hidden items. @@ -1131,12 +1162,12 @@ The value should be a list with the custom categories where the state button should be visible. Possible categories are `group', `option', and `face'." :type '(set (const group) (const option) (const face)) - :group 'customize) + :group 'custom-buffer) (defcustom custom-magic-show-button nil "Show a magic button indicating the state of each customization option." :type 'boolean - :group 'customize) + :group 'custom-buffer) (define-widget 'custom-magic 'default "Show and manipulate state for a customization option." @@ -2176,8 +2207,9 @@ and so forth. The remaining group tags are shown with (custom-load-widget widget) (let* ((level (widget-get widget :custom-level)) (symbol (widget-value widget)) - (members (sort (get symbol 'custom-group) - custom-buffer-sort-predicate)) + (members (sort (sort (copy-sequence (get symbol 'custom-group)) + custom-buffer-sort-predicate) + custom-buffer-order-predicate)) (prefixes (widget-get widget :custom-prefixes)) (custom-prefix-list (custom-prefix-add symbol prefixes)) (length (length members)) @@ -2199,7 +2231,6 @@ and so forth. The remaining group tags are shown with (unless (eq (preceding-char) ?\n) (widget-insert "\n")))) members))) - (put symbol 'custom-group members) (message "Creating group magic...") (mapcar 'custom-magic-reset children) (message "Creating group state...") @@ -2465,7 +2496,7 @@ Leave point at the location of the call, or after the last expression." (defcustom custom-menu-nesting 2 "Maximum nesting in custom menus." :type 'integer - :group 'customize) + :group 'custom-menu) (defun custom-face-menu-create (widget symbol) "Ignoring WIDGET, create a menu entry for customization face SYMBOL." @@ -2518,9 +2549,9 @@ The menu is in a format applicable to `easy-menu-define'." (< (length (get symbol 'custom-group)) widget-menu-max-size)) (let ((custom-prefix-list (custom-prefix-add symbol custom-prefix-list)) - (members (sort (get symbol 'custom-group) - custom-menu-sort-predicate))) - (put symbol 'custom-group members) + (members (sort (sort (copy-sequence (get symbol 'custom-group)) + custom-menu-sort-predicate) + custom-menu-order-predicate))) (custom-load-symbol symbol) `(,(custom-unlispify-menu-entry symbol t) ,item @@ -2579,7 +2610,7 @@ The format is suitable for use with `easy-menu-define'." (defcustom custom-mode-hook nil "Hook called when entering custom-mode." :type 'hook - :group 'customize) + :group 'custom-buffer ) (defun custom-mode () "Major mode for editing customization buffers. diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index 09a5a6617b..cf98e2b376 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.9905 +;; Version: 1.9914 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -282,7 +282,7 @@ With arg, turn widget mode on if and only if arg is positive." (interactive "P") (cond ((null arg) (setq widget-minor-mode (not widget-minor-mode))) - ((<= 0 arg) + ((<= arg 0) (setq widget-minor-mode nil)) (t (setq widget-minor-mode t))) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 35c0ffd0e1..af6c5e7d2b 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.9908 +;; Version: 1.9914 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; This file is part of GNU Emacs. @@ -123,17 +123,21 @@ is the string or buffer containing the text." "http://www.dina.kvl.dk/~abraham/custom/") :prefix "widget-" :group 'extensions - :group 'faces :group 'hypermedia) +(defgroup widget-faces nil + "Faces used by the widget library." + :group 'widgets + :group 'faces) + (defface widget-button-face '((t (:bold t))) "Face used for widget buttons." - :group 'widgets) + :group 'widget-faces) (defcustom widget-mouse-face 'highlight "Face used for widget buttons when the mouse is above them." :type 'face - :group 'widgets) + :group 'widget-faces) (defface widget-field-face '((((class grayscale color) (background light)) @@ -144,7 +148,7 @@ is the string or buffer containing the text." (t (:italic t))) "Face used for editable fields." - :group 'widgets) + :group 'widget-faces) ;;; Utility functions. ;; @@ -347,14 +351,15 @@ minibuffer." (t (:italic t))) "Face used for inactive widgets." - :group 'widgets) + :group 'widget-faces) (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 'mouse-face 'widget-inactive-face) + ;; This is disabled, as it makes the mouse cursor change shape. + ;; (overlay-put overlay 'mouse-face 'widget-inactive-face) (overlay-put overlay 'evaporate t) (overlay-put overlay 'priority 100) (overlay-put overlay (if (string-match "XEmacs" emacs-version) @@ -474,6 +479,26 @@ This is only meaningful for radio buttons or checkboxes in a list." (throw 'child child))) nil))) +(defun widget-map-buttons (function &optional buffer maparg) + "Map FUNCTION over the buttons in BUFFER. +FUNCTION is called with the arguments WIDGET and MAPARG. + +If FUNCTION returns non-nil, the walk is cancelled. + +The arguments MAPARG, and BUFFER default to nil and (current-buffer), +respectively." + (let ((cur (point-min)) + (widget nil) + (parent nil) + (overlays (if buffer + (save-excursion (set-buffer buffer) (overlay-lists)) + (overlay-lists)))) + (setq overlays (append (car overlays) (cdr overlays))) + (while (setq cur (pop overlays)) + (setq widget (overlay-get cur 'button)) + (if (and widget (funcall function widget maparg)) + (setq overlays nil))))) + ;;; Glyphs. (defcustom widget-glyph-directory (concat data-directory "custom/") @@ -720,6 +745,31 @@ The optional ARGS are additional keyword arguments." (apply 'insert args) (widget-specify-text from (point)))) +(defun widget-convert-text (type from to &optional button-from button-to) + "Return a widget of type TYPE with endpoint FROM TO. +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." + (let ((widget (widget-convert type)) + (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) + (widget-put widget :to to) + (when button-from + (widget-specify-button widget button-from button-to)) + widget)) + +(defun widget-convert-button (type from to) + "Return a widget of type TYPE with endpoint FROM TO. +No text will be inserted to the buffer, instead the text between FROM +and TO will be used as the widgets end points, as well as the widgets +button end points." + (widget-convert-text type from to from to)) + ;;; Keymap and Commands. (defvar widget-keymap nil @@ -783,7 +833,7 @@ Recommended as a parent keymap for modes using widgets.") (t (:bold t :underline t))) "Face used for pressed buttons." - :group 'widgets) + :group 'widget-faces) (defun widget-button-click (event) "Invoke button below mouse pointer." @@ -1017,7 +1067,8 @@ When not inside a field, move to the previous button or field." widget-field-list (cons field widget-field-list)) (let ((from (car (widget-get field :field-overlay))) (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field from to) + (widget-specify-field field + (marker-position from) (marker-position to)) (set-marker from nil) (set-marker to nil)))) (widget-clear-undo) @@ -1037,16 +1088,19 @@ When not inside a field, move to the previous button or field." (defun widget-field-buffer (widget) "Return the start of WIDGET's editing field." - (overlay-buffer (widget-get widget :field-overlay))) + (let ((overlay (widget-get widget :field-overlay))) + (and overlay (overlay-buffer overlay)))) (defun widget-field-start (widget) "Return the start of WIDGET's editing field." - (overlay-start (widget-get widget :field-overlay))) + (let ((overlay (widget-get widget :field-overlay))) + (and overlay (overlay-start overlay)))) (defun widget-field-end (widget) "Return the end of WIDGET's editing field." - ;; Don't subtract one if local-map works at the end of the overlay. - (1- (overlay-end (widget-get widget :field-overlay)))) + (let ((overlay (widget-get widget :field-overlay))) + ;; Don't subtract one if local-map works at the end of the overlay. + (and overlay (1- (overlay-end overlay))))) (defun widget-field-find (pos) "Return the field at POS. @@ -1253,32 +1307,34 @@ If that does not exists, call the value of `widget-complete-field'." (defun widget-default-format-handler (widget escape) ;; We recognize the %h escape by default. - (let* ((buttons (widget-get widget :buttons)) - (doc-property (widget-get widget :documentation-property)) - (doc-try (cond ((widget-get widget :doc)) - ((symbolp doc-property) - (documentation-property (widget-get widget :value) - doc-property)) - (t - (funcall doc-property (widget-get widget :value))))) - (doc-text (and (stringp doc-try) - (> (length doc-try) 1) - doc-try))) + (let* ((buttons (widget-get widget :buttons))) (cond ((eq escape ?h) - (when doc-text - (and (eq (preceding-char) ?\n) - (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - ;; The `*' in the beginning is redundant. - (when (eq (aref doc-text 0) ?*) - (setq doc-text (substring doc-text 1))) - ;; Get rid of trailing newlines. - (when (string-match "\n+\\'" doc-text) - (setq doc-text (substring doc-text 0 (match-beginning 0)))) - (push (widget-create-child-and-convert - widget 'documentation-string - doc-text) - buttons))) + (let* ((doc-property (widget-get widget :documentation-property)) + (doc-try (cond ((widget-get widget :doc)) + ((symbolp doc-property) + (documentation-property + (widget-get widget :value) + doc-property)) + (t + (funcall doc-property + (widget-get widget :value))))) + (doc-text (and (stringp doc-try) + (> (length doc-try) 1) + doc-try))) + (when doc-text + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + ;; The `*' in the beginning is redundant. + (when (eq (aref doc-text 0) ?*) + (setq doc-text (substring doc-text 1))) + ;; Get rid of trailing newlines. + (when (string-match "\n+\\'" doc-text) + (setq doc-text (substring doc-text 0 (match-beginning 0)))) + (push (widget-create-child-and-convert + widget 'documentation-string + doc-text) + buttons)))) (t (error "Unknown escape `%c'" escape))) (widget-put widget :buttons buttons))) @@ -2476,7 +2532,7 @@ when he invoked the menu." (:foreground "dark green")) (t nil)) "Face used for documentation text." - :group 'widgets) + :group 'widget-faces) (define-widget 'documentation-string 'item "A documentation string." @@ -2488,11 +2544,11 @@ when he invoked the menu." (defun widget-documentation-string-value-create (widget) ;; Insert documentation string. (let ((doc (widget-value widget)) - (shown (widget-get (widget-get widget :parent) :documentation-shown))) + (shown (widget-get (widget-get widget :parent) :documentation-shown)) + (start (point))) (if (string-match "\n" doc) (let ((before (substring doc 0 (match-beginning 0))) (after (substring doc (match-beginning 0))) - (start (point)) buttons) (insert before " ") (widget-specify-doc widget start (point)) @@ -2507,7 +2563,8 @@ when he invoked the menu." (insert after) (widget-specify-doc widget start (point))) (widget-put widget :buttons buttons)) - (insert doc))) + (insert doc) + (widget-specify-doc widget start (point)))) (insert "\n")) (defun widget-documentation-string-action (widget &rest ignore) @@ -2666,6 +2723,41 @@ It will read a directory name from the minibuffer when invoked." :prompt-history 'widget-variable-prompt-value-history :tag "Variable") +(when (featurep 'mule) + (defvar widget-coding-system-prompt-value-history nil + "History of input to `widget-coding-system-prompt-value'.") + + (define-widget 'coding-system 'symbol + "A MULE coding-system." + :format "%{%t%}: %v" + :tag "Coding system" + :prompt-history 'widget-coding-system-prompt-value-history + :prompt-value 'widget-coding-system-prompt-value + :action 'widget-coding-system-action) + + (defun widget-coding-system-prompt-value (widget prompt value unbound) + ;; Read coding-system from minibuffer. + (intern + (completing-read (format "%s (default %s) " prompt value) + (mapcar (function + (lambda (sym) + (list (symbol-name sym)) + )) + (coding-system-list))))) + + (defun widget-coding-system-action (widget &optional event) + ;; Read a file name from the minibuffer. + (let ((answer + (widget-coding-system-prompt-value + widget + (widget-apply widget :menu-tag-get) + (widget-value widget) + t))) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup))) + ) + (define-widget 'sexp 'editable-field "An arbitrary lisp expression." :tag "Lisp expression" -- cgit v1.2.3