X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/51a1edab455583e9aa943e69a96092bd934a7950..185a53bbe73a5f0c02cdb4df132c3c0e44b6c669:/lisp/cus-face.el diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 62f5cb57a8..33c8c995a4 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -1,10 +1,9 @@ -;;; cus-face.el -- customization support for faces. +;;; cus-face.el --- customization support for faces ;; -;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: Emacs ;; This file is part of GNU Emacs. @@ -37,23 +36,21 @@ (defun custom-declare-face (face spec doc &rest args) "Like `defface', but FACE is evaluated as a normal argument." (unless (get face 'face-defface-spec) - (put face 'face-defface-spec spec) (when (fboundp 'facep) (unless (facep face) ;; If the user has already created the face, respect that. - (let ((value (or (get face 'saved-face) spec)) - (frames (frame-list)) - frame) + (let ((value (or (get face 'saved-face) spec))) ;; Create global face. (make-empty-face face) - ;; Create frame local faces - (while frames - (setq frame (car frames) - frames (cdr frames)) + ;; Create frame-local faces + (dolist (frame (frame-list)) (face-spec-set face value frame))) ;; When making a face after frames already exist (if (memq window-system '(x w32)) (make-face-x-resource-internal face)))) + ;; Don't record SPEC until we see it causes no errors. + (put face 'face-defface-spec spec) + (push (cons 'defface face) current-load-list) (when (and doc (null (face-documentation face))) (set-face-documentation face (purecopy doc))) (custom-handle-all-keywords face args 'custom-face) @@ -62,23 +59,15 @@ ;;; Face attributes. -;; Below, nil is used in widget specifications for `unspecified' face -;; attributes and `off' is used instead of nil attribute values. The -;; reason for this is that nil corresponds to the result you get when -;; looking up an attribute in a defface spec that isn't contained in -;; the spec. - (defconst custom-face-attributes '((:family - (choice :tag "Font family" - :help-echo "Font family or fontset alias name." - (const :tag "*" nil) - (string :tag "Family"))) - + (string :tag "Font Family" + :help-echo "Font family or fontset alias name.")) + (:width (choice :tag "Width" :help-echo "Font width." - (const :tag "*" nil) + :value normal ; default (const :tag "compressed" condensed) (const :tag "condensed" condensed) (const :tag "demiexpanded" semi-expanded) @@ -94,19 +83,19 @@ (const :tag "ultracondensed" ultra-condensed) (const :tag "ultraexpanded" ultra-expanded) (const :tag "wide" extra-expanded))) - + (:height (choice :tag "Height" :help-echo "Face's font height." - (const :tag "*" nil) + :value 1.0 ; default (integer :tag "Height in 1/10 pt") (number :tag "Scale" 1.0))) (:weight (choice :tag "Weight" :help-echo "Font weight." - (const :tag "*" nil) - (const :tag "black" ultra_bold) + :value normal ; default + (const :tag "black" ultra-bold) (const :tag "bold" bold) (const :tag "book" semi-light) (const :tag "demibold" semi-bold) @@ -121,48 +110,43 @@ (const :tag "semilight" semi-light) (const :tag "ultralight" ultra-light) (const :tag "ultrabold" ultra-bold))) - + (:slant (choice :tag "Slant" :help-echo "Font slant." - (const :tag "*" nil) + :value normal ; default (const :tag "italic" italic) (const :tag "oblique" oblique) (const :tag "normal" normal))) - + (:underline (choice :tag "Underline" :help-echo "Control text underlining." - (const :tag "*" nil) + (const :tag "Off" nil) (const :tag "On" t) - (const :tag "Off" off) (color :tag "Colored"))) - + (:overline (choice :tag "Overline" :help-echo "Control text overlining." - (const :tag "*" nil) + (const :tag "Off" nil) (const :tag "On" t) - (const :tag "Off" off) (color :tag "Colored"))) - + (:strike-through (choice :tag "Strike-through" :help-echo "Control text strike-through." - (const :tag "*" nil) + (const :tag "Off" nil) (const :tag "On" t) - (const :tag "Off" off) (color :tag "Colored"))) - + (:box ;; Fixme: this can probably be done better. (choice :tag "Box around text" :help-echo "Control box around text." - (const :tag "*" nil) - (const :tag "Off" off) + (const :tag "Off" nil) (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) @@ -174,36 +158,57 @@ (const :tag "None" nil)))) ;; filter to make value suitable for customize (lambda (real-value) - (if (consp real-value) - (list :line-width (or (plist-get real-value :line-width) 1) - :color (plist-get real-value :color) - :style (plist-get real-value :style)) - real-value))) - + (and real-value + (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) + (and cus-value + (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))) - + (const :tag "Off" nil) + (const :tag "On" t))) + (:foreground - (choice :tag "Foreground" - :help-echo "Set foreground color." - (const :tag "*" nil) - (color :tag "Color"))) - + (color :tag "Foreground" + :help-echo "Set foreground color (name or #RRGGBB hex spec).")) + (:background - (choice :tag "Background" - :help-echo "Set background color." - (const :tag "*" nil) - (color :tag "Color"))) - + (color :tag "Background" + :help-echo "Set background color (name or #RRGGBB hex spec).")) + (:stipple (choice :tag "Stipple" - :help-echo "Name of background bitmap file." - (const :tag "*" nil) - (file :tag "File" :must-match t))) + :help-echo "Background bit-mask" + (const :tag "None" nil) + (file :tag "File" + :help-echo "Name of bitmap file." + :must-match t))) (:inherit (repeat :tag "Inherit" @@ -222,7 +227,7 @@ (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 PRE-FILTER POST-FILTER), @@ -240,7 +245,6 @@ 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.") - (defun custom-face-attributes-get (face frame) "For FACE on FRAME, return an alternating list describing its attributes. The list has the form (KEYWORD VALUE KEYWORD VALUE...). @@ -263,39 +267,129 @@ If FRAME is nil, use the global defaults for FACE." ;;;###autoload (defun custom-set-faces (&rest args) "Initialize faces according to user preferences. +This associates the settings with the `user' theme. +The arguments should be a list where each entry has the form: + + (FACE SPEC [NOW [COMMENT]]) + +SPEC is stored as the saved value for FACE, as well as the value for the +`user' theme. The `user' theme is one of the default themes known to Emacs. +See `custom-known-themes' for more information on the known themes. +See `custom-theme-set-faces' for more information on the interplay +between themes and faces. +See `defface' for the format of SPEC. + +If NOW is present and non-nil, FACE is created now, according to SPEC. +COMMENT is a string comment about FACE." + (apply 'custom-theme-set-faces 'user args)) + +(defun custom-theme-set-faces (theme &rest args) + "Initialize faces for theme THEME. The arguments should be a list where each entry has the form: (FACE SPEC [NOW [COMMENT]]) -SPEC is stored as the saved value for FACE. +SPEC is stored as the saved value for FACE, as well as the value for the +`user' theme. The `user' theme is one of the default themes known to Emacs. +See `custom-known-themes' for more information on the known themes. +See `custom-theme-set-faces' for more information on the interplay +between themes and faces. +See `defface' for the format of SPEC. + If NOW is present and non-nil, FACE is created now, according to SPEC. COMMENT is a string comment about FACE. -See `defface' for the format of SPEC." - (while args - (let ((entry (car args))) - (if (listp entry) - (let ((face (nth 0 entry)) - (spec (nth 1 entry)) - (now (nth 2 entry)) - (comment (nth 3 entry))) - (put face 'saved-face spec) - (put face 'saved-face-comment comment) - (when now - (put face 'force-face t)) - (when (or now (facep face)) - (put face 'face-comment comment) - (make-empty-face face) - (face-spec-set face spec)) +Several properties of THEME and FACE are used in the process: + +If THEME property `theme-immediate' is non-nil, this is equivalent of +providing the NOW argument to all faces in the argument list: FACE is +created now. The only difference is FACE property `force-face': if NOW +is non-nil, FACE property `force-face' is set to the symbol `rogue', else +if THEME property `theme-immediate' is non-nil, FACE property `force-face' +is set to the symbol `immediate'. + +SPEC itself is saved in FACE property `saved-face' and it is stored in +FACE's list property `theme-face' \(using `custom-push-theme')." + (custom-check-theme theme) + (let ((immediate (get theme 'theme-immediate))) + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((face (nth 0 entry)) + (spec (nth 1 entry)) + (now (nth 2 entry)) + (comment (nth 3 entry))) + (put face 'saved-face spec) + (put face 'saved-face-comment comment) + (custom-push-theme 'theme-face face theme 'set spec) + (when (or now immediate) + (put face 'force-face (if now 'rogue 'immediate))) + (when (or now immediate (facep face)) + (unless (facep face) + (make-empty-face face)) + (put face 'face-comment comment) + (face-spec-set face spec)) (setq args (cdr args))) ;; Old format, a plist of FACE SPEC pairs. (let ((face (nth 0 args)) (spec (nth 1 args))) - (put face 'saved-face spec)) - (setq args (cdr (cdr args))))))) + (put face 'saved-face spec) + (custom-push-theme 'theme-face face theme 'set spec)) + (setq args (cdr (cdr args)))))))) + +;;;###autoload +(defun custom-theme-face-value (face theme) + "Return spec of FACE in THEME if THEME modifies FACE. +Value is nil otherwise. The association between theme and spec for FACE +is stored in FACE's property `theme-face'. The appropriate face +is retrieved using `custom-theme-value'." + ;; Returns car because the value is stored inside a one element list + (car-safe (custom-theme-value theme (get face 'theme-face)))) + +(defun custom-theme-reset-internal-face (face to-theme) + "Reset FACE to the value defined by TO-THEME. +If FACE is not defined in TO-THEME, reset FACE to the standard +value. See `custom-theme-face-value'. The standard value is +stored in SYMBOL's property `face-defface-spec' by `defface'." + (let ((spec (custom-theme-face-value face to-theme)) + was-in-theme) + (setq was-in-theme spec) + (setq spec (or spec (get face 'face-defface-spec))) + (when spec + (put face 'save-face was-in-theme) + (when (or (get face 'force-face) (facep face)) + (unless (facep face) + (make-empty-face face)) + (face-spec-set face spec))) + spec)) + +;;;###autoload +(defun custom-theme-reset-faces (theme &rest args) + "Reset the value of the face to values previously defined. +Associate this setting with THEME. + +ARGS is a list of lists of the form + + (FACE TO-THEME) + +This means reset FACE to its value in TO-THEME." + (custom-check-theme theme) + (mapcar '(lambda (arg) + (apply 'custom-theme-reset-internal-face arg) + (custom-push-theme 'theme-face (car arg) theme 'reset (cadr arg))) + args)) + +;;;###autoload +(defun custom-reset-faces (&rest args) + "Reset the value of the face to values previously saved. +This is the setting assosiated the `user' theme. + +ARGS is defined as for `custom-theme-reset-faces'" + (apply 'custom-theme-reset-faces 'user args)) ;;; The End. (provide 'cus-face) +;;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b ;;; cus-face.el ends here