xemacs-beta: lisp/custom/cus-edit.el comparison

comparison lisp/custom/cus-edit.el @ 120:cca96a509cfe r20-1b12

Import from CVS: tag r20-1b12

author	cvs
date	Mon, 13 Aug 2007 09:25:29 +0200
parents	7d55a9ba150c
children	9b50b4588a93

comparison

equal deleted inserted replaced

-:d101af7320b8
+:cca96a509cfe
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: help, faces
-;; Version: 1.69
+;; Version: 1.74
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;;; Commentary:
 ;;
 ;; See `custom.el'.
 (define-widget-keywords :custom-prefixes :custom-menu :custom-show
 :custom-magic :custom-state :custom-level :custom-form
 :custom-set :custom-save :custom-reset-current :custom-reset-saved
 :custom-reset-factory)
+(put 'custom-define-hook 'custom-type 'hook)
+(put 'custom-define-hook 'factory-value '(nil))
+(custom-add-to-group 'customize 'custom-define-hook 'custom-variable)
 ;;; Customization Groups.
 (defgroup emacs nil
 "Customization of the One True Editor."
 	 (save-excursion
 	   (set-buffer (get-buffer-create " *Custom-Work*"))
 	   (erase-buffer)
 	   (princ symbol (current-buffer))
 	   (goto-char (point-min))
+	   (when (and (eq (get symbol 'custom-type) 'boolean)
+		      (re-search-forward "-p\\'" nil t))
+	     (replace-match "" t t)
+	     (goto-char (point-min)))
 	   (let ((prefixes custom-prefix-list)
 		 prefix)
 	     (while prefixes
 	       (setq prefix (car prefixes))
 	       (if (search-forward prefix (+ (point) (length prefix)) t)
 (defun custom-prefix-add (symbol prefixes)
 ;; Addd SYMBOL to list of ignored PREFIXES.
 (cons (or (get symbol 'custom-prefix)
 	    (concat (symbol-name symbol) "-"))
 	prefixes))
+(defcustom custom-guess-type-alist
+'(("-p\\'" boolean)
+("-hook\\'" hook)
+("-face\\'" face)
+("-file\\'" file)
+("-function\\'" function)
+("-functions\\'" (repeat function))
+("-list\\'" (repeat sexp))
+("-alist\\'" (repeat (cons sexp sexp))))
+"Alist of (MATCH TYPE).
+MATCH should be a regexp matching the name of a symbol, and TYPE should
+be a widget suitable for editing the value of that symbol.  The TYPE
+of the first entry where MATCH matches the name of the symbol will be
+used.
+This is used for guessing the type of variables not declared with
+customize."
+:type '(repeat (group regexp sexp))
+:group 'customize)
+(defun custom-guess-type (symbol)
+"Guess a widget suitable for editing the value of SYMBOL.
+This is done by matching SYMBOL with `custom-guess-type-alist'."
+(let ((name (symbol-name symbol))
+	(alist custom-guess-type-alist)
+	current found)
+(while alist
+(setq current (car alist)
+	    alist (cdr alist))
+(when (string-match (nth 0 current) name)
+	(setq found (nth 1 current)
+	      alist nil)))
+found))
 ;;; The Custom Mode.
 (defvar custom-options nil
 "Customization widgets in the current buffer.")
 (let ((found nil))
 	(message "Looking for faces...")
 	(mapcar (lambda (symbol)
 		  (setq found (cons (list symbol 'custom-face) found)))
 		(face-list))
-	(message "Creating customization buffer...")
 	(custom-buffer-create found))
 (if (stringp symbol)
 	(setq symbol (intern symbol)))
 (unless (symbolp symbol)
 (error "Should be a symbol %S" symbol))
 (defun custom-buffer-create (options)
 "Create a buffer containing OPTIONS.
 OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
 SYMBOL is a customization option, and WIDGET is a widget for editing
 that option."
+(message "Creating customization buffer...")
 (kill-buffer (get-buffer-create "*Customization*"))
 (switch-to-buffer (get-buffer-create "*Customization*"))
 (custom-mode)
 (widget-insert "This is a customization buffer.
 Push RET or click mouse-2 on the word ")
 		 :tag "help"
 		 :help-echo "Read the online help."
 		 "(custom)The Customization Buffer")
 (widget-insert " for more information.\n\n")
 (setq custom-options
-	(mapcar (lambda (entry)
+	(if (= (length options) 1)
-		  (prog1
+	    (mapcar (lambda (entry)
-		      (if (> (length options) 1)
+		      (widget-create (nth 1 entry)
-			  (widget-create (nth 1 entry)
+				     :custom-state 'unknown
+				     :tag (custom-unlispify-tag-name
+					   (nth 0 entry))
+				     :value (nth 0 entry)))
+		    options)
+	  (let ((count 0)
+		(length (length options)))
+	    (mapcar (lambda (entry)
+			(prog2
+			    (message "Creating customization items %2d%%..."
+				     (/ (* 100.0 count) length))
+			    (widget-create (nth 1 entry)
 					 :tag (custom-unlispify-tag-name
 					       (nth 0 entry))
 					 :value (nth 0 entry))
-			;; If there is only one entry, don't hide it!
+			  (setq count (1+ count))
-			(widget-create (nth 1 entry)
+			  (unless (eq (preceding-char) ?\n)
-				       :custom-state 'unknown
+			    (widget-insert "\n"))
-				       :tag (custom-unlispify-tag-name
+			  (widget-insert "\n")))
-					       (nth 0 entry))
+		      options))))
-				       :value (nth 0 entry)))
+(unless (eq (preceding-char) ?\n)
-		    (unless (eq (preceding-char) ?\n)
+(widget-insert "\n"))
-		      (widget-insert "\n"))
+(widget-insert "\n")
-		    (widget-insert "\n")))
+(message "Creating customization magic...")
-		options))
 (mapcar 'custom-magic-reset custom-options)
+(message "Creating customization buttons...")
 (widget-create 'push-button
 		 :tag "Set"
 		 :help-echo "Set all modifications for this session."
 		 :action (lambda (widget &optional event)
 			   (custom-set)))
 				    (next-command-event))
 			     ;; Emacs
 			     (when (memq 'down (event-modifiers event))
 			       (read-event)))))
 (widget-insert "\n")
+(message "Creating customization setup...")
 (widget-setup)
-(goto-char (point-min)))
+(goto-char (point-min))
+(message "Creating customization buffer...done"))
 ;;; Modification of Basic Widgets.
 ;;
 ;; We add extra properties to the basic widgets needed here.  This is
 ;; fine, as long as we are careful to stay within out own namespace.
 :custom-save 'custom-variable-save
 :custom-reset-current 'custom-redraw
 :custom-reset-saved 'custom-variable-reset-saved
 :custom-reset-factory 'custom-variable-reset-factory)
+(defun custom-variable-type (symbol)
+"Return a widget suitable for editing the value of SYMBOL.
+If SYMBOL has a `custom-type' property, use that.
+Otherwise, look up symbol in `custom-guess-type-alist'."
+(let* ((type (or (get symbol 'custom-type)
+		   (custom-guess-type symbol)
+		   'sexp))
+	 (options (get symbol 'custom-options))
+	 (tmp (if (listp type)
+		  (copy-list type)
+		(list type))))
+(when options
+(widget-put tmp :options options))
+tmp))
 (defun custom-variable-value-create (widget)
 "Here is where you edit the variables value."
 (custom-load-widget widget)
 (let* ((buttons (widget-get widget :buttons))
 	 (children (widget-get widget :children))
 	 (form (widget-get widget :custom-form))
 	 (state (widget-get widget :custom-state))
 	 (symbol (widget-get widget :value))
-	 (options (get symbol 'custom-options))
-	 (child-type (or (get symbol 'custom-type) 'sexp))
 	 (tag (widget-get widget :tag))
-	 (type (let ((tmp (if (listp child-type)
+	 (type (custom-variable-type symbol))
-			      (copy-list child-type)
-			    (list child-type))))
-		 (when options
-		   (widget-put tmp :options options))
-		 tmp))
 	 (conv (widget-convert type))
 	 (value (if (default-boundp symbol)
 		    (default-value symbol)
 		  (widget-get conv :value))))
 ;; If the widget is new, the child determine whether it is hidden.
 :help-echo "Set or reset this face."
 :documentation-property '(lambda (face)
 			     (face-doc-string face))
 :value-create 'custom-face-value-create
 :action 'custom-face-action
+:custom-form 'selected
 :custom-set 'custom-face-set
 :custom-save 'custom-face-save
 :custom-reset-current 'custom-redraw
 :custom-reset-saved 'custom-face-reset-saved
 :custom-reset-factory 'custom-face-reset-factory
 	   (custom-format-handler widget escape)))
 (when child
 (widget-put widget
 		  :buttons (cons child (widget-get widget :buttons))))))
+(define-widget 'custom-face-all 'editable-list
+"An editable list of display specifications and attributes."
+:entry-format "%i %d %v"
+:insert-button-args '(:help-echo "Insert new display specification here.")
+:append-button-args '(:help-echo "Append new display specification here.")
+:delete-button-args '(:help-echo "Delete this display specification.")
+:args '((group :format "%v" custom-display custom-face-edit)))
+(defconst custom-face-all (widget-convert 'custom-face-all)
+"Converted version of the `custom-face-all' widget.")
+(define-widget 'custom-display-unselected 'item
+"A display specification that doesn't match the selected display."
+:match 'custom-display-unselected-match)
+(defun custom-display-unselected-match (widget value)
+"Non-nil if VALUE is an unselected display specification."
+(and (listp value)
+(eq (length value) 2)
+(not (custom-display-match-frame value (selected-frame)))))
+(define-widget 'custom-face-selected 'group
+"Edit the attributes of the selected display in a face specification."
+:args '((repeat :format ""
+		  :inline t
+		  (group custom-display-unselected sexp))
+	  (group (sexp :format "") custom-face-edit)
+	  (repeat :format ""
+		  :inline t
+		  sexp)))
+(defconst custom-face-selected (widget-convert 'custom-face-selected)
+"Converted version of the `custom-face-selected' widget.")
 (defun custom-face-value-create (widget)
 ;; Create a list of the display specifications.
 (unless (eq (preceding-char) ?\n)
 (insert "\n"))
 (when (not (eq (widget-get widget :custom-state) 'hidden))
+(message "Creating face editor...")
 (custom-load-widget widget)
 (let* ((symbol (widget-value widget))
+	   (spec (or (get symbol 'saved-face)
+		     (get symbol 'factory-face)
+		     ;; Attempt to construct it.
+		     (list (list t (custom-face-attributes-get
+				    symbol (selected-frame))))))
+	   (form (widget-get widget :custom-form))
+	   (indent (widget-get widget :indent))
 	   (edit (widget-create-child-and-convert
-		  widget 'editable-list
+		  widget
-		  :entry-format "%i %d %v"
+		  (cond ((and (eq form 'selected)
-		  :value (or (get symbol 'saved-face)
+			      (widget-apply custom-face-selected :match spec))
-			     (get symbol 'factory-face)
+			 (when indent (insert-char ?\  indent))
-			     ;; Attempt to construct it.
+			 'custom-face-selected)
-			     (list (list t (custom-face-attributes-get
+			((and (not (eq form 'lisp))
-					    symbol (selected-frame)))))
+			      (widget-apply custom-face-all :match spec))
-		  :insert-button-args '(:help-echo "\
+			 'custom-face-all)
-Insert new display specification here.")
+			(t
-		  :append-button-args '(:help-echo "\
+			 (when indent (insert-char ?\  indent))
-Append new display specification here.")
+			 'sexp))
-		  :delete-button-args '(:help-echo "\
+		  :value spec)))
-Delete this display specification.")
-		  '(group :format "%v"
-			  custom-display custom-face-edit))))
 (custom-face-state-set widget)
-(widget-put widget :children (list edit)))))
+(widget-put widget :children (list edit)))
+(message "Creating face editor...done")))
 (defvar custom-face-menu
-'(("Set" . custom-face-set)
+'(("Edit Selected" . custom-face-edit-selected)
+("Edit All" . custom-face-edit-all)
+("Edit Lisp" . custom-face-edit-lisp)
+("Set" . custom-face-set)
 ("Save" . custom-face-save)
 ("Reset to Saved" . custom-face-reset-saved)
 ("Reset to Factory Setting" . custom-face-reset-factory))
 "Alist of actions for the `custom-face' widget.
 The key is a string containing the name of the action, the value is a
 lisp function taking the widget as an element which will be called
 when the action is chosen.")
+(defun custom-face-edit-selected (widget)
+"Edit selected attributes of the value of WIDGET."
+(widget-put widget :custom-state 'unknown)
+(widget-put widget :custom-form 'selected)
+(custom-redraw widget))
+(defun custom-face-edit-all (widget)
+"Edit all attributes of the value of WIDGET."
+(widget-put widget :custom-state 'unknown)
+(widget-put widget :custom-form 'all)
+(custom-redraw widget))
+(defun custom-face-edit-lisp (widget)
+"Edit the lisp representation of the value of WIDGET."
+(widget-put widget :custom-state 'unknown)
+(widget-put widget :custom-form 'lisp)
+(custom-redraw widget))
 (defun custom-face-state-set (widget)
 "Set the state of WIDGET."
 (let ((symbol (widget-value widget)))
 (widget-put widget :custom-state (cond ((get symbol 'customized-face)
 'custom-group-tag-face))
 (defun custom-group-value-create (widget)
 (let ((state (widget-get widget :custom-state)))
 (unless (eq state 'hidden)
+(message "Creating group...")
 (custom-load-widget widget)
 (let* ((level (widget-get widget :custom-level))
 	     (symbol (widget-value widget))
 	     (members (get symbol 'custom-group))
 	     (prefixes (widget-get widget :custom-prefixes))
 	     (custom-prefix-list (custom-prefix-add symbol prefixes))
+	     (length (length members))
+	     (count 0)
 	     (children (mapcar (lambda (entry)
 				 (widget-insert "\n")
+				 (message "Creating group members... %2d%%"
+					  (/ (* 100.0 count) length))
+				 (setq count (1+ count))
 				 (prog1
 				     (widget-create-child-and-convert
 				      widget (nth 1 entry)
 				      :group widget
 				      :tag (custom-unlispify-tag-name
 				      :custom-level (1+ level)
 				      :value (nth 0 entry))
 				   (unless (eq (preceding-char) ?\n)
 				     (widget-insert "\n"))))
 			       members)))
+	(message "Creating group magic...")
 	(mapcar 'custom-magic-reset children)
+	(message "Creating group state...")
 	(widget-put widget :children children)
-	(custom-group-state-update widget)))))
+	(custom-group-state-update widget)
+	(message "Creating group... done")))))
 (defvar custom-group-menu
 '(("Set" . custom-group-set)
 ("Save" . custom-group-save)
 ("Reset to Current" . custom-group-reset-current)
 			      (and (not (boundp symbol))
 				   (not (get symbol 'force-value))))
 			  (princ ")")
 			(princ " t)"))))))
 (princ ")")
-(unless (eolp)
+(unless (looking-at "\n")
 	(princ "\n")))))
 (defun custom-save-faces ()
 "Save all customized faces in `custom-file'."
 (save-excursion
 (custom-save-delete 'custom-set-faces)
 (let ((standard-output (current-buffer)))
 (unless (bolp)
 	(princ "\n"))
 (princ "(custom-set-faces")
+(let ((value (get 'default 'saved-face)))
+	;; The default face must be first, since it affects the others.
+	(when value
+	  (princ "\n '(default ")
+	  (prin1 value)
+	  (if (or (get 'default 'factory-face)
+		  (and (not (custom-facep 'default))
+		       (not (get 'default 'force-face))))
+	      (princ ")")
+	    (princ " t)"))))
 (mapatoms (lambda (symbol)
 		  (let ((value (get symbol 'saved-face)))
-		    (when value
+		    (when (and (not (eq symbol 'default))
+			       ;; Don't print default face here.
+			       value)
 		      (princ "\n '(")
 		      (princ symbol)
 		      (princ " ")
 		      (prin1 value)
 		      (if (or (get symbol 'factory-face)
 			      (and (not (custom-facep symbol))
 				   (not (get symbol 'force-face))))
 			  (princ ")")
 			(princ " t)"))))))
 (princ ")")
-(unless (eolp)
+(unless (looking-at "\n")
 	(princ "\n")))))
 ;;;###autoload
 (defun custom-save-all ()
 "Save all customizations in `custom-file'."
 (set-buffer (find-file-noselect custom-file))
 (save-buffer)))
 ;;; The Customize Menu.
-(defcustom custom-menu-nesting 2
+;;; Menu support
-"Maximum nesting in custom menus."
-:type 'integer
+(unless (string-match "XEmacs" emacs-version)
-:group 'customize)
+(defconst custom-help-menu '("Customize"
+			       ["Update menu..." custom-menu-update t]
+			       ["Group..." customize t]
+			       ["Variable..." customize-variable t]
+			       ["Face..." customize-face t]
+			       ["Saved..." customize-customized t]
+			       ["Apropos..." customize-apropos t])
+;; This menu should be identical to the one defined in `menu-bar.el'.
+"Customize menu")
+(defun custom-menu-reset ()
+"Reset customize menu."
+(remove-hook 'custom-define-hook 'custom-menu-reset)
+(define-key global-map [menu-bar help-menu customize-menu]
+(cons (car custom-help-menu)
+	    (easy-menu-create-keymaps (car custom-help-menu)
+				      (cdr custom-help-menu)))))
+(defun custom-menu-update (event)
+"Update customize menu."
+(interactive "e")
+(add-hook 'custom-define-hook 'custom-menu-reset)
+(let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs))
+	   (menu `(,(car custom-help-menu)
+		   ,emacs
+		   ,@(cdr (cdr custom-help-menu)))))
+(let ((map (easy-menu-create-keymaps (car menu) (cdr menu))))
+	(define-key global-map [menu-bar help-menu customize-menu]
+	  (cons (car menu) map)))))
+(defcustom custom-menu-nesting 2
+"Maximum nesting in custom menus."
+:type 'integer
+:group 'customize))
 (defun custom-face-menu-create (widget symbol)
 "Ignoring WIDGET, create a menu entry for customization face SYMBOL."
 (vector (custom-unlispify-menu-entry symbol)
 	  `(custom-buffer-create '((,symbol custom-face)))
 	(widget-apply type :custom-menu symbol)
 (vector (custom-unlispify-menu-entry symbol)
 	      `(custom-buffer-create '((,symbol custom-variable)))
 	      t))))
+;; Add checkboxes to boolean variable entries.
 (widget-put (get 'boolean 'widget-type)
 	    :custom-menu (lambda (widget symbol)
 			   (vector (custom-unlispify-menu-entry symbol)
 				   `(custom-buffer-create
 				     '((,symbol custom-variable)))
 "Ignoring WIDGET, create a menu entry for customization group SYMBOL."
 ;; Limit the nesting.
 (let ((custom-menu-nesting (1- custom-menu-nesting)))
 (custom-menu-create symbol))))
+;;;###autoload
 (defun custom-menu-create (symbol &optional name)
 "Create menu for customization group SYMBOL.
 If optional NAME is given, use that as the name of the menu.
 Otherwise make up a name from SYMBOL.
 The menu is in a format applicable to `easy-menu-define'."
 (unless name
 (setq name (custom-unlispify-menu-entry symbol)))
 (let ((item (vector name
 		      `(custom-buffer-create '((,symbol custom-group)))
 		      t)))
-(if (and (>= custom-menu-nesting 0)
+(if (and (or (not (boundp 'custom-menu-nesting))
+		 (>= custom-menu-nesting 0))
 	     (< (length (get symbol 'custom-group)) widget-menu-max-size))
 	(let ((custom-prefix-list (custom-prefix-add symbol
 						     custom-prefix-list)))
 	  (custom-load-symbol symbol)
 	  `(,(custom-unlispify-menu-entry symbol t)
 					  (nth 1 entry)
 					(list (nth 1 entry)))
 				      :custom-menu (nth 0 entry)))
 		      (get symbol 'custom-group))))
 item)))
-;;;###autoload
-(defun custom-menu-update (event)
-"Update customize menu."
-(interactive "e")
-(add-hook 'custom-define-hook 'custom-menu-reset)
-(let* ((emacs (widget-apply '(custom-group) :custom-menu 'emacs))
-	 (menu `(,(car custom-help-menu)
-		 ,emacs
-		 ,@(cdr (cdr custom-help-menu)))))
-(let ((map (easy-menu-create-keymaps (car menu) (cdr menu))))
-(define-key global-map [menu-bar help-menu customize-menu]
-	(cons (car menu) map)))))
 ;;; Dependencies.
 ;;;###autoload
 (defun custom-make-dependencies ()

Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-edit.el @ 120:cca96a509cfe r20-1b12