home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / x11 / x-faces.el < prev    next >
Encoding:
Text File  |  1993-03-31  |  19.0 KB  |  506 lines
  1. ;; X -specific face frobnication.
  2. ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;; This file does the magic to parse X font names, and make sure that the
  21. ;; default and modeline attributes of new screens are specified enough.
  22. ;;
  23. ;;  The resource-manager syntax for faces is
  24. ;;
  25. ;;     Emacs*bold.attributeFont:        font-name
  26. ;;     Emacs*bold.attributeColor:        color
  27. ;;     Emacs*bold.attributeForeground:    fg
  28. ;;     Emacs*bold.attributeBackground:    bg
  29. ;;     Emacs*bold.attributeBackgroundPixmap:    file
  30. ;;     Emacs*bold.attributeUnderline:        true/false
  31. ;;
  32. ;;  You can specify the parameters of a face on a per-screen basis.  For 
  33. ;;  example, to have the "isearch" face use a red foreground on screens
  34. ;;  named "emacs" (the default) but use a blue foreground on screens that
  35. ;;  you create named "debugger", you could do
  36. ;;
  37. ;;     Emacs*emacs.isearch.attributeForeground:    red
  38. ;;     Emacs*debugger.isearch.attributeForeground:    blue
  39. ;;
  40. ;;  Generally things that make faces won't set any of the face attributes if
  41. ;;  you have already given them values via the resource database.  You can
  42. ;;  also change this stuff from your .emacs file, by using the functions
  43. ;;  set-face-foreground, set-face-font, etc.  See the code in this file, and
  44. ;;  in faces.el.
  45.  
  46. (defconst x-font-regexp nil)
  47. (defconst x-font-regexp-head nil)
  48. (defconst x-font-regexp-weight nil)
  49. (defconst x-font-regexp-slant nil)
  50.  
  51. ;;; Regexps matching font names in "Host Portable Character Representation."
  52. ;;;
  53. (let ((-         "[-?]")
  54.       (foundry        "[^-]+")
  55.       (family         "[^-]+")
  56.       (weight        "\\(bold\\|demibold\\|medium\\)")        ; 1
  57. ;     (weight\?        "\\(\\*\\|bold\\|demibold\\|medium\\|\\)")    ; 1
  58.       (weight\?        "\\([^-]*\\)")                    ; 1
  59.       (slant        "\\([ior]\\)")                    ; 2
  60. ;     (slant\?        "\\([ior?*]?\\)")                ; 2
  61.       (slant\?        "\\([^-]?\\)")                    ; 2
  62. ;     (swidth        "\\(\\*\\|normal\\|semicondensed\\|\\)")    ; 3
  63.       (swidth        "\\([^-]*\\)")                    ; 3
  64. ;     (adstyle        "\\(\\*\\|sans\\|\\)")                ; 4
  65.       (adstyle        "[^-]*")                    ; 4
  66.       (pixelsize    "[0-9]+")
  67.       (pointsize    "[0-9][0-9]+")
  68.       (resx        "[0-9][0-9]+")
  69.       (resy        "[0-9][0-9]+")
  70.       (spacing        "[cmp?*]")
  71.       (avgwidth        "[0-9]+")
  72.       (registry        "[^-]+")
  73.       (encoding        "[^-]+")
  74.       )
  75.   (setq x-font-regexp
  76.     (concat "\\`\\*?[-?*]"
  77.         foundry - family - weight\? - slant\? - swidth - adstyle -
  78.         pixelsize - pointsize - resx - resy - spacing - registry -
  79.         encoding "[-?*]\\*?\\'"
  80.         ))
  81.   (setq x-font-regexp-head
  82.     (concat "\\`[-?*]" foundry - family - weight\? - slant\?
  83.         "\\([-*?]\\|\\'\\)"))
  84.   (setq x-font-regexp-slant (concat - slant -))
  85.   (setq x-font-regexp-weight (concat - weight -))
  86.   nil)        
  87.  
  88. (defun x-frob-font-weight (font which)
  89.   (if (or (string-match x-font-regexp font)
  90.       (string-match x-font-regexp-head font)
  91.       (string-match x-font-regexp-weight font))
  92.       (concat (substring font 0 (match-beginning 1)) which
  93.           (substring font (match-end 1)))
  94.     nil))
  95.  
  96. (defun x-frob-font-slant (font which)
  97.   (cond ((or (string-match x-font-regexp font)
  98.          (string-match x-font-regexp-head font))
  99.      (concat (substring font 0 (match-beginning 2)) which
  100.          (substring font (match-end 2))))
  101.     ((string-match x-font-regexp-slant font)
  102.      (concat (substring font 0 (match-beginning 1)) which
  103.          (substring font (match-end 1))))
  104.     (t nil)))
  105.  
  106.  
  107. (defun x-make-font-bold (font)
  108.   "Given an X font specification, this attempts to make a `bold' version
  109. of it.  If it fails, it returns nil."
  110.   (x-frob-font-weight font "bold"))
  111.  
  112. (defun x-make-font-demibold (font)
  113.   "Given an X font specification, this attempts to make a `demibold' version
  114. of it.  If it fails, it returns nil."
  115.   (x-frob-font-weight font "demibold"))
  116.  
  117. (defun x-make-font-unbold (font)
  118.   "Given an X font specification, this attempts to make a non-bold version
  119. of it.  If it fails, it returns nil."
  120.   (x-frob-font-weight font "medium"))
  121.  
  122. (defun x-make-font-italic (font)
  123.   "Given an X font specification, this attempts to make an `italic' version
  124. of it.  If it fails, it returns nil."
  125.   (x-frob-font-slant font "i"))
  126.  
  127. (defun x-make-font-oblique (font) ; you say tomayto...
  128.   "Given an X font specification, this attempts to make an `italic' version
  129. of it.  If it fails, it returns nil."
  130.   (x-frob-font-slant font "o"))
  131.  
  132. (defun x-make-font-unitalic (font)
  133.   "Given an X font specification, this attempts to make a non-italic version
  134. of it.  If it fails, it returns nil."
  135.   (x-frob-font-slant font "r"))
  136.  
  137.  
  138. ;;; non-X-specific interface
  139.  
  140. (defun make-face-bold (face &optional screen)
  141.   "Make the font of the given face be bold, if possible.  
  142. Returns nil on failure."
  143.   (interactive (list (read-face-name "Make which face bold: ")))
  144.   (let ((ofont (or (face-font face screen)
  145.            (face-font face t)
  146.            (face-font 'default screen))))
  147.     (if (null screen)
  148.     (let ((screens (screen-list)))
  149.       (while screens
  150.         (make-face-bold face (car screens))
  151.         (setq screens (cdr screens))))
  152.       (setq face (get-face face screen))
  153.       (let ((font (or (face-font face screen)
  154.               (face-font face t)
  155.               (face-font 'default screen)))
  156.         f2)
  157.     (or (and (setq f2 (x-make-font-bold font))
  158.          (try-face-font face f2))
  159.         (and (setq f2 (x-make-font-demibold font))
  160.          (try-face-font face f2)))))
  161.     (not (equal ofont (or (face-font face) ofont)))))
  162.  
  163. (defun make-face-italic (face &optional screen)
  164.   "Make the font of the given face be italic, if possible.  
  165. Returns nil on failure."
  166.   (interactive (list (read-face-name "Make which face italic: ")))
  167.   (let ((ofont (or (face-font face screen)
  168.            (face-font face t)
  169.            (face-font 'default screen))))
  170.     (if (null screen)
  171.     (let ((screens (screen-list)))
  172.       (while screens
  173.         (make-face-italic face (car screens))
  174.         (setq screens (cdr screens))))
  175.       (setq face (get-face face screen))
  176.       (let ((font (or (face-font face screen)
  177.               (face-font face t)
  178.               (face-font 'default screen)))
  179.         f2)
  180.     (or (and (setq f2 (x-make-font-italic font))
  181.          (try-face-font face f2))
  182.         (and (setq f2 (x-make-font-oblique font))
  183.          (try-face-font face f2)))))
  184.     (not (equal ofont (or (face-font face) ofont)))))
  185.  
  186. (defun make-face-bold-italic (face &optional screen)
  187.   "Make the font of the given face be bold and italic, if possible.  
  188. Returns nil on failure."
  189.   (interactive (list (read-face-name "Make which face bold-italic: ")))
  190.   (let ((ofont (or (face-font face screen)
  191.            (face-font face t)
  192.            (face-font 'default screen))))
  193.     (if (null screen)
  194.     (let ((screens (screen-list)))
  195.       (while screens
  196.         (make-face-bold-italic face (car screens))
  197.         (setq screens (cdr screens))))
  198.       (setq face (get-face face screen))
  199.       (let ((font (or (face-font face screen)
  200.               (face-font face t)
  201.               (face-font 'default screen)))
  202.         f2 f3)
  203.     (or (and (setq f2 (x-make-font-italic font))
  204.          (not (equal font f2))
  205.          (setq f3 (x-make-font-bold f2))
  206.          (not (equal f2 f3))
  207.          (try-face-font face f3))
  208.         (and (setq f2 (x-make-font-oblique font))
  209.          (not (equal font f2))
  210.          (setq f3 (x-make-font-bold f2))
  211.          (not (equal f2 f3))
  212.          (try-face-font face f3))
  213.         (and (setq f2 (x-make-font-italic font))
  214.          (not (equal font f2))
  215.          (setq f3 (x-make-font-demibold f2))
  216.          (not (equal f2 f3))
  217.          (try-face-font face f3))
  218.         (and (setq f2 (x-make-font-oblique font))
  219.          (not (equal font f2))
  220.          (setq f3 (x-make-font-demibold f2))
  221.          (not (equal f2 f3))
  222.          (try-face-font face f3)))))
  223.     (not (equal ofont (or (face-font face screen) ofont)))))
  224.  
  225. (defun make-face-unbold (face &optional screen)
  226.   "Make the font of the given face be non-bold, if possible.  
  227. Returns nil on failure."
  228.   (interactive (list (read-face-name "Make which face non-bold: ")))
  229.   (let ((ofont (or (face-font face screen)
  230.            (face-font face t)
  231.            (face-font 'default screen))))
  232.     (if (null screen)
  233.     (let ((screens (screen-list)))
  234.       (while screens
  235.         (make-face-unbold face (car screens))
  236.         (setq screens (cdr screens))))
  237.       (setq face (get-face face screen))
  238.       (let ((font (x-make-font-unbold
  239.            (or (face-font face screen)
  240.                (face-font face t)
  241.                (face-font 'default screen)))))
  242.     (if font (try-face-font face font))))
  243.     (not (equal ofont (or (face-font face screen) ofont)))))
  244.  
  245. (defun make-face-unitalic (face &optional screen)
  246.   "Make the font of the given face be non-italic, if possible.  
  247. Returns nil on failure."
  248.   (interactive (list (read-face-name "Make which face non-italic: ")))
  249.   (let ((ofont (or (face-font face screen)
  250.            (face-font face t)
  251.            (face-font 'default screen))))
  252.     (if (null screen)
  253.     (let ((screens (screen-list)))
  254.       (while screens
  255.         (make-face-unitalic face (car screens))
  256.         (setq screens (cdr screens))))
  257.       (setq face (get-face face screen))
  258.       (let ((font (x-make-font-unitalic
  259.            (or (face-font face screen)
  260.                (face-font face t)
  261.                (face-font 'default screen)))))
  262.     (if font (try-face-font face font))))
  263.     (not (equal ofont (or (face-font face screen) ofont)))))
  264.  
  265.  
  266. ;;; internal routines
  267.  
  268. ;;; This is called from make-face to read the initial values of the face
  269. ;;; from the resource database.  (Later calls to set-face-mumble may override
  270. ;;; these values.)  This is also called from make-screen-initial-faces before
  271. ;;; the initial X screen is mapped, so it had better not signal an error.
  272. ;;;
  273. (defun x-resource-face (face &optional screen set-anyway)
  274.   (cond
  275.    ((null screen)
  276.     (let ((screens (screen-list)))
  277.       (while screens
  278.     (x-resource-face (face-name face) (car screens) set-anyway)
  279.     (setq screens (cdr screens)))))
  280.    (t
  281.     (setq face (get-face (face-name face) screen))
  282.     ;;
  283.     ;; These are things like "attributeForeground" instead of simply
  284.     ;; "foreground" because people tend to do things like "*foreground",
  285.     ;; which would cause all faces to be fully qualified, making faces
  286.     ;; inherit attributes in a non-useful way.  So we've made them slightly
  287.     ;; less obvious to specify in order to make them work correctly in
  288.     ;; more random environments.
  289.     ;;
  290.     ;; I think these should be called "face.faceForeground" instead of
  291.     ;; "face.attributeForeground", but they're the way they are for
  292.     ;; hysterical reasons.
  293.     ;; 
  294.     (let* ((name (symbol-name (face-name face)))
  295.        (fn  (or (x-get-resource (concat name ".attributeFont")
  296.                     "Face.AttributeFont"
  297.                     'string screen)
  298.             (and set-anyway (face-font face))))
  299.        (fg  (or (x-get-resource (concat name ".attributeForeground")
  300.                     "Face.AttributeForeground" 'string screen)
  301.             (and set-anyway (face-foreground face))))
  302.        (bg  (or (x-get-resource (concat name ".attributeBackground")
  303.                     "Face.AttributeBackground" 'string screen)
  304.             (and set-anyway (face-background face))))
  305.        (bgp (or (x-get-resource (concat name ".attributeBackgroundPixmap")
  306.                     "Face.AttributeBackgroundPixmap" 'string
  307.                     screen)
  308.             (and set-anyway (face-background-pixmap face))))
  309.        (ulp (or (x-get-resource (concat name ".attributeUnderline")
  310.                     "Face.AttributeUnderline" 'boolean screen)
  311.             (and set-anyway (face-underline-p face))))
  312.        )
  313.       ;;
  314.       ;; If this is the default face, then any unspecified parameters should
  315.       ;; be defaulted from the properties of the "screen".  This is a hack...
  316.       ;;
  317.       (if (eq (face-name face) 'default)
  318.       (progn
  319.         (or fn (setq fn (x-get-resource "font" "Font" 'string screen)))
  320.         (or fg (setq fg (x-get-resource "foreground" "Foreground"
  321.                         'string screen)))
  322.         (or bg (setq bg (x-get-resource "background" "Background"
  323.                         'string screen)))))
  324.       (if fn
  325.       (condition-case ()
  326.           (set-face-font face fn screen)
  327.         (error (message "font %s not found for face %s" fn name))))
  328.       (if fg
  329.       (condition-case ()
  330.           (set-face-foreground face fg screen)
  331.         (error (message "color %s not allocated for face %s" fg name))))
  332.       (if bg
  333.       (condition-case ()
  334.           (set-face-background face bg screen)
  335.         (error (message "color %s not allocated for face %s" bg name))))
  336.       (if bgp
  337.       (condition-case ()
  338.           (set-face-background-pixmap face bgp screen)
  339.         (error (message "pixmap %s not found for face %s" bgp name))))
  340.       (if (or ulp set-anyway)
  341.       (set-face-underline-p face ulp screen))
  342.       )))
  343.   face)
  344.  
  345.  
  346. ;;; This is called from make-screen-initial-faces to make sure that the
  347. ;;; "default" and "modeline" faces for this screen have enough attributes
  348. ;;; specified for emacs to be able to display anything on it.  This had
  349. ;;; better not signal an error.
  350. ;;;
  351. (defun x-initialize-screen-faces (screen)
  352.   (let ((default (get-face 'default screen))
  353.     (modeline (get-face 'modeline screen)))
  354.     (or
  355.      (face-font default screen)
  356.      ;;
  357.      ;; No font specified in the resource database; try to cope.
  358.      ;;
  359.      ;; At first I wanted to do this by just putting a font-spec in the
  360.      ;; fallback resources passed to XtAppInitialize(), but that fails
  361.      ;; if there is an Emacs app-defaults file which doesn't specify a
  362.      ;; font: apparently the fallback resources are not consulted when
  363.      ;; there is an app-defaults file, which seems pretty bogus to me.
  364.      ;;
  365.      ;; We should also probably try "*xtDefaultFont", but I think that it
  366.      ;; might be legal to specify that as "xtDefaultFont:", that is, at
  367.      ;; top level, instead of "*xtDefaultFont:", that is, applicable to
  368.      ;; every application.  `x-get-resource' can't handle that right now.
  369.      ;;
  370.      (try-face-font default "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*"
  371.             screen)
  372.      (try-face-font default "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*"
  373.             screen)
  374.      (try-face-font default "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*" screen)
  375.      (try-face-font default "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*" screen)
  376.      (try-face-font default "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*" screen)
  377.      (try-face-font default "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*" screen)
  378.      (try-face-font default "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*" screen)
  379.      ;; if we get to here we're screwed, and faces.c will fatal()...
  380.      )
  381.     ;;
  382.     ;; If the "default" face didn't have both colors specified, then pick
  383.     ;; some, taking into account the "reverseVideo" resource, as well as
  384.     ;; whether one of the colors was specified.  
  385.     ;;
  386.     (let ((fg (face-foreground default screen))
  387.       (bg (face-background default screen)))
  388.       (if (not (and fg bg))
  389.       (if (or (and fg (equal (downcase fg) "white"))
  390.           (and bg (equal (downcase bg) "black"))
  391.           (car (x-get-resource "reverseVideo" "ReverseVideo"
  392.                        'boolean screen)))
  393.           (progn
  394.         (or fg (set-face-foreground default "white" screen))
  395.         (or bg (set-face-background default "black" screen)))
  396.         (or fg (set-face-foreground default "black" screen))
  397.         (or bg (set-face-background default "white" screen)))))
  398.     ;;
  399.     ;; Now let's try to pick some reasonable defaults for a few other faces.
  400.     ;; This kind of stuff should normally go on the create-screen-hook, but
  401.     ;; this way we won't be in danger of the user screwing things up by not
  402.     ;; adding hooks in a safe way.
  403.     ;;
  404.     (let ((pre-display-buffer-function nil) ; we're on thin ice here...
  405.       (stack-trace-on-error nil)
  406.       (debug-on-error nil))
  407.       (x-initialize-other-random-faces screen)
  408.       (x-initialize-pointer-shape screen)  ; from x-mouse.el
  409.       )))
  410.  
  411.  
  412. (defun x-complain-about-font (face)
  413.   (if (symbolp face) (setq face (symbol-name face)))
  414.   (princ (format "%s: couldn't deduce %s %s version of %S\n"
  415.          invocation-name
  416.          (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
  417.          face
  418.          (face-font 'default))
  419.      (function external-debugging-output)))
  420.  
  421. (defun x-initialize-other-random-faces (screen)
  422.   "Initializes the colors and fonts of the bold, italic, bold-italic, 
  423. primary-selection, secondary-selection, and isearch faces when each
  424. screen is created.  If you want to add code to do stuff like this, use
  425. the create-screen-hook."
  426.  
  427.   (or (face-differs-from-default-p 'bold screen)
  428.       (make-face-bold 'bold screen)
  429.       ;; if default font is bold, then make the `bold' face be unbold.
  430.       (make-face-unbold 'bold screen)
  431.       ;; otherwise the luser specified one of the bogus font names
  432.       (x-complain-about-font 'bold)
  433.       )
  434.  
  435.   (or (face-differs-from-default-p 'italic screen)
  436.       (make-face-italic 'italic screen)
  437.       (progn
  438.     (make-face-bold 'italic screen) ; bold if possible, then complain
  439.     (x-complain-about-font 'italic))
  440.       )
  441.  
  442.   (or (face-differs-from-default-p 'bold-italic screen)
  443.       (make-face-bold-italic 'bold-italic screen)
  444.       ;; if we couldn't get a bold-italic version, try just bold.
  445.       (make-face-bold 'bold-italic screen)
  446.       ;; if we couldn't get bold or bold-italic, then that's probably because
  447.       ;; the default font is bold, so make the `bold-italic' face be unbold.
  448.       (and (make-face-unbold 'bold-italic screen)
  449.        (make-face-italic 'bold-italic screen))
  450.       ;; if that didn't work, try italic (can this ever happen? what the hell.)
  451.       (progn
  452.     (make-face-italic 'bold-italic screen)
  453.     ;; then bitch and moan.
  454.     (x-complain-about-font 'bold-italic))
  455.       )
  456.  
  457.   (or (find-face 'primary-selection)
  458.       (make-face 'primary-selection))
  459.  
  460.   (or (find-face 'secondary-selection)
  461.       (make-face 'secondary-selection))
  462.  
  463.   (or (face-differs-from-default-p 'highlight screen)
  464.       (condition-case ()
  465.       (if (x-color-display-p)
  466.               (condition-case ()
  467.           (set-face-background 'highlight "darkseagreen2" screen)
  468.                 (error (set-face-background 'highlight "green" screen)))
  469.         (set-face-background-pixmap 'highlight "gray1" screen))
  470.     (error (invert-face 'highlight screen))))
  471.  
  472.   (or (face-differs-from-default-p 'primary-selection screen)
  473.       (condition-case ()
  474.       (if (x-color-display-p)
  475.           (set-face-background 'primary-selection "gray" screen)
  476.         (set-face-background-pixmap 'primary-selection "gray3" screen))
  477.     (error (invert-face 'primary-selection screen))))
  478.  
  479.   (or (face-differs-from-default-p 'secondary-selection screen)
  480.       (condition-case ()
  481.       (if (x-color-display-p)
  482.               (condition-case ()
  483.           ;; some older X servers don't have this one.
  484.           (set-face-background 'secondary-selection "paleturquoise"
  485.                        screen)
  486.         (error
  487.          (set-face-background 'secondary-selection "green" screen)))
  488.         (set-face-background-pixmap 'secondary-selection "gray1" screen))
  489.     (error (invert-face 'secondary-selection screen))))
  490.  
  491.   (or (face-differs-from-default-p 'isearch screen)
  492.       (if (x-color-display-p)
  493.       (condition-case ()
  494.           (set-face-background 'isearch "paleturquoise" screen)
  495.         (error
  496.          (condition-case ()
  497.          (set-face-background 'isearch "green" screen)
  498.            (error nil))))
  499.     nil)
  500.       (make-face-bold 'isearch screen)
  501.       ;; if default font is bold, then make the `isearch' face be unbold.
  502.       (make-face-unbold 'isearch screen))
  503.   )
  504.  
  505. (provide 'x-faces)
  506.