From: Dave Love Date: Wed, 17 Jan 2001 20:37:48 +0000 (+0000) Subject: Merge with HEAD. X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=03df2794f38ab82d215f34ac629909ba0d41e4b3;p=emacs.git Merge with HEAD. --- diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index a90b1204fba..08689d2747a 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1297,7 +1297,15 @@ Un-customize all values in this buffer. They get their standard settings." (widget-insert " ") (widget-create 'push-button :tag "Finish" - :help-echo "Bury or kill the buffer." + :help-echo + (lambda (&rest ignore) + (cond + ((eq custom-buffer-done-function + 'custom-bury-buffer) + "Bury this buffer") + ((eq custom-buffer-done-function 'kill-buffer) + "Kill this buffer") + (t "Finish with this buffer"))) :action #'Custom-buffer-done) (widget-insert "\n\n") (message "Creating customization items...") @@ -1315,18 +1323,18 @@ Un-customize all values in this buffer. They get their standard settings." (let ((count 0) (length (length options))) (mapcar (lambda (entry) - (prog2 - (message "Creating customization items ...%2d%%" - (/ (* 100.0 count) length)) - (widget-create (nth 1 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)) - (setq count (1+ count)) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (widget-insert "\n"))) - options)))) + (setq count (1+ count)) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n"))) + options)))) (unless (eq (preceding-char) ?\n) (widget-insert "\n")) (message "Creating customization items ...%2d%%done" 100) @@ -2386,7 +2394,7 @@ Optional EVENT is the location for the menu." (error "Cannot set hidden variable")) ((setq val (widget-apply child :validate)) (goto-char (widget-get val :from)) - (error "%s" (widget-get val :error))) + (error "Saving %s: %s" symbol (widget-get val :error))) ((memq form '(lisp mismatch)) (when (equal comment "") (setq comment nil) @@ -2617,6 +2625,57 @@ Match frames with dark backgrounds.") (defconst custom-face-selected (widget-convert 'custom-face-selected) "Converted version of the `custom-face-selected' widget.") +(defun custom-filter-face-spec (spec filter-index default-filter) + "Return a canonicalized version of SPEC using. +FILTER-INDEX is the index in the entry for each attribute in +`custom-face-attributes' at which the appropriate filter function can be +found, and DEFAULT-FILTER is the filter to apply for attributes that +don't specify one." + (mapcar (lambda (entry) + ;; Filter a single face-spec entry + (let ((tests (car entry)) + (unfiltered-attrs + ;; Handle both old- and new-style attribute syntax + (if (listp (car (cdr entry))) + (car (cdr entry)) + (cdr entry))) + (filtered-attrs nil)) + ;; Filter each face attribute + (while unfiltered-attrs + (let* ((attr (pop unfiltered-attrs)) + (pre-filtered-value (pop unfiltered-attrs)) + (filter + (or (nth filter-index (assq attr custom-face-attributes)) + default-filter)) + (filtered-value + (if filter + (funcall filter pre-filtered-value) + pre-filtered-value))) + (push filtered-value filtered-attrs) + (push attr filtered-attrs))) + ;; + (list tests filtered-attrs))) + spec)) + +(defun custom-pre-filter-face-spec (spec) + "Return SPEC changed as necessary for editing by the face customization widget. +SPEC must be a full face spec." + (custom-filter-face-spec + spec 2 + (lambda (value) + (cond ((eq value 'unspecified) nil) + ((eq value nil) 'off) + (t value))))) + +(defun custom-post-filter-face-spec (spec) + "Return the customized SPEC in a form suitable for setting the face." + (custom-filter-face-spec + spec 3 + (lambda (value) + (cond ((eq value nil) 'unspecified) + ((eq value 'off) nil) + (t value))))) + (defun custom-face-value-create (widget) "Create a list of the display specifications for WIDGET." (let ((buttons (widget-get widget :buttons)) @@ -2639,10 +2698,12 @@ Match frames with dark backgrounds.") (t ;; Create tag. (insert tag) + (widget-specify-sample widget begin (point)) (if (eq custom-buffer-style 'face) (insert " ") - (widget-specify-sample widget begin (point)) - (insert ": ")) + (if (string-match "face\\'" tag) + (insert ":") + (insert " face: "))) ;; Sample. (push (widget-create-child-and-convert widget 'item :format "(%{%t%})" @@ -2703,6 +2764,7 @@ Match frames with dark backgrounds.") ;; edit it as the user has specified it. (if (not (face-spec-match-p symbol spec (selected-frame))) (setq spec (list (list t (face-attr-construct symbol (selected-frame)))))) + (setq spec (custom-pre-filter-face-spec spec)) (setq edit (widget-create-child-and-convert widget (cond ((and (eq form 'selected) @@ -2816,7 +2878,7 @@ Optional EVENT is the location for the menu." "Make the face attributes in WIDGET take effect." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) - (value (widget-value child)) + (value (custom-post-filter-face-spec (widget-value child))) (comment-widget (widget-get widget :comment-widget)) (comment (widget-value comment-widget))) (when (equal comment "") @@ -2824,7 +2886,11 @@ Optional EVENT is the location for the menu." ;; Make the comment invisible by hand if it's empty (custom-comment-hide comment-widget)) (put symbol 'customized-face value) - (face-spec-set symbol value) + (if (face-spec-choose value) + (face-spec-set symbol value) + ;; face-set-spec ignores empty attribute lists, so just give it + ;; something harmless instead. + (face-spec-set symbol '((t :foreground unspecified)))) (put symbol 'customized-face-comment comment) (put symbol 'face-comment comment) (custom-face-state-set widget) @@ -2911,7 +2977,7 @@ restoring it to the state of a face that has never been customized." :convert-widget 'widget-value-convert-widget :button-prefix 'widget-push-button-prefix :button-suffix 'widget-push-button-suffix - :format "%t: %[select face%] %v" + :format "%{%t%}: %[select face%] %v" :tag "Face" :value 'default :value-create 'widget-face-value-create @@ -3487,7 +3553,7 @@ or (if there were none) at the end of the buffer." (princ "\n")) (princ "(custom-set-variables ;; custom-set-variables was added by Custom -- don't edit or cut/paste it! - ;; Your init file must only contain one such instance.\n") + ;; Your init file should contain only one such instance.\n") (mapcar (lambda (symbol) (let ((spec (car-safe (get symbol 'theme-value))) @@ -3558,7 +3624,7 @@ or (if there were none) at the end of the buffer." (princ "\n")) (princ "(custom-set-faces ;; custom-set-faces was added by Custom -- don't edit or cut/paste it! - ;; Your init file must only contain one such instance.\n") + ;; Your init file should contain only one such instance.\n") (mapcar (lambda (symbol) (let ((theme-spec (car-safe (get symbol 'theme-face))) @@ -3757,14 +3823,9 @@ Otherwise the menu will be named `Customize'. The format is suitable for use with `easy-menu-define'." (unless name (setq name "Customize")) - ;; Fixme: sort out use of :filter in Emacs 21. - (if nil ;(string-match "XEmacs" emacs-version) - ;; We can delay it under XEmacs. - `(,name - :filter (lambda (&rest junk) - (cdr (custom-menu-create ',symbol)))) - ;; But we must create it now under Emacs. - (cons name (cdr (custom-menu-create symbol))))) + `(,name + :filter (lambda (&rest junk) + (custom-menu-create ',symbol)))) ;;; The Custom Mode. diff --git a/lisp/cus-face.el b/lisp/cus-face.el index b51ba8fee66..8d61ebddb2a 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -1,6 +1,6 @@ ;;; cus-face.el -- customization support for faces. ;; -;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -73,12 +73,7 @@ (choice :tag "Font family" :help-echo "Font family or fontset alias name." (const :tag "*" nil) - (string :tag "Family")) - (lambda (face value &optional frame) - (set-face-attribute face frame :family (or value 'unspecified))) - (lambda (face &optional frame) - (let ((family (face-attribute face :family frame))) - (if (eq family 'unspecified) nil family)))) + (string :tag "Family"))) (:width (choice :tag "Width" @@ -98,18 +93,14 @@ (const :tag "semiexpanded" semi-expanded) (const :tag "ultracondensed" ultra-condensed) (const :tag "ultraexpanded" ultra-expanded) - (const :tag "wide" extra-expanded)) - (lambda (face value &optional frame) - (set-face-attribute face frame :width (or value 'unspecified))) - (lambda (face &optional frame) - (let ((width (face-attribute face :width frame))) - (if (eq width 'unspecified) nil width)))) + (const :tag "wide" extra-expanded))) (:height (choice :tag "Height" :help-echo "Face's font height." (const :tag "*" nil) - (integer :tag "Height in 1/10 pt")) + (integer :tag "Height in 1/10 pt") + (number :tag "Scale" 1.0)) (lambda (face value &optional frame) (set-face-attribute face frame :height (or value 'unspecified))) (lambda (face &optional frame) @@ -134,12 +125,7 @@ (const :tag "semibold" semi-bold) (const :tag "semilight" semi-light) (const :tag "ultralight" ultra-light) - (const :tag "ultrabold" ultra-bold)) - (lambda (face value &optional frame) - (set-face-attribute face frame :weight (or value 'unspecified))) - (lambda (face &optional frame) - (let ((weight (face-attribute face :weight frame))) - (if (eq weight 'unspecified) nil weight)))) + (const :tag "ultrabold" ultra-bold))) (:slant (choice :tag "Slant" @@ -147,12 +133,7 @@ (const :tag "*" nil) (const :tag "italic" italic) (const :tag "oblique" oblique) - (const :tag "normal" normal)) - (lambda (face value &optional frame) - (set-face-attribute face frame :slant (or value 'unspecified))) - (lambda (face &optional frame) - (let ((slant (face-attribute face :slant frame))) - (if (eq slant 'unspecified) nil slant)))) + (const :tag "normal" normal))) (:underline (choice :tag "Underline" @@ -160,15 +141,7 @@ (const :tag "*" nil) (const :tag "On" t) (const :tag "Off" off) - (color :tag "Colored")) - (lambda (face value &optional frame) - (cond ((eq value 'off) (setq value nil)) - ((null value) (setq value 'unspecified))) - (set-face-attribute face frame :underline value)) - (lambda (face &optional frame) - (let ((underline (face-attribute face :underline frame))) - (cond ((eq underline 'unspecified) nil) - ((null underline) 'off))))) + (color :tag "Colored"))) (:overline (choice :tag "Overline" @@ -176,15 +149,7 @@ (const :tag "*" nil) (const :tag "On" t) (const :tag "Off" off) - (color :tag "Colored")) - (lambda (face value &optional frame) - (cond ((eq value 'off) (setq value nil)) - ((null value) (setq value 'unspecified))) - (set-face-attribute face frame :overline value)) - (lambda (face &optional frame) - (let ((overline (face-attribute face :overline frame))) - (cond ((eq overline 'unspecified) nil) - ((null overline) 'off))))) + (color :tag "Colored"))) (:strike-through (choice :tag "Strike-through" @@ -192,26 +157,16 @@ (const :tag "*" nil) (const :tag "On" t) (const :tag "Off" off) - (color :tag "Colored")) - (lambda (face value &optional frame) - (cond ((eq value 'off) (setq value nil)) - ((null value) (setq value 'unspecified))) - (set-face-attribute face frame :strike-through value)) - (lambda (face &optional frame) - (let ((value (face-attribute face :strike-through frame))) - (cond ((eq value 'unspecified) (setq value nil)) - ((null value) (setq value 'off))) - value))) + (color :tag "Colored"))) (:box ;; Fixme: this can probably be done better. (choice :tag "Box around text" :help-echo "Control box around text." - (const :tag "*" t) - (const :tag "Off" nil) + (const :tag "*" nil) + (const :tag "Off" off) (list :tag "Box" - :value (:line-width 2 :color "grey75" - :style released-button) + :value (:line-width 2 :color "grey75" :style released-button) (const :format "" :value :line-width) (integer :tag "Width") (const :format "" :value :color) @@ -221,75 +176,104 @@ (const :tag "Raised" released-button) (const :tag "Sunken" pressed-button) (const :tag "None" nil)))) - (lambda (face value &optional frame) - (set-face-attribute face frame :box value)) - (lambda (face &optional frame) - (let ((value (face-attribute face :box frame))) - (if (consp value) - (list :line-width (or (plist-get value :line-width) 1) - :color (plist-get value :color) - :style (plist-get value :style)) - value)))) + ;; filter to make value suitable for customize + (lambda (real-value) + (if (null real-value) + 'off + (let ((lwidth + (or (and (consp real-value) (plist-get real-value :line-width)) + (and (integerp real-value) real-value) + 1)) + (color + (or (and (consp real-value) (plist-get real-value :color)) + (and (stringp real-value) real-value) + nil)) + (style + (and (consp real-value) (plist-get real-value :style)))) + (list :line-width lwidth :color color :style style)))) + ;; filter to make customized-value suitable for storing + (lambda (cus-value) + (cond ((null cus-value) + 'unspecified) + ((eq cus-value 'off) + nil) + (t + (let ((lwidth (plist-get cus-value :line-width)) + (color (plist-get cus-value :color)) + (style (plist-get cus-value :style))) + (cond ((and (null color) (null style)) + lwidth) + ((and (null lwidth) (null style)) + ;; actually can't happen, because LWIDTH is always an int + color) + (t + ;; Keep as a plist, but remove null entries + (nconc (and lwidth `(:line-width ,lwidth)) + (and color `(:color ,color)) + (and style `(:style ,style)))))))))) (:inverse-video (choice :tag "Inverse-video" :help-echo "Control whether text should be in inverse-video." (const :tag "*" nil) (const :tag "On" t) - (const :tag "Off" off)) - (lambda (face value &optional frame) - (cond ((eq value 'off) (setq value nil)) - ((null value) (setq value 'unspecified))) - (set-face-attribute face frame :inverse-video value)) - (lambda (face &optional frame) - (let ((value (face-attribute face :inverse-video frame))) - (cond ((eq value 'unspecified) - nil) - ((null value)'off))))) + (const :tag "Off" off))) (:foreground (choice :tag "Foreground" :help-echo "Set foreground color." (const :tag "*" nil) - (color :tag "Color")) - (lambda (face value &optional frame) - (set-face-attribute face frame :foreground (or value 'unspecified))) - (lambda (face &optional frame) - (let ((value (face-attribute face :foreground frame))) - (if (eq value 'unspecified) nil value)))) + (color :tag "Color"))) (:background (choice :tag "Background" :help-echo "Set background color." (const :tag "*" nil) - (color :tag "Color")) - (lambda (face value &optional frame) - (set-face-attribute face frame :background (or value 'unspecified))) - (lambda (face &optional frame) - (let ((value (face-attribute face :background frame))) - (if (eq value 'unspecified) nil value)))) + (color :tag "Color"))) (:stipple (choice :tag "Stipple" - :help-echo "Name of background bitmap file." + :help-echo "Background bit-mask" (const :tag "*" nil) - (file :tag "File" :must-match t)) - (lambda (face value &optional frame) - (set-face-attribute face frame :stipple (or value 'unspecified))) - (lambda (face &optional frame) - (let ((value (face-attribute face :stipple frame))) - (if (eq value 'unspecified) nil value))))) + (const :tag "None" off) + (file :tag "File" + :help-echo "Name of bitmap file." + :must-match t))) + + (:inherit + (repeat :tag "Inherit" + :help-echo "List of faces to inherit attributes from." + (face :Tag "Face" default)) + ;; filter to make value suitable for customize + (lambda (real-value) + (cond ((or (null real-value) (eq real-value 'unspecified)) + nil) + ((symbolp real-value) + (list real-value)) + (t + real-value))) + ;; filter to make customized-value suitable for storing + (lambda (cus-value) + (if (and (consp cus-value) (null (cdr cus-value))) + (car cus-value) + cus-value)))) "Alist of face attributes. -The elements are of the form (KEY TYPE SET GET), where KEY is the name -of the attribute, TYPE is a widget type for editing the attibute, SET -is a function for setting the attribute value, and GET is a function -for getting the attribute value. +The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER), +where KEY is the name of the attribute, TYPE is a widget type for +editing the attribute, PRE-FILTER is a function to make the attribute's +value suitable for the customization widget, and POST-FILTER is a +function to make the customized value suitable for storing. PRE-FILTER +and POST-FILTER are optional. + +The PRE-FILTER should take a single argument, the attribute value as +stored, and should return a value for customization (using the +customization type TYPE). -The SET function should take three arguments, the face to modify, the -value of the attribute, and optionally the frame where the face should -be changed. +The POST-FILTER should also take a single argument, the value after +being customized, and should return a value suitable for setting the +given face attribute.") The GET function should take two arguments, the face to examine, and optionally the frame where the face should be examined.")