lisp/cus-face.el

   1 ;;; cus-face.el -- customization support for faces.
   2 ;;
   3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: help, faces
   7 ;; Version: Emacs
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; See `custom.el'.
  30
  31 ;;; Code:
  32
  33 (defalias 'custom-facep
  34   (if (fboundp 'facep) 'facep
  35     '(lambda (face) nil)))
  36
  37 ;;; Declaring a face.
  38
  39 ;;;###autoload
  40 (defun custom-declare-face (face spec doc &rest args)
  41   "Like `defface', but FACE is evaluated as a normal argument."
  42   (unless (get face 'face-defface-spec)
  43     (put face 'face-defface-spec spec)
  44     (when (fboundp 'facep)
  45       (unless (facep face)
  46         ;; If the user has already created the face, respect that.
  47         (let ((value (or (get face 'saved-face) spec))
  48               (frames (frame-list))
  49               frame)
  50           ;; Create global face.
  51           (make-empty-face face)
  52           ;; Create frame local faces
  53           (while frames
  54             (setq frame (car frames)
  55                   frames (cdr frames))
  56             (face-spec-set face value frame)))
  57         ;; When making a face after frames already exist
  58         (if (memq window-system '(x w32))
  59             (make-face-x-resource-internal face))))
  60     (when (and doc (null (face-documentation face)))
  61       (set-face-documentation face doc))
  62     (custom-handle-all-keywords face args 'custom-face)
  63     (run-hooks 'custom-define-hook))
  64   face)
  65
  66 ;;; Font Attributes.
  67
  68 (defconst custom-face-attributes
  69   '((:bold (boolean :tag "Bold"
  70                     :help-echo "Control whether a bold font should be used.")
  71            set-face-bold-p
  72            face-bold-p)
  73     (:italic (boolean :tag "Italic"
  74                       :help-echo "\
  75 Control whether an italic font should be used.")
  76              set-face-italic-p
  77              face-italic-p)
  78     (:underline (boolean :tag "Underline"
  79                          :help-echo "\
  80 Control whether the text should be underlined.")
  81                 set-face-underline-p
  82                 face-underline-p)
  83     (:inverse-video (boolean :tag "Inverse Video"
  84                              :help-echo "\
  85 Control whether the text should be in inverse video.")
  86                 set-face-inverse-video-p
  87                 face-inverse-video-p)
  88     (:foreground (color :tag "Foreground"
  89                         :value ""
  90                         :help-echo "Set foreground color.")
  91                  set-face-foreground
  92                  face-foreground)
  93     (:background (color :tag "Background"
  94                         :value ""
  95                         :help-echo "Set background color.")
  96                  set-face-background
  97                  face-background)
  98     (:stipple (editable-field :format "Stipple: %v"
  99                               :help-echo "Name of background bitmap file.")
 100               set-face-stipple
 101               face-stipple))
 102   "Alist of face attributes.
 103 The elements are of the form (KEY TYPE SET GET),
 104 where KEY is the name of the attribute,
 105 TYPE is a widget type for editing the attibute,
 106 SET is a function for setting the attribute value,
 107 and GET is a function for getiing the attribute value.
 108
 109 The SET function should take three arguments, the face to modify, the
 110 value of the attribute, and optionally the frame where the face should
 111 be changed.
 112
 113 The GET function should take two arguments, the face to examine, and
 114 optionally the frame where the face should be examined.")
 115
 116 (defun custom-face-attributes-get (face frame)
 117   "For FACE on FRAME, return an alternating list describing its attributes.
 118 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 119 Each keyword should be listed in `custom-face-attributes'.
 120 We include only those attributes that differ from the default face.
 121
 122 If FRAME is nil, use the global defaults for FACE."
 123   (let ((atts custom-face-attributes)
 124         att result get)
 125     (while atts
 126       (setq att (car atts)
 127             atts (cdr atts)
 128             get (nth 3 att))
 129       (when get
 130         (let ((answer (funcall get face frame)))
 131           (if (and (not (equal answer (funcall get 'default frame)))
 132                    (widget-apply (nth 1 att) :match answer))
 133               (setq result (cons (nth 0 att) (cons answer result)))))))
 134     result))
 135
 136 ;;; Initializing.
 137
 138 ;;;###autoload
 139 (defun custom-set-faces (&rest args)
 140   "Initialize faces according to user preferences.
 141 The arguments should be a list where each entry has the form:
 142
 143   (FACE SPEC [NOW])
 144
 145 SPEC is stored as the saved value for FACE.
 146 If NOW is present and non-nil, FACE is created now, according to SPEC.
 147
 148 See `defface' for the format of SPEC."
 149   (while args
 150     (let ((entry (car args)))
 151       (if (listp entry)
 152           (let ((face (nth 0 entry))
 153                 (spec (nth 1 entry))
 154                 (now (nth 2 entry)))
 155             (put face 'saved-face spec)
 156             (when now
 157               (put face 'force-face t))
 158             (when (or now (facep face))
 159               (make-empty-face face)
 160               (face-spec-set face spec))
 161             (setq args (cdr args)))
 162         ;; Old format, a plist of FACE SPEC pairs.
 163         (let ((face (nth 0 args))
 164               (spec (nth 1 args)))
 165           (put face 'saved-face spec))
 166         (setq args (cdr (cdr args)))))))
 167
 168 ;;; The End.
 169
 170 (provide 'cus-face)
 171
 172 ;; cus-face.el ends here