lisp/gtk-faces.el

   1 ;;; gtk-faces.el --- GTK-specific face frobnication, aka black magic.
   2
   3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995, 1996 Ben Wing.
   5 ;; Copyright (c) 2000 William Perry
   6
   7 ;; Author: William M. Perry <wmperry@gnu.org>
   8 ;; Maintainer: XEmacs Development Team
   9 ;; Keywords: extensions, internal, dumped
  10
  11 ;; This file is part of XEmacs.
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XEmacs is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Synched up with: Not synched.
  29
  30 ;;; Commentary:
  31
  32 ;; This file is dumped with XEmacs (when GTK support is compiled in).
  33
  34
  35 (defun gtk-init-find-device ()
  36   (let ((dev nil)
  37         (devices (device-list)))
  38     (while (and (not dev) devices)
  39       (if (eq (device-type (car devices)) 'gtk)
  40           (setq dev (car devices)))
  41       (setq devices (cdr devices)))
  42     dev))
  43
  44 ;;; gtk-init-device-faces is responsible for initializing default
  45 ;;; values for faces on a newly created device.
  46 ;;;
  47 (defun gtk-init-device-faces (device)
  48   ;;
  49   ;; If the "default" face didn't have a font specified, try to pick one.
  50   ;;
  51   (if (not (eq (device-type device) 'gtk))
  52       nil
  53     (gtk-init-pointers)
  54     (let* ((style (gtk-style-info device))
  55            ;;(normal 0)                 ; GTK_STATE_NORMAL
  56            ;;(active 1)                 ; GTK_STATE_ACTIVE
  57            (prelight 2)                 ; GTK_STATE_PRELIGHT
  58            (selected 3)                 ; GTK_STATE_SELECTED
  59            ;;(insensitive 4)            ; GTK_STATE_INSENSITIVE
  60            )
  61       (set-face-foreground 'highlight
  62                            (nth prelight (plist-get style 'text))
  63                            device)
  64       (set-face-background 'highlight
  65                            (nth prelight (plist-get style 'background))
  66                            device)
  67       (set-face-foreground 'zmacs-region
  68                            (nth selected (plist-get style 'text))
  69                            device)
  70       (set-face-background 'zmacs-region
  71                            (nth selected (plist-get style 'background))
  72                            device))
  73     (set-face-background 'text-cursor "red3" device)))
  74
  75 ;;; This is called from `init-frame-faces', which is called from
  76 ;;; init_frame_faces() which is called from Fmake_frame(), to perform
  77 ;;; any device-specific initialization.
  78 ;;;
  79 (defun gtk-init-frame-faces (frame)
  80   )
  81
  82 ;;; gtk-init-global-faces is responsible for ensuring that the
  83 ;;; default face has some reasonable fallbacks if nothing else is
  84 ;;; specified.
  85 ;;;
  86 (defun gtk-init-global-faces ()
  87   (let* ((dev (gtk-init-find-device))
  88          (default-font (or (face-font 'default 'global)
  89                            ;(plist-get (gtk-style-info dev) 'font)
  90                            "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*"))
  91          (italic-font (or (gtk-make-font-italic default-font dev) default-font))
  92          (bold-font (or (gtk-make-font-bold default-font dev) default-font))
  93          (bi-font (or (gtk-make-font-bold-italic default-font dev) default-font)))
  94
  95     (or (face-font 'default 'global)
  96         (set-face-font 'default default-font 'global '(gtk default)))
  97
  98     (or (face-font 'bold 'global)
  99         (set-face-font 'bold bold-font 'global '(gtk default)))
 100
 101     (or (face-font 'bold-italic 'global)
 102         (set-face-font 'bold-italic bi-font 'global '(gtk default)))
 103
 104     (or (face-font 'italic 'global)
 105         (set-face-font 'italic italic-font 'global '(gtk default)))))
 106
 107 \f
 108 ;;; Lots of this stolen from x-faces.el - I'm not sure if this will
 109 ;;; require a rewrite for win32 or not?
 110 (defconst gtk-font-regexp nil)
 111 (defconst gtk-font-regexp-head nil)
 112 (defconst gtk-font-regexp-head-2 nil)
 113 (defconst gtk-font-regexp-weight nil)
 114 (defconst gtk-font-regexp-slant nil)
 115 (defconst gtk-font-regexp-pixel nil)
 116 (defconst gtk-font-regexp-point nil)
 117 (defconst gtk-font-regexp-foundry-and-family nil)
 118 (defconst gtk-font-regexp-registry-and-encoding nil)
 119 (defconst gtk-font-regexp-spacing nil)
 120
 121 ;;; Regexps matching font names in "Host Portable Character Representation."
 122 ;;;
 123 (let ((-                "[-?]")
 124       (foundry          "[^-]*")
 125       (family           "[^-]*")
 126       (weight           "\\(bold\\|demibold\\|medium\\|black\\)")       ; 1
 127 ;     (weight\?         "\\(\\*\\|bold\\|demibold\\|medium\\|\\)")      ; 1
 128       (weight\?         "\\([^-]*\\)")                                  ; 1
 129       (slant            "\\([ior]\\)")                                  ; 2
 130 ;     (slant\?          "\\([ior?*]?\\)")                               ; 2
 131       (slant\?          "\\([^-]?\\)")                                  ; 2
 132 ;     (swidth           "\\(\\*\\|normal\\|semicondensed\\|\\)")        ; 3
 133       (swidth           "\\([^-]*\\)")                                  ; 3
 134 ;     (adstyle          "\\(\\*\\|sans\\|\\)")                          ; 4
 135       (adstyle          "\\([^-]*\\)")                                  ; 4
 136       (pixelsize        "\\(\\*\\|[0-9]+\\)")                           ; 5
 137       (pointsize        "\\(\\*\\|0\\|[0-9][0-9]+\\)")                  ; 6
 138 ;      (resx            "\\(\\*\\|[0-9][0-9]+\\)")                      ; 7
 139 ;      (resy            "\\(\\*\\|[0-9][0-9]+\\)")                      ; 8
 140       (resx             "\\([*0]\\|[0-9][0-9]+\\)")                     ; 7
 141       (resy             "\\([*0]\\|[0-9][0-9]+\\)")                     ; 8
 142       (spacing          "[cmp?*]")
 143       (avgwidth         "\\(\\*\\|[0-9]+\\)")                           ; 9
 144       (registry         "[^-]*") ; some fonts have omitted registries
 145 ;      (encoding        ".+")           ; note that encoding may contain "-"...
 146       (encoding "[^-]+")                ; false!
 147       )
 148   (setq gtk-font-regexp
 149         (purecopy
 150          (concat "\\`\\*?[-?*]"
 151                  foundry - family - weight\? - slant\? - swidth - adstyle -
 152                  pixelsize - pointsize - resx - resy - spacing - avgwidth -
 153                  registry - encoding "\\'"
 154                  )))
 155   (setq gtk-font-regexp-head
 156         (purecopy
 157           (concat "\\`[-?*]" foundry - family - weight\? - slant\?
 158                   "\\([-*?]\\|\\'\\)")))
 159   (setq gtk-font-regexp-head-2
 160         (purecopy
 161           (concat "\\`[-?*]" foundry - family - weight\? - slant\?
 162                   - swidth - adstyle - pixelsize - pointsize
 163                   "\\([-*?]\\|\\'\\)")))
 164   (setq gtk-font-regexp-slant (purecopy (concat - slant -)))
 165   (setq gtk-font-regexp-weight (purecopy (concat - weight -)))
 166   ;; if we can't match any of the more specific regexps (unfortunate) then
 167   ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits
 168   ;; is pixels.  Bogus as hell.
 169   (setq gtk-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]"))
 170   (setq gtk-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]"))
 171   ;; the following two are used by x-font-menu.el.
 172   (setq gtk-font-regexp-foundry-and-family
 173         (purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
 174   (setq gtk-font-regexp-registry-and-encoding
 175         (purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))
 176   (setq gtk-font-regexp-spacing
 177         (purecopy (concat - "\\(" spacing "\\)" - avgwidth
 178                           - registry - encoding "\\'")))
 179   )
 180
 181 (defvaralias 'x-font-regexp 'gtk-font-regexp)
 182 (defvaralias 'x-font-regexp-head 'gtk-font-regexp-head)
 183 (defvaralias 'x-font-regexp-head-2 'gtk-font-regexp-head-2)
 184 (defvaralias 'x-font-regexp-weight 'gtk-font-regexp-weight)
 185 (defvaralias 'x-font-regexp-slant 'gtk-font-regexp-slant)
 186 (defvaralias 'x-font-regexp-pixel 'gtk-font-regexp-pixel)
 187 (defvaralias 'x-font-regexp-point 'gtk-font-regexp-point)
 188 (defvaralias 'x-font-regexp-foundry-and-family 'gtk-font-regexp-foundry-and-family)
 189 (defvaralias 'x-font-regexp-registry-and-encoding 'gtk-font-regexp-registry-and-encoding)
 190 (defvaralias 'x-font-regexp-spacing 'gtk-font-regexp-spacing)
 191
 192 (defun gtk-frob-font-weight (font which)
 193   (if (font-instance-p font) (setq font (font-instance-name font)))
 194   (cond ((null font) nil)
 195         ((or (string-match gtk-font-regexp font)
 196              (string-match gtk-font-regexp-head font)
 197              (string-match gtk-font-regexp-weight font))
 198          (concat (substring font 0 (match-beginning 1)) which
 199                  (substring font (match-end 1))))
 200         (t nil)))
 201
 202 (defun gtk-frob-font-slant (font which)
 203   (if (font-instance-p font) (setq font (font-instance-name font)))
 204   (cond ((null font) nil)
 205         ((or (string-match gtk-font-regexp font)
 206              (string-match gtk-font-regexp-head font))
 207          (concat (substring font 0 (match-beginning 2)) which
 208                  (substring font (match-end 2))))
 209         ((string-match gtk-font-regexp-slant font)
 210          (concat (substring font 0 (match-beginning 1)) which
 211                  (substring font (match-end 1))))
 212         (t nil)))
 213
 214 (defun gtk-make-font-bold (font &optional device)
 215   (or (try-font-name (gtk-frob-font-weight font "bold") device)
 216       (try-font-name (gtk-frob-font-weight font "black") device)
 217       (try-font-name (gtk-frob-font-weight font "demibold") device)))
 218
 219 (defun gtk-make-font-unbold (font &optional device)
 220   (try-font-name (gtk-frob-font-weight font "medium") device))
 221
 222 (defcustom *try-oblique-before-italic-fonts* t
 223   "*If nil, italic fonts are searched before oblique fonts.
 224 If non-nil, oblique fonts are tried before italic fonts.  This is mostly
 225 applicable to adobe-courier fonts"
 226   :type 'boolean
 227   :tag "Try Oblique Before Italic Fonts"
 228   :group 'x)
 229
 230 (defun gtk-make-font-italic (font &optional device)
 231   (if *try-oblique-before-italic-fonts*
 232       (or (try-font-name (gtk-frob-font-slant font "o") device)
 233           (try-font-name (gtk-frob-font-slant font "i") device))
 234     (or (try-font-name (gtk-frob-font-slant font "i") device)
 235         (try-font-name (gtk-frob-font-slant font "o") device))))
 236
 237 (defun gtk-make-font-unitalic (font &optional device)
 238   (try-font-name (gtk-frob-font-slant font "r") device))
 239
 240 (defun gtk-make-font-bold-italic (font &optional device)
 241   (if *try-oblique-before-italic-fonts*
 242       (or (try-font-name
 243            (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device)
 244           (try-font-name
 245            (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device)
 246           (try-font-name
 247            (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device)
 248           (try-font-name
 249            (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device)
 250           (try-font-name
 251            (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device)
 252           (try-font-name
 253            (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device))
 254     (or (try-font-name
 255          (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device)
 256         (try-font-name
 257          (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device)
 258         (try-font-name
 259          (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device)
 260         (try-font-name
 261          (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device)
 262         (try-font-name
 263          (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device)
 264         (try-font-name
 265          (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device))))
 266
 267 (defun gtk-choose-font ()
 268   (interactive)
 269   (require 'x-font-menu)
 270   (require 'font)
 271   (let ((locale (if font-menu-this-frame-only-p
 272                     (selected-frame)
 273                   nil))
 274         (dialog nil))
 275     (setq dialog (gtk-font-selection-dialog-new "Choose default font..."))
 276     (put dialog 'modal t)
 277     (put dialog 'type 'dialog)
 278
 279     (gtk-widget-set-sensitive (gtk-font-selection-dialog-apply-button dialog) nil)
 280     (gtk-signal-connect dialog 'destroy (lambda (&rest ignored) (gtk-main-quit)))
 281     (gtk-signal-connect (gtk-font-selection-dialog-ok-button dialog)
 282                         'clicked
 283                         (lambda (button data)
 284                           (let* ((dialog (car data))
 285                                  (locale (cdr data))
 286                                  (font (font-create-object
 287                                         (gtk-font-selection-dialog-get-font-name dialog))))
 288                             (gtk-widget-destroy dialog)
 289                             (font-menu-set-font (car (font-family font)) nil (* 10 (font-size font)))))
 290                         (cons dialog locale))
 291     (gtk-signal-connect (gtk-font-selection-dialog-cancel-button dialog)
 292                         'clicked
 293                         (lambda (button dialog)
 294                           (gtk-widget-destroy dialog)) dialog)
 295
 296     (gtk-widget-show-all dialog)
 297     (gtk-main)))