X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/675f1fcb15f8b44aa26efedec8bc0b821ee62f3e..db8d59365b5ccdca367ace2d4df5b8a2242e5765:/lisp/cus-face.el diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 7c4930ff99..53ad08498f 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -1,10 +1,10 @@ -;;; 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, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: Emacs ;; This file is part of GNU Emacs. @@ -20,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; @@ -37,23 +37,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)) + (if (memq window-system '(x w32 mac)) (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 +60,16 @@ ;;; 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. - +;;;###autoload (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 +85,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 +112,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 +160,54 @@ (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 "Background bit-mask" - (const :tag "*" nil) - (const :tag "None" off) + (const :tag "None" nil) (file :tag "File" :help-echo "Name of bitmap file." :must-match t))) @@ -225,7 +229,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), @@ -243,7 +247,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...). @@ -266,39 +269,117 @@ 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. +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, 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)) + oldspec) + ;; If FACE is actually an alias, customize the face it + ;; is aliased to. + (if (get face 'face-alias) + (setq face (get face 'face-alias))) + + (setq oldspec (get face 'theme-face)) + (when (not (and oldspec (eq 'user (caar oldspec)))) + (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))))))) + (if (get face 'face-alias) + (setq face (get face 'face-alias))) + (put face 'saved-face spec) + (custom-push-theme 'theme-face face theme 'set spec)) + (setq args (cdr (cdr args)))))))) + +;; XEmacs compability function. In XEmacs, when you reset a Custom +;; Theme, you have to specify the theme to reset it to. We just apply +;; the next theme. +;;;###autoload +(defun custom-theme-reset-faces (theme &rest args) + "Reset the specs in THEME of some faces to their specs in other themes. +Each of the arguments ARGS has this form: + + (FACE IGNORED) + +This means reset FACE. The argument IGNORED is ignored." + (custom-check-theme theme) + (dolist (arg args) + (custom-push-theme 'theme-face (car arg) theme 'reset))) + +;;;###autoload +(defun custom-reset-faces (&rest args) + "Reset the specs of some faces to their specs in specified themes. +This creates settings in the `user' theme. + +Each of the arguments ARGS has this form: + + (FACE FROM-THEME) + +This means reset FACE to its value in FROM-THEME." + (apply 'custom-theme-reset-faces 'user args)) ;;; The End. (provide 'cus-face) +;;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b ;;; cus-face.el ends here