LCOV - code coverage report
Current view: top level - lisp - cus-face.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 8 45 17.8 %
Date: 2017-08-30 10:12:24 Functions: 1 6 16.7 %

          Line data    Source code
       1             : ;;; cus-face.el --- customization support for faces
       2             : ;;
       3             : ;; Copyright (C) 1996-1997, 1999-2017 Free Software Foundation, Inc.
       4             : ;;
       5             : ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
       6             : ;; Keywords: help, faces
       7             : ;; Package: emacs
       8             : 
       9             : ;; This file is part of GNU Emacs.
      10             : 
      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 3 of the License, or
      14             : ;; (at your option) any later version.
      15             : 
      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.
      20             : 
      21             : ;; You should have received a copy of the GNU General Public License
      22             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      23             : 
      24             : ;;; Commentary:
      25             : ;;
      26             : ;; See `custom.el'.
      27             : 
      28             : ;;; Code:
      29             : 
      30             : (defalias 'custom-facep 'facep)
      31             : 
      32             : ;;; Declaring a face.
      33             : 
      34             : (defun custom-declare-face (face spec doc &rest args)
      35             :   "Like `defface', but with FACE evaluated as a normal argument."
      36          92 :   (unless (get face 'face-defface-spec)
      37           2 :     (face-spec-set face (purecopy spec) 'face-defface-spec)
      38           4 :     (push (cons 'defface face) current-load-list)
      39           2 :     (when doc
      40           2 :       (set-face-documentation face (purecopy doc)))
      41           2 :     (custom-handle-all-keywords face args 'custom-face)
      42          92 :     (run-hooks 'custom-define-hook))
      43          92 :   face)
      44             : 
      45             : ;;; Face attributes.
      46             : 
      47             : (defconst custom-face-attributes
      48             :   '((:family
      49             :      (string :tag "Font Family"
      50             :              :help-echo "Font family or fontset alias name."))
      51             : 
      52             :     (:foundry
      53             :      (string :tag "Font Foundry"
      54             :              :help-echo "Font foundry name."))
      55             : 
      56             :     (:width
      57             :      (choice :tag "Width"
      58             :              :help-echo "Font width."
      59             :              :value normal              ; default
      60             :              (const :tag "compressed" condensed)
      61             :              (const :tag "condensed" condensed)
      62             :              (const :tag "demiexpanded" semi-expanded)
      63             :              (const :tag "expanded" expanded)
      64             :              (const :tag "extracondensed" extra-condensed)
      65             :              (const :tag "extraexpanded" extra-expanded)
      66             :              (const :tag "medium" normal)
      67             :              (const :tag "narrow" condensed)
      68             :              (const :tag "normal" normal)
      69             :              (const :tag "regular" normal)
      70             :              (const :tag "semicondensed" semi-condensed)
      71             :              (const :tag "semiexpanded" semi-expanded)
      72             :              (const :tag "ultracondensed" ultra-condensed)
      73             :              (const :tag "ultraexpanded" ultra-expanded)
      74             :              (const :tag "wide" extra-expanded)))
      75             : 
      76             :     (:height
      77             :      (choice :tag "Height"
      78             :              :help-echo "Face's font height."
      79             :              :value 1.0                 ; default
      80             :              (integer :tag "Height in 1/10 pt")
      81             :              (number :tag "Scale" 1.0)))
      82             : 
      83             :     (:weight
      84             :      (choice :tag "Weight"
      85             :              :help-echo "Font weight."
      86             :              :value normal              ; default
      87             :              (const :tag "black" ultra-bold)
      88             :              (const :tag "bold" bold)
      89             :              (const :tag "book" semi-light)
      90             :              (const :tag "demibold" semi-bold)
      91             :              (const :tag "extralight" extra-light)
      92             :              (const :tag "extrabold" extra-bold)
      93             :              (const :tag "heavy" extra-bold)
      94             :              (const :tag "light" light)
      95             :              (const :tag "medium" normal)
      96             :              (const :tag "normal" normal)
      97             :              (const :tag "regular" normal)
      98             :              (const :tag "semibold" semi-bold)
      99             :              (const :tag "semilight" semi-light)
     100             :              (const :tag "ultralight" ultra-light)
     101             :              (const :tag "ultrabold" ultra-bold)
     102             :              (const :tag "thin" thin)))
     103             : 
     104             :     (:slant
     105             :      (choice :tag "Slant"
     106             :              :help-echo "Font slant."
     107             :              :value normal              ; default
     108             :              (const :tag "italic" italic)
     109             :              (const :tag "oblique" oblique)
     110             :              (const :tag "normal" normal)
     111             :              (const :tag "roman" roman)))
     112             : 
     113             :     (:underline
     114             :      (choice :tag "Underline"
     115             :              :help-echo "Control text underlining."
     116             :              (const :tag "Off" nil)
     117             :              (list :tag "On"
     118             :                    :value (:color foreground-color :style line)
     119             :                    (const :format "" :value :color)
     120             :                    (choice :tag "Color"
     121             :                            (const :tag "Foreground Color" foreground-color)
     122             :                            color)
     123             :                    (const :format "" :value :style)
     124             :                    (choice :tag "Style"
     125             :                            (const :tag "Line" line)
     126             :                            (const :tag "Wave" wave))))
     127             :      ;; filter to make value suitable for customize
     128             :      (lambda (real-value)
     129             :        (and real-value
     130             :             (let ((color
     131             :                    (or (and (consp real-value) (plist-get real-value :color))
     132             :                        (and (stringp real-value) real-value)
     133             :                        'foreground-color))
     134             :                   (style
     135             :                    (or (and (consp real-value) (plist-get real-value :style))
     136             :                        'line)))
     137             :               (list :color color :style style))))
     138             :      ;; filter to make customized-value suitable for storing
     139             :      (lambda (cus-value)
     140             :        (and cus-value
     141             :             (let ((color (plist-get cus-value :color))
     142             :                   (style (plist-get cus-value :style)))
     143             :               (cond ((eq style 'line)
     144             :                      ;; Use simple value for default style
     145             :                      (if (eq color 'foreground-color) t color))
     146             :                     (t
     147             :                      `(:color ,color :style ,style)))))))
     148             : 
     149             :     (:overline
     150             :      (choice :tag "Overline"
     151             :              :help-echo "Control text overlining."
     152             :              (const :tag "Off" nil)
     153             :              (const :tag "On" t)
     154             :              (color :tag "Colored")))
     155             : 
     156             :     (:strike-through
     157             :      (choice :tag "Strike-through"
     158             :              :help-echo "Control text strike-through."
     159             :              (const :tag "Off" nil)
     160             :              (const :tag "On" t)
     161             :              (color :tag "Colored")))
     162             : 
     163             :     (:box
     164             :      ;; Fixme: this can probably be done better.
     165             :      (choice :tag "Box around text"
     166             :              :help-echo "Control box around text."
     167             :              (const :tag "Off" nil)
     168             :              (list :tag "Box"
     169             :                    :value (:line-width 2 :color "grey75" :style released-button)
     170             :                    (const :format "" :value :line-width)
     171             :                    (integer :tag "Width")
     172             :                    (const :format "" :value :color)
     173             :                    (choice :tag "Color" (const :tag "*" nil) color)
     174             :                    (const :format "" :value :style)
     175             :                    (choice :tag "Style"
     176             :                            (const :tag "Raised" released-button)
     177             :                            (const :tag "Sunken" pressed-button)
     178             :                            (const :tag "None" nil))))
     179             :      ;; filter to make value suitable for customize
     180             :      (lambda (real-value)
     181             :        (and real-value
     182             :             (let ((lwidth
     183             :                    (or (and (consp real-value)
     184             :                             (plist-get real-value :line-width))
     185             :                        (and (integerp real-value) real-value)
     186             :                        1))
     187             :                   (color
     188             :                    (or (and (consp real-value) (plist-get real-value :color))
     189             :                        (and (stringp real-value) real-value)
     190             :                        nil))
     191             :                   (style
     192             :                    (and (consp real-value) (plist-get real-value :style))))
     193             :               (list :line-width lwidth :color color :style style))))
     194             :      ;; filter to make customized-value suitable for storing
     195             :      (lambda (cus-value)
     196             :        (and cus-value
     197             :             (let ((lwidth (plist-get cus-value :line-width))
     198             :                   (color (plist-get cus-value :color))
     199             :                   (style (plist-get cus-value :style)))
     200             :               (cond ((and (null color) (null style))
     201             :                      lwidth)
     202             :                     ((and (null lwidth) (null style))
     203             :                      ;; actually can't happen, because LWIDTH is always an int
     204             :                      color)
     205             :                     (t
     206             :                      ;; Keep as a plist, but remove null entries
     207             :                      (nconc (and lwidth `(:line-width ,lwidth))
     208             :                             (and color  `(:color ,color))
     209             :                             (and style  `(:style ,style)))))))))
     210             : 
     211             :     (:inverse-video
     212             :      (choice :tag "Inverse-video"
     213             :              :help-echo "Control whether text should be in inverse-video."
     214             :              (const :tag "Off" nil)
     215             :              (const :tag "On" t)))
     216             : 
     217             :     (:foreground
     218             :      (color :tag "Foreground"
     219             :             :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
     220             : 
     221             :     (:distant-foreground
     222             :      (color :tag "Distant Foreground"
     223             :             :help-echo "Set distant foreground color (name or #RRGGBB hex spec)."))
     224             : 
     225             :     (:background
     226             :      (color :tag "Background"
     227             :             :help-echo "Set background color (name or #RRGGBB hex spec)."))
     228             : 
     229             :     (:stipple
     230             :      (choice :tag "Stipple"
     231             :              :help-echo "Background bit-mask"
     232             :              (const :tag "None" nil)
     233             :              (file :tag "File"
     234             :                    :help-echo "Name of bitmap file."
     235             :                    :must-match t)))
     236             : 
     237             :     (:inherit
     238             :      (repeat :tag "Inherit"
     239             :              :help-echo "List of faces to inherit attributes from."
     240             :              (face :Tag "Face" default))
     241             :      ;; filter to make value suitable for customize
     242             :      (lambda (real-value)
     243             :        (cond ((or (null real-value) (eq real-value 'unspecified))
     244             :               nil)
     245             :              ((symbolp real-value)
     246             :               (list real-value))
     247             :              (t
     248             :               real-value)))
     249             :      ;; filter to make customized-value suitable for storing
     250             :      (lambda (cus-value)
     251             :        (if (and (consp cus-value) (null (cdr cus-value)))
     252             :            (car cus-value)
     253             :          cus-value))))
     254             : 
     255             :   "Alist of face attributes.
     256             : 
     257             : The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
     258             : where KEY is the name of the attribute, TYPE is a widget type for
     259             : editing the attribute, PRE-FILTER is a function to make the attribute's
     260             : value suitable for the customization widget, and POST-FILTER is a
     261             : function to make the customized value suitable for storing.  PRE-FILTER
     262             : and POST-FILTER are optional.
     263             : 
     264             : The PRE-FILTER should take a single argument, the attribute value as
     265             : stored, and should return a value for customization (using the
     266             : customization type TYPE).
     267             : 
     268             : The POST-FILTER should also take a single argument, the value after
     269             : being customized, and should return a value suitable for setting the
     270             : given face attribute.")
     271             : 
     272             : (defun custom-face-attributes-get (face frame)
     273             :   "For FACE on FRAME, return an alternating list describing its attributes.
     274             : The list has the form (KEYWORD VALUE KEYWORD VALUE...).
     275             : Each keyword should be listed in `custom-face-attributes'.
     276             : 
     277             : If FRAME is nil, use the global defaults for FACE."
     278           0 :   (let ((attrs custom-face-attributes)
     279             :         plist)
     280           0 :     (while attrs
     281           0 :       (let* ((attribute (car (car attrs)))
     282           0 :              (value (face-attribute face attribute frame)))
     283           0 :         (setq attrs (cdr attrs))
     284           0 :         (unless (or (eq value 'unspecified)
     285           0 :                     (and (null value) (memq attribute '(:inherit))))
     286           0 :           (setq plist (cons attribute (cons value plist))))))
     287           0 :     plist))
     288             : 
     289             : ;;; Initializing.
     290             : 
     291             : (defun custom-set-faces (&rest args)
     292             :   "Apply a list of face specs for user customizations.
     293             : This works by calling `custom-theme-set-faces' for the `user'
     294             : theme, a special theme referring to settings made via Customize.
     295             : The arguments should be a list where each entry has the form:
     296             : 
     297             :   (FACE SPEC [NOW [COMMENT]])
     298             : 
     299             : See the documentation of `custom-theme-set-faces' for details."
     300           0 :   (apply 'custom-theme-set-faces 'user args))
     301             : 
     302             : (defun custom-theme-set-faces (theme &rest args)
     303             :   "Apply a list of face specs associated with theme THEME.
     304             : THEME should be a theme name (a symbol).  The special theme named
     305             : `user' refers to user settings applied via Customize.
     306             : 
     307             : The remaining ARGS should be a list where each entry is a list of
     308             : the form:
     309             : 
     310             :   (FACE SPEC [NOW [COMMENT]])
     311             : 
     312             : FACE should be a face name (a symbol).  If FACE is a face alias,
     313             : the setting refers to the parent face.
     314             : 
     315             : SPEC should be a face spec.  For details, see `defface'.
     316             : 
     317             : NOW, if present and non-nil, forces the face settings to take
     318             : immediate effect in the Emacs display; in particular, FACE is
     319             : initialized as a face if it is not yet one.  If NOW is omitted or
     320             : nil, the caller is responsible for making the settings take
     321             : effect later, by calling `custom-theme-recalc-face' or
     322             : `face-spec-recalc'.
     323             : 
     324             : COMMENT is a string comment about FACE.
     325             : 
     326             : This function works by calling `custom-push-theme' to record each
     327             : SPEC in each FACE's `theme-face' property, and in THEME's
     328             : `theme-settings' property.  If FACE has not already been
     329             : customized, it also stores SPEC in the `saved-face' property.
     330             : 
     331             : If THEME has a non-nil `theme-immediate' property, this is
     332             : equivalent to providing the NOW argument to all faces in the
     333             : argument list."
     334           0 :   (custom-check-theme theme)
     335           0 :   (let ((immediate (get theme 'theme-immediate)))
     336           0 :     (dolist (entry args)
     337           0 :       (unless (listp entry)
     338           0 :         (error "Incompatible Custom theme spec"))
     339           0 :       (let ((face (car entry))
     340           0 :             (spec (nth 1 entry)))
     341             :         ;; If FACE is actually an alias, customize the face it
     342             :         ;; is aliased to.
     343           0 :         (if (get face 'face-alias)
     344           0 :             (setq face (get face 'face-alias)))
     345           0 :         (if custom--inhibit-theme-enable
     346             :             ;; Just update theme settings.
     347           0 :             (custom-push-theme 'theme-face face theme 'set spec)
     348             :           ;; Update theme settings and set the face spec.
     349           0 :           (let ((now (nth 2 entry))
     350           0 :                 (comment (nth 3 entry))
     351           0 :                 (oldspec (get face 'theme-face)))
     352           0 :             (when (not (and oldspec (eq 'user (caar oldspec))))
     353           0 :               (put face 'saved-face spec)
     354           0 :               (put face 'saved-face-comment comment))
     355           0 :             (custom-push-theme 'theme-face face theme 'set spec)
     356           0 :             (when (or now immediate)
     357           0 :               (put face 'force-face (if now 'rogue 'immediate)))
     358           0 :             (when (or now immediate (facep face))
     359           0 :               (put face 'face-comment comment)
     360           0 :               (face-spec-set face spec t))))))))
     361             : 
     362             : ;; XEmacs compatibility function.  In XEmacs, when you reset a Custom
     363             : ;; Theme, you have to specify the theme to reset it to.  We just apply
     364             : ;; the next theme.
     365             : (defun custom-theme-reset-faces (theme &rest args)
     366             :   "Reset the specs in THEME of some faces to their specs in other themes.
     367             : Each of the arguments ARGS has this form:
     368             : 
     369             :     (FACE IGNORED)
     370             : 
     371             : This means reset FACE.  The argument IGNORED is ignored."
     372           0 :   (custom-check-theme theme)
     373           0 :   (dolist (arg args)
     374           0 :     (custom-push-theme 'theme-face (car arg) theme 'reset)))
     375             : 
     376             : (defun custom-reset-faces (&rest args)
     377             :   "Reset the specs of some faces to their specs in specified themes.
     378             : This creates settings in the `user' theme.
     379             : 
     380             : Each of the arguments ARGS has this form:
     381             : 
     382             :     (FACE FROM-THEME)
     383             : 
     384             : This means reset FACE to its value in FROM-THEME."
     385           0 :   (apply 'custom-theme-reset-faces 'user args))
     386             : 
     387             : ;;; The End.
     388             : 
     389             : (provide 'cus-face)
     390             : 
     391             : ;;; cus-face.el ends here

Generated by: LCOV version 1.12