code.delx.au - gnu-emacs/blob - 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 ;;; Declaring a face.
  34
  35 ;;;###autoload
  36 (defun custom-declare-face (face spec doc &rest args)
  37   "Like `defface', but FACE is evaluated as a normal argument."
  38   (unless (get face 'face-defface-spec)
  39     (put face 'face-defface-spec spec)
  40     (when (fboundp 'facep)
  41       (unless (facep face)
  42         ;; If the user has already created the face, respect that.
  43         (let ((value (or (get face 'saved-face) spec))
  44               (frames (frame-list))
  45               frame)
  46           ;; Create global face.
  47           (make-empty-face face)
  48           ;; Create frame local faces
  49           (while frames
  50             (setq frame (car frames)
  51                   frames (cdr frames))
  52             (face-spec-set face value frame)))))
  53     (when (and doc (null (face-doc-string face)))
  54       (set-face-doc-string face doc))
  55     (custom-handle-all-keywords face args 'custom-face)
  56     (run-hooks 'custom-define-hook))
  57   face)
  58
  59 ;;; Font Attributes.
  60
  61 (defconst custom-face-attributes
  62   '((:bold (toggle :format "%[Bold%]: %v\n"
  63                    :help-echo "Control whether a bold font should be used.")
  64            set-face-bold-p
  65            face-bold-p)
  66     (:italic (toggle :format "%[Italic%]: %v\n"
  67                      :help-echo "\
  68 Control whether an italic font should be used.")
  69              set-face-italic-p
  70              face-italic-p)
  71     (:underline (toggle :format "%[Underline%]: %v\n"
  72                         :help-echo "\
  73 Control whether the text should be underlined.")
  74                 set-face-underline-p
  75                 face-underline-p)
  76     (:foreground (color :tag "Foreground"
  77                         :value "black"
  78                         :help-echo "Set foreground color.")
  79                  set-face-foreground
  80                  face-foreground)
  81     (:background (color :tag "Background"
  82                         :value "white"
  83                         :help-echo "Set background color.")
  84                  set-face-background
  85                  face-background)
  86     (:stipple (editable-field :format "Stipple: %v"
  87                               :help-echo "Name of background bitmap file.")
  88               set-face-stipple
  89               face-stipple))
  90   "Alist of face attributes.
  91 The elements are of the form (KEY TYPE SET GET),
  92 where KEY is the name of the attribute,
  93 TYPE is a widget type for editing the attibute,
  94 SET is a function for setting the attribute value,
  95 and GET is a function for getiing the attribute value.
  96
  97 The SET function should take three arguments, the face to modify, the
  98 value of the attribute, and optionally the frame where the face should
  99 be changed.
 100
 101 The GET function should take two arguments, the face to examine, and
 102 optionally the frame where the face should be examined.")
 103
 104 (defun custom-face-attributes-get (face frame)
 105   "For FACE on FRAME, return an alternating list describing its attributes.
 106 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 107 Each keyword should be listed in `custom-face-attributes'.
 108 We include only those attributes that differ from the default face.
 109
 110 If FRAME is nil, use the global defaults for FACE."
 111   (let ((atts custom-face-attributes)
 112         att result get)
 113     (while atts
 114       (setq att (car atts)
 115             atts (cdr atts)
 116             get (nth 3 att))
 117       (when get
 118         (let ((answer (funcall get face frame)))
 119           (if (and (not (equal answer (funcall get 'default frame)))
 120                    (widget-apply (nth 1 att) :match answer))
 121               (setq result (cons (nth 0 att) (cons answer result)))))))
 122     result))
 123
 124 ;;; Initializing.
 125
 126 ;;;###autoload
 127 (defun custom-set-faces (&rest args)
 128   "Initialize faces according to user preferences.
 129 The arguments should be a list where each entry has the form:
 130
 131   (FACE SPEC [NOW])
 132
 133 SPEC is stored as the saved value for FACE.
 134 If NOW is present and non-nil, FACE is created now, according to SPEC.
 135
 136 See `defface' for the format of SPEC."
 137   (while args
 138     (let ((entry (car args)))
 139       (if (listp entry)
 140           (let ((face (nth 0 entry))
 141                 (spec (nth 1 entry))
 142                 (now (nth 2 entry)))
 143             (put face 'saved-face spec)
 144             (when now
 145               (put face 'force-face t))
 146             (when (or now (facep face))
 147               (make-empty-face face)
 148               (face-spec-set face spec))
 149             (setq args (cdr args)))
 150         ;; Old format, a plist of FACE SPEC pairs.
 151         (let ((face (nth 0 args))
 152               (spec (nth 1 args)))
 153           (put face 'saved-face spec))
 154         (setq args (cdr (cdr args)))))))
 155
 156 ;;; The End.
 157
 158 (provide 'cus-face)
 159
 160 ;; cus-face.el ends here