Mercurial > emacs

changeset 18244:909a0f9169b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Synched with 1.9914.
author Per Abrahamsen <abraham@dina.kvl.dk>
date Sat, 14 Jun 1997 10:21:01 +0000
parents 7ebbc72852df
children 045ae402e927
files lisp/cus-edit.el lisp/wid-browse.el lisp/wid-edit.el
diffstat 3 files changed, 220 insertions(+), 97 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/cus-edit.el	Sat Jun 14 06:33:29 1997 +0000
+++ b/lisp/cus-edit.el	Sat Jun 14 10:21:01 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; 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 @@
 
 (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 @@
 
 (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 @@
 
 ;;; 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 (const :tag "Unsorted" ignore)
+		(const :tag "Alphabetic" custom-sort-items-alphabetically)
+		(function :tag "Other"))
+  :group 'custom-buffer)
+
+(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 (function-item custom-buffer-sort-alphabetically)
+  :type '(radio (const :tag "Groups first" custom-sort-groups-first)
+		(const :tag "Groups last" custom-sort-groups-last)
 		(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-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 (const :tag "Unsorted" ignore)
+		(const :tag "Alphabetic" custom-sort-items-alphabetically)
+		(function :tag "Other"))
+  :group 'custom-menu)
 
-(defcustom custom-menu-sort-predicate 'custom-menu-sort-alphabetically
+(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 (function-item custom-menu-sort-alphabetically)
+  :type '(radio (const :tag "Groups first" custom-sort-groups-first)
+		(const :tag "Groups last" custom-sort-groups-last)
 		(function :tag "Other"))
-  :group 'customize)
+  :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-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))))))
+(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 @@
   "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 @@
 
 ;;; 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 @@
   :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 @@
 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 @@
       (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 @@
 				   (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 @@
 (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 @@
 	     (< (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 @@
 (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.
--- a/lisp/wid-browse.el	Sat Jun 14 06:33:29 1997 +0000
+++ b/lisp/wid-browse.el	Sat Jun 14 10:21:01 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; 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 @@
   (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)))
--- a/lisp/wid-edit.el	Sat Jun 14 06:33:29 1997 +0000
+++ b/lisp/wid-edit.el	Sat Jun 14 10:21:01 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; 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 @@
 		   "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 @@
 			     (t 
 			      (:italic t)))
   "Face used for editable fields."
-  :group 'widgets)
+  :group 'widget-faces)
 
 ;;; Utility functions.
 ;;
@@ -347,14 +351,15 @@
 				(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 @@
 	  (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 @@
     (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 @@
     (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 @@
 	    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 @@
 
 (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 @@
 
 (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 @@
 				      (: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 @@
 (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 @@
 	    (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 @@
   :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"