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