Mercurial > hg > xemacs-beta
diff lisp/cus-edit.el @ 4434:7f3d065a56a1
Ease customization of faces under point...
... by providing an optional prefix argument to customize-face[-other-window].
author | Didier Verna <didier@xemacs.org> |
---|---|
date | Wed, 05 Mar 2008 10:41:54 +0100 |
parents | 12ff8dc2b57e |
children | 877ad4697eea |
line wrap: on
line diff
--- a/lisp/cus-edit.el Wed Mar 05 01:12:53 2008 -0800 +++ b/lisp/cus-edit.el Wed Mar 05 10:41:54 2008 +0100 @@ -1,6 +1,6 @@ ;;; cus-edit.el --- Tools for customizating Emacs and Lisp packages. ;; -;; Copyright (C) 2007 Didier Verna +;; Copyright (C) 2007, 2008 Didier Verna ;; Copyright (C) 2003 Ben Wing ;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc. ;; @@ -836,7 +836,7 @@ (and version (or (null since-version) (customize-version-lessp since-version - version)))) + version)))) (push (list symbol 'custom-variable) found)))) (unless found (error "No user options have changed defaults %s" @@ -870,39 +870,86 @@ (list (list symbol 'custom-variable)) (format "*Customize Option: %s*" (custom-unlispify-tag-name symbol)))) -;;;###autoload -(defun customize-face (&optional symbol) - "Customize SYMBOL, which should be a face name or nil. -If SYMBOL is nil, customize all faces." - (interactive (list (completing-read "Customize face: (default all) " - obarray 'find-face))) - (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) - (custom-buffer-create (custom-sort-items - (mapcar (lambda (symbol) - (list symbol 'custom-face)) - (face-list)) - t nil) - "*Customize Faces*") - (when (stringp symbol) - (setq symbol (intern symbol))) - (check-argument-type 'symbolp symbol) - (custom-buffer-create (list (list symbol 'custom-face)) - (format "*Customize Face: %s*" - (custom-unlispify-tag-name symbol))))) + +(defun custom-face-prompt () + ;; Interactive call for `customize-face' and `customize-face-other-window'. + ;; See their docstrings for more information. Note that this call returns a + ;; list of only one element. This is because the callers'second arg AT-POINT + ;; is only used in interactive calls. + (let ((faces (get-char-property (point) 'face))) + (if (or (null faces) (not current-prefix-arg)) + ;; The default behavior, which is to prompt for all faces, is also + ;; used as a fall back when a prefix is given but there's no face + ;; under point: + (let ((choice (completing-read "Customize face: (default all) " + obarray 'find-face))) + (if (zerop (length choice)) + nil + (list (intern choice)))) + (cond ((symbolp faces) + ;; Customize only this one: + (list (list faces))) + ((listp faces) + ;; Make a choice only amongst the faces under point: + (let ((choice (completing-read + "Customize face: (default all faces at point) " + (mapcar (lambda (face) + (list (symbol-name face) face)) + faces) + nil t))) + (if (zerop (length choice)) + (list faces) + (list (intern choice))))))))) + +(defun customize-face-1 (face custom-buffer-create-fn) + ;; Customize FACE in a buffer created with BUFFER-CREATE-FN. + ;; See the docstring of `customize-face' and `customize-face-other-window' + ;; for more information. + (cond ((null face) + (funcall custom-buffer-create-fn + (custom-sort-items + (mapcar (lambda (symbol) + (list symbol 'custom-face)) + (face-list)) + t nil) + "*Customize All Faces*")) + ((listp face) + (funcall custom-buffer-create-fn + (custom-sort-items + (mapcar (lambda (symbol) + (list symbol 'custom-face)) + face) + t nil) + "*Customize Some Faces*")) + ((symbolp face) + (funcall custom-buffer-create-fn + (list (list face 'custom-face)) + (format "*Customize Face: %s*" + (custom-unlispify-tag-name face)))) + (t + (signal-error 'wrong-type-argument + '((or null listp symbolp) face))))) + ;;;###autoload -(defun customize-face-other-window (&optional symbol) - "Show customization buffer for FACE in other window." - (interactive (list (completing-read "Customize face: " - obarray 'find-face))) - (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) - () - (if (stringp symbol) - (setq symbol (intern symbol))) - (check-argument-type 'symbolp symbol) - (custom-buffer-create-other-window - (list (list symbol 'custom-face)) - (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol))))) +(defun customize-face (&optional face at-point) + "Open a customization buffer for FACE. +FACE should be either: +- nil, meaning to customize all faces, +- a list of symbols naming faces, meaning to customize only those, +- a symbol naming a face, meaning to customize this face only. + +When called interactively, use a prefix (the AT-POINT argument) to +make a choice among the faces found at current position." + (interactive (custom-face-prompt)) + (customize-face-1 face #'custom-buffer-create)) + +;;;###autoload +(defun customize-face-other-window (&optional face at-point) + "Like `customize-face', but use another window." + (interactive (custom-face-prompt)) + (customize-face-1 face #'custom-buffer-create-other-window)) + ;;;###autoload (defun customize-customized () @@ -2207,35 +2254,35 @@ (defvar custom-variable-menu `(("Set for Current Session" custom-variable-set ,#'(lambda (widget) - (eq (widget-get widget :custom-state) 'modified))) + (eq (widget-get widget :custom-state) 'modified))) ("Save for Future Sessions" custom-variable-save ,#'(lambda (widget) - (memq (widget-get widget :custom-state) - '(modified set changed rogue)))) + (memq (widget-get widget :custom-state) + '(modified set changed rogue)))) ("Reset to Current" custom-redraw ,#'(lambda (widget) - (and (default-boundp (widget-value widget)) - (memq (widget-get widget :custom-state) '(modified changed))))) + (and (default-boundp (widget-value widget)) + (memq (widget-get widget :custom-state) '(modified changed))))) ("Reset to Saved" custom-variable-reset-saved ,#'(lambda (widget) - (and (or (get (widget-value widget) 'saved-value) - (get (widget-value widget) 'saved-variable-comment)) - (memq (widget-get widget :custom-state) - '(modified set changed rogue))))) + (and (or (get (widget-value widget) 'saved-value) + (get (widget-value widget) 'saved-variable-comment)) + (memq (widget-get widget :custom-state) + '(modified set changed rogue))))) ("Reset to Standard Settings" custom-variable-reset-standard ,#'(lambda (widget) - (and (get (widget-value widget) 'standard-value) - (memq (widget-get widget :custom-state) - '(modified set changed saved rogue))))) + (and (get (widget-value widget) 'standard-value) + (memq (widget-get widget :custom-state) + '(modified set changed saved rogue))))) ("---" ignore ignore) ("Add Comment" custom-comment-show custom-comment-invisible-p) ("---" ignore ignore) ("Don't show as Lisp expression" custom-variable-edit ,#'(lambda (widget) - (eq (widget-get widget :custom-form) 'lisp))) + (eq (widget-get widget :custom-form) 'lisp))) ("Show as Lisp expression" custom-variable-edit-lisp ,#'(lambda (widget) - (eq (widget-get widget :custom-form) 'edit)))) + (eq (widget-get widget :custom-form) 'edit)))) "Alist of actions for the `custom-variable' widget. Each entry has the form (NAME ACTION FILTER) where NAME is the name of the menu entry, ACTION is the function to call on the widget when the @@ -2701,23 +2748,23 @@ ("Save for Future Sessions" custom-face-save) ("Reset to Saved" custom-face-reset-saved ,#'(lambda (widget) - (or (get (widget-value widget) 'saved-face) - (get (widget-value widget) 'saved-face-comment)))) + (or (get (widget-value widget) 'saved-face) + (get (widget-value widget) 'saved-face-comment)))) ("Reset to Standard Setting" custom-face-reset-standard ,#'(lambda (widget) - (get (widget-value widget) 'face-defface-spec))) + (get (widget-value widget) 'face-defface-spec))) ("---" ignore ignore) ("Add Comment" custom-comment-show custom-comment-invisible-p) ("---" ignore ignore) ("Show all display specs" custom-face-edit-all ,#'(lambda (widget) - (not (eq (widget-get widget :custom-form) 'all)))) + (not (eq (widget-get widget :custom-form) 'all)))) ("Just current attributes" custom-face-edit-selected ,#'(lambda (widget) - (not (eq (widget-get widget :custom-form) 'selected)))) + (not (eq (widget-get widget :custom-form) 'selected)))) ("Show as Lisp expression" custom-face-edit-lisp ,#'(lambda (widget) - (not (eq (widget-get widget :custom-form) 'lisp))))) + (not (eq (widget-get widget :custom-form) 'lisp))))) "Alist of actions for the `custom-face' widget. Each entry has the form (NAME ACTION FILTER) where NAME is the name of the menu entry, ACTION is the function to call on the widget when the @@ -3341,19 +3388,19 @@ (defvar custom-group-menu `(("Set for Current Session" custom-group-set ,#'(lambda (widget) - (eq (widget-get widget :custom-state) 'modified))) + (eq (widget-get widget :custom-state) 'modified))) ("Save for Future Sessions" custom-group-save ,#'(lambda (widget) - (memq (widget-get widget :custom-state) '(modified set)))) + (memq (widget-get widget :custom-state) '(modified set)))) ("Reset to Current" custom-group-reset-current ,#'(lambda (widget) - (memq (widget-get widget :custom-state) '(modified)))) + (memq (widget-get widget :custom-state) '(modified)))) ("Reset to Saved" custom-group-reset-saved ,#'(lambda (widget) - (memq (widget-get widget :custom-state) '(modified set)))) + (memq (widget-get widget :custom-state) '(modified set)))) ("Reset to standard setting" custom-group-reset-standard ,#'(lambda (widget) - (memq (widget-get widget :custom-state) '(modified set saved))))) + (memq (widget-get widget :custom-state) '(modified set saved))))) "Alist of actions for the `custom-group' widget. Each entry has the form (NAME ACTION FILTER) where NAME is the name of the menu entry, ACTION is the function to call on the widget when the @@ -3767,12 +3814,12 @@ (custom-save-faces) (let ((find-file-hooks nil) (auto-mode-alist) - custom-file-directory) - (unless (file-directory-p (setq custom-file-directory - (file-name-directory custom-file))) - (message "Creating %s... " custom-file-directory) - (make-directory custom-file-directory t) - (message "Creating %s... done." custom-file-directory)) + custom-file-directory) + (unless (file-directory-p (setq custom-file-directory + (file-name-directory custom-file))) + (message "Creating %s... " custom-file-directory) + (make-directory custom-file-directory t) + (message "Creating %s... done." custom-file-directory)) (with-current-buffer (find-file-noselect custom-file) (save-buffer)))))