[bpt/emacs.git] / lisp / cus-face.el

;;; cus-face.el -- customization support for faces.
;;
;; Copyright (C) 1996, 1997, 1999 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
;; Version: Emacs

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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.

;;; Commentary:
;;
;; See `custom.el'.

;;; Code:

(defalias 'custom-facep 'facep)

;;; Declaring a face.

;;;###autoload
(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)
	  ;; Create global face.
	  (make-empty-face face)
	  ;; Create frame local faces
	  (while frames
	    (setq frame (car frames)
		  frames (cdr frames))
	    (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))))
    (when (and doc (null (face-documentation face)))
      (set-face-documentation face (purecopy doc)))
    (custom-handle-all-keywords face args 'custom-face)
    (run-hooks 'custom-define-hook))
  face)

;;; 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"))
     (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))))
    
    (:width
     (choice :tag "Width"
	     :help-echo "Font width."
	     (const :tag "*" nil)
	     (const :tag "compressed" condensed)
	     (const :tag "condensed" condensed)
	     (const :tag "demiexpanded" semi-expanded)
	     (const :tag "expanded" expanded)
	     (const :tag "extracondensed" extra-condensed)
	     (const :tag "extraexpanded" extra-expanded)
	     (const :tag "medium" normal)
	     (const :tag "narrow" condensed)
	     (const :tag "normal" normal)
	     (const :tag "regular" normal)
	     (const :tag "semicondensed" semi-condensed)
	     (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))))
    
    (:height
     (choice :tag "Height"
	     :help-echo "Face's font height."
	     (const :tag "*" nil)
	     (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)
       (let ((height (face-attribute face :height frame)))
	 (if (eq height 'unspecified) nil height))))

    (:weight
     (choice :tag "Weight"
	     :help-echo "Font weight."
	     (const :tag "*" nil)
	     (const :tag "black" ultra_bold)
	     (const :tag "bold" bold)
	     (const :tag "book" semi-light)
	     (const :tag "demibold" semi-bold)
	     (const :tag "extralight" extra-light)
	     (const :tag "extrabold" extra-bold)
	     (const :tag "heavy" extra-bold)
	     (const :tag "light" light)
	     (const :tag "medium" normal)
	     (const :tag "normal" normal)
	     (const :tag "regular" normal)
	     (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))))
    
    (:slant
     (choice :tag "Slant"
	     :help-echo "Font slant."
	     (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))))
    
    (:underline
     (choice :tag "Underline"
	     :help-echo "Control text underlining."
	     (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)))))
    
    (:overline
     (choice :tag "Overline"
	     :help-echo "Control text overlining."
	     (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)))))
    
    (:strike-through
     (choice :tag "Strike-through"
	     :help-echo "Control text strike-through."
	     (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)))
    
    (: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)
	     (list :tag "Box"
		   :value (:line-width 2 :color "grey75"
				       :style released-button)
		   (const :format "" :value :line-width)
		   (integer :tag "Width")
		   (const :format "" :value :color)
		   (choice :tag "Color" (const :tag "*" nil) color)
		   (const :format "" :value :style)
		   (choice :tag "Style"
			   (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))))
    
    (: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)))))
    
    (: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))))
    
    (: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))))
    
    (:stipple
     (choice :tag "Stipple"
	     :help-echo "Name of background bitmap file."
	     (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))))

    (:inherit
     (repeat :tag "Inherit"
	     :help-echo "List of faces to inherit attributes from."
	     (face :Tag "Face" default))
     (lambda (face value &optional frame)
       (message "Setting to: <%s>" value)
       (set-face-attribute face frame :inherit
			   (if (and (consp value) (null (cdr value)))
			       (car value)
			     value)))
     (lambda (face &optional frame)
       (let ((value (face-attribute face :inherit frame)))
	 (cond ((or (null value) (eq value 'unspecified))
		nil)
	       ((symbolp value)
		(list value))
	       (t
		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 getiing the attribute value.

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 GET function should take two arguments, the face to examine, and
optionally the frame where the face should be examined.")


(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...).
Each keyword should be listed in `custom-face-attributes'.

If FRAME is nil, use the global defaults for FACE."
  (let ((attrs custom-face-attributes)
	plist)
    (while attrs
      (let* ((attribute (car (car attrs)))
	     (value (face-attribute face attribute frame)))
	(setq attrs (cdr attrs))
	(unless (or (eq value 'unspecified)
		    (and (null value) (memq attribute '(:inherit))))
	  (setq plist (cons attribute (cons value plist))))))
    plist))

;;; Initializing.

;;;###autoload
(defun custom-set-faces (&rest args)
  "Initialize faces according to user preferences.
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.
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))
	    (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)))))))

;;; The End.

(provide 'cus-face)

;;; cus-face.el ends here
Commit	Line	Data
6c283d44	1	;;; cus-face.el -- customization support for faces.
d543e20b	2	;;
1743c17a	3	;; Copyright (C) 1996, 1997, 1999 Free Software Foundation, Inc.
d543e20b PA	4	;;
	5	;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
	6	;; Keywords: help, faces
5f0cfe8b	7	;; Version: Emacs
d543e20b	8
6c283d44	9	;; This file is part of GNU Emacs.
d543e20b	10
6c283d44 RS	11	;; GNU Emacs is free software; you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation; either version 2, or (at your option)
	14	;; any later version.
d543e20b	15
6c283d44 RS	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
d543e20b	20
6c283d44 RS	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs; see the file COPYING. If not, write to the
	23	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	24	;; Boston, MA 02111-1307, USA.
d543e20b	25
6c283d44 RS	26	;;; Commentary:
	27	;;
	28	;; See `custom.el'.
d543e20b	29
6c283d44	30	;;; Code:
d543e20b	31
da0b1f56	32	(defalias 'custom-facep 'facep)
ccd0d40c	33
d543e20b PA	34	;;; Declaring a face.
	35
	36	;;;###autoload
	37	(defun custom-declare-face (face spec doc &rest args)
	38	"Like `defface', but FACE is evaluated as a normal argument."
6c283d44 RS	39	(unless (get face 'face-defface-spec)
6c283d44 RS	40	(put face 'face-defface-spec spec)
d543e20b	41	(when (fboundp 'facep)
6c283d44	42	(unless (facep face)
d543e20b PA	43	;; If the user has already created the face, respect that.
d543e20b PA	44	(let ((value (or (get face 'saved-face) spec))
6c283d44	45	(frames (frame-list))
d543e20b PA	46	frame)
	47	;; Create global face.
	48	(make-empty-face face)
d543e20b PA	49	;; Create frame local faces
	50	(while frames
	51	(setq frame (car frames)
	52	frames (cdr frames))
971e48ca RS	53	(face-spec-set face value frame)))
	54	;; When making a face after frames already exist
	55	(if (memq window-system '(x w32))
	56	(make-face-x-resource-internal face))))
209ddde3	57	(when (and doc (null (face-documentation face)))
08449ec1	58	(set-face-documentation face (purecopy doc)))
d543e20b PA	59	(custom-handle-all-keywords face args 'custom-face)
	60	(run-hooks 'custom-define-hook))
	61	face)
	62
da0b1f56 GM	63	;;; Face attributes.
	64
	65	;; Below, nil is used in widget specifications for `unspecified' face
	66	;; attributes and `off' is used instead of nil attribute values. The
	67	;; reason for this is that nil corresponds to the result you get when
	68	;; looking up an attribute in a defface spec that isn't contained in
	69	;; the spec.
d543e20b PA	70
d543e20b PA	71	(defconst custom-face-attributes
da0b1f56 GM	72	'((:family
	73	(choice :tag "Font family"
	74	:help-echo "Font family or fontset alias name."
	75	(const :tag "*" nil)
	76	(string :tag "Family"))
	77	(lambda (face value &optional frame)
	78	(set-face-attribute face frame :family (or value 'unspecified)))
	79	(lambda (face &optional frame)
	80	(let ((family (face-attribute face :family frame)))
	81	(if (eq family 'unspecified) nil family))))
	82
	83	(:width
	84	(choice :tag "Width"
	85	:help-echo "Font width."
	86	(const :tag "*" nil)
	87	(const :tag "compressed" condensed)
	88	(const :tag "condensed" condensed)
	89	(const :tag "demiexpanded" semi-expanded)
	90	(const :tag "expanded" expanded)
	91	(const :tag "extracondensed" extra-condensed)
	92	(const :tag "extraexpanded" extra-expanded)
	93	(const :tag "medium" normal)
	94	(const :tag "narrow" condensed)
	95	(const :tag "normal" normal)
	96	(const :tag "regular" normal)
	97	(const :tag "semicondensed" semi-condensed)
	98	(const :tag "semiexpanded" semi-expanded)
	99	(const :tag "ultracondensed" ultra-condensed)
	100	(const :tag "ultraexpanded" ultra-expanded)
	101	(const :tag "wide" extra-expanded))
	102	(lambda (face value &optional frame)
	103	(set-face-attribute face frame :width (or value 'unspecified)))
	104	(lambda (face &optional frame)
	105	(let ((width (face-attribute face :width frame)))
	106	(if (eq width 'unspecified) nil width))))
	107
	108	(:height
	109	(choice :tag "Height"
	110	:help-echo "Face's font height."
	111	(const :tag "*" nil)
6bca3005 MB	112	(integer :tag "Height in 1/10 pt")
6bca3005 MB	113	(number :tag "Scale" 1.0))
da0b1f56 GM	114	(lambda (face value &optional frame)
	115	(set-face-attribute face frame :height (or value 'unspecified)))
	116	(lambda (face &optional frame)
	117	(let ((height (face-attribute face :height frame)))
	118	(if (eq height 'unspecified) nil height))))
6bca3005	119
da0b1f56 GM	120	(:weight
	121	(choice :tag "Weight"
	122	:help-echo "Font weight."
	123	(const :tag "*" nil)
	124	(const :tag "black" ultra_bold)
	125	(const :tag "bold" bold)
	126	(const :tag "book" semi-light)
	127	(const :tag "demibold" semi-bold)
	128	(const :tag "extralight" extra-light)
	129	(const :tag "extrabold" extra-bold)
	130	(const :tag "heavy" extra-bold)
	131	(const :tag "light" light)
	132	(const :tag "medium" normal)
	133	(const :tag "normal" normal)
	134	(const :tag "regular" normal)
	135	(const :tag "semibold" semi-bold)
	136	(const :tag "semilight" semi-light)
	137	(const :tag "ultralight" ultra-light)
	138	(const :tag "ultrabold" ultra-bold))
	139	(lambda (face value &optional frame)
	140	(set-face-attribute face frame :weight (or value 'unspecified)))
	141	(lambda (face &optional frame)
	142	(let ((weight (face-attribute face :weight frame)))
	143	(if (eq weight 'unspecified) nil weight))))
	144
	145	(:slant
	146	(choice :tag "Slant"
	147	:help-echo "Font slant."
	148	(const :tag "*" nil)
	149	(const :tag "italic" italic)
	150	(const :tag "oblique" oblique)
	151	(const :tag "normal" normal))
	152	(lambda (face value &optional frame)
	153	(set-face-attribute face frame :slant (or value 'unspecified)))
	154	(lambda (face &optional frame)
	155	(let ((slant (face-attribute face :slant frame)))
	156	(if (eq slant 'unspecified) nil slant))))
	157
	158	(:underline
	159	(choice :tag "Underline"
	160	:help-echo "Control text underlining."
	161	(const :tag "*" nil)
	162	(const :tag "On" t)
	163	(const :tag "Off" off)
	164	(color :tag "Colored"))
	165	(lambda (face value &optional frame)
	166	(cond ((eq value 'off) (setq value nil))
	167	((null value) (setq value 'unspecified)))
	168	(set-face-attribute face frame :underline value))
	169	(lambda (face &optional frame)
	170	(let ((underline (face-attribute face :underline frame)))
1743c17a DL	171	(cond ((eq underline 'unspecified) nil)
1743c17a DL	172	((null underline) 'off)))))
da0b1f56 GM	173
	174	(:overline
	175	(choice :tag "Overline"
	176	:help-echo "Control text overlining."
	177	(const :tag "*" nil)
	178	(const :tag "On" t)
	179	(const :tag "Off" off)
	180	(color :tag "Colored"))
	181	(lambda (face value &optional frame)
	182	(cond ((eq value 'off) (setq value nil))
	183	((null value) (setq value 'unspecified)))
	184	(set-face-attribute face frame :overline value))
	185	(lambda (face &optional frame)
	186	(let ((overline (face-attribute face :overline frame)))
1743c17a DL	187	(cond ((eq overline 'unspecified) nil)
1743c17a DL	188	((null overline) 'off)))))
da0b1f56 GM	189
	190	(:strike-through
	191	(choice :tag "Strike-through"
	192	:help-echo "Control text strike-through."
	193	(const :tag "*" nil)
	194	(const :tag "On" t)
	195	(const :tag "Off" off)
	196	(color :tag "Colored"))
	197	(lambda (face value &optional frame)
	198	(cond ((eq value 'off) (setq value nil))
	199	((null value) (setq value 'unspecified)))
	200	(set-face-attribute face frame :strike-through value))
	201	(lambda (face &optional frame)
	202	(let ((value (face-attribute face :strike-through frame)))
	203	(cond ((eq value 'unspecified) (setq value nil))
	204	((null value) (setq value 'off)))
	205	value)))
	206
	207	(:box
1743c17a	208	;; Fixme: this can probably be done better.
da0b1f56 GM	209	(choice :tag "Box around text"
da0b1f56 GM	210	:help-echo "Control box around text."
1743c17a DL	211	(const :tag "*" t)
1743c17a DL	212	(const :tag "Off" nil)
da0b1f56	213	(list :tag "Box"
1743c17a DL	214	:value (:line-width 2 :color "grey75"
	215	:style released-button)
	216	(const :format "" :value :line-width)
da0b1f56	217	(integer :tag "Width")
1743c17a DL	218	(const :format "" :value :color)
	219	(choice :tag "Color" (const :tag "*" nil) color)
	220	(const :format "" :value :style)
	221	(choice :tag "Style"
	222	(const :tag "Raised" released-button)
	223	(const :tag "Sunken" pressed-button)
	224	(const :tag "None" nil))))
da0b1f56	225	(lambda (face value &optional frame)
da0b1f56 GM	226	(set-face-attribute face frame :box value))
	227	(lambda (face &optional frame)
	228	(let ((value (face-attribute face :box frame)))
1743c17a DL	229	(if (consp value)
	230	(list :line-width (or (plist-get value :line-width) 1)
	231	:color (plist-get value :color)
	232	:style (plist-get value :style))
	233	value))))
da0b1f56 GM	234
	235	(:inverse-video
	236	(choice :tag "Inverse-video"
	237	:help-echo "Control whether text should be in inverse-video."
	238	(const :tag "*" nil)
	239	(const :tag "On" t)
	240	(const :tag "Off" off))
	241	(lambda (face value &optional frame)
	242	(cond ((eq value 'off) (setq value nil))
	243	((null value) (setq value 'unspecified)))
	244	(set-face-attribute face frame :inverse-video value))
	245	(lambda (face &optional frame)
	246	(let ((value (face-attribute face :inverse-video frame)))
1743c17a DL	247	(cond ((eq value 'unspecified)
	248	nil)
	249	((null value)'off)))))
da0b1f56 GM	250
	251	(:foreground
	252	(choice :tag "Foreground"
	253	:help-echo "Set foreground color."
	254	(const :tag "*" nil)
	255	(color :tag "Color"))
	256	(lambda (face value &optional frame)
	257	(set-face-attribute face frame :foreground (or value 'unspecified)))
	258	(lambda (face &optional frame)
	259	(let ((value (face-attribute face :foreground frame)))
	260	(if (eq value 'unspecified) nil value))))
	261
	262	(:background
	263	(choice :tag "Background"
	264	:help-echo "Set background color."
	265	(const :tag "*" nil)
	266	(color :tag "Color"))
	267	(lambda (face value &optional frame)
	268	(set-face-attribute face frame :background (or value 'unspecified)))
	269	(lambda (face &optional frame)
	270	(let ((value (face-attribute face :background frame)))
	271	(if (eq value 'unspecified) nil value))))
	272
	273	(:stipple
	274	(choice :tag "Stipple"
	275	:help-echo "Name of background bitmap file."
	276	(const :tag "*" nil)
	277	(file :tag "File" :must-match t))
	278	(lambda (face value &optional frame)
	279	(set-face-attribute face frame :stipple (or value 'unspecified)))
	280	(lambda (face &optional frame)
	281	(let ((value (face-attribute face :stipple frame)))
6bca3005 MB	282	(if (eq value 'unspecified) nil value))))
	283
	284	(:inherit
	285	(repeat :tag "Inherit"
	286	:help-echo "List of faces to inherit attributes from."
	287	(face :Tag "Face" default))
	288	(lambda (face value &optional frame)
	289	(message "Setting to: <%s>" value)
	290	(set-face-attribute face frame :inherit
	291	(if (and (consp value) (null (cdr value)))
	292	(car value)
	293	value)))
	294	(lambda (face &optional frame)
	295	(let ((value (face-attribute face :inherit frame)))
	296	(cond ((or (null value) (eq value 'unspecified))
	297	nil)
	298	((symbolp value)
	299	(list value))
	300	(t
	301	value))))))
da0b1f56 GM	302
	303	"Alist of face attributes.
	304
	305	The elements are of the form (KEY TYPE SET GET), where KEY is the name
	306	of the attribute, TYPE is a widget type for editing the attibute, SET
	307	is a function for setting the attribute value, and GET is a function
	308	for getiing the attribute value.
d543e20b PA	309
	310	The SET function should take three arguments, the face to modify, the
	311	value of the attribute, and optionally the frame where the face should
	312	be changed.
	313
	314	The GET function should take two arguments, the face to examine, and
6c283d44	315	optionally the frame where the face should be examined.")
d543e20b	316
da0b1f56	317
d543e20b	318	(defun custom-face-attributes-get (face frame)
6c283d44 RS	319	"For FACE on FRAME, return an alternating list describing its attributes.
6c283d44 RS	320	The list has the form (KEYWORD VALUE KEYWORD VALUE...).
d543e20b PA	321	Each keyword should be listed in `custom-face-attributes'.
d543e20b PA	322
6c283d44	323	If FRAME is nil, use the global defaults for FACE."
da0b1f56 GM	324	(let ((attrs custom-face-attributes)
	325	plist)
	326	(while attrs
	327	(let* ((attribute (car (car attrs)))
	328	(value (face-attribute face attribute frame)))
	329	(setq attrs (cdr attrs))
6bca3005 MB	330	(unless (or (eq value 'unspecified)
6bca3005 MB	331	(and (null value) (memq attribute '(:inherit))))
da0b1f56 GM	332	(setq plist (cons attribute (cons value plist))))))
da0b1f56 GM	333	plist))
d543e20b	334
d543e20b PA	335	;;; Initializing.
d543e20b PA	336
d543e20b PA	337	;;;###autoload
	338	(defun custom-set-faces (&rest args)
	339	"Initialize faces according to user preferences.
	340	The arguments should be a list where each entry has the form:
	341
1743c17a	342	(FACE SPEC [NOW [COMMENT]])
d543e20b	343
6c283d44 RS	344	SPEC is stored as the saved value for FACE.
6c283d44 RS	345	If NOW is present and non-nil, FACE is created now, according to SPEC.
1743c17a	346	COMMENT is a string comment about FACE.
d543e20b PA	347
	348	See `defface' for the format of SPEC."
	349	(while args
	350	(let ((entry (car args)))
	351	(if (listp entry)
	352	(let ((face (nth 0 entry))
	353	(spec (nth 1 entry))
1743c17a DL	354	(now (nth 2 entry))
1743c17a DL	355	(comment (nth 3 entry)))
d543e20b	356	(put face 'saved-face spec)
1743c17a	357	(put face 'saved-face-comment comment)
d543e20b PA	358	(when now
d543e20b PA	359	(put face 'force-face t))
6c283d44	360	(when (or now (facep face))
1743c17a	361	(put face 'face-comment comment)
6c283d44 RS	362	(make-empty-face face)
6c283d44 RS	363	(face-spec-set face spec))
d543e20b PA	364	(setq args (cdr args)))
	365	;; Old format, a plist of FACE SPEC pairs.
	366	(let ((face (nth 0 args))
	367	(spec (nth 1 args)))
	368	(put face 'saved-face spec))
	369	(setq args (cdr (cdr args)))))))
	370
	371	;;; The End.
	372
	373	(provide 'cus-face)
	374
1743c17a	375	;;; cus-face.el ends here