Mercurial > hg > xemacs-beta
annotate lisp/gtk-faces.el @ 5818:15b0715c204d
Avoid passing patterns to with charset property to FcNameUnparse.
Prevents crash reported by Raymond Toy.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 18 Oct 2014 21:20:42 +0900 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 462 | 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
13 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
14 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
15 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
16 ;; option) any later version. |
| 462 | 17 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
18 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
20 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
21 ;; for more details. |
| 462 | 22 |
| 23 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5229
diff
changeset
|
24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 462 | 25 |
| 26 ;;; Synched up with: Not synched. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; This file is dumped with XEmacs (when GTK support is compiled in). | |
| 31 | |
| 502 | 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 | |
| 771 | 41 gtk-main gtk-style-info)) |
| 462 | 42 |
| 711 | 43 (eval-when-compile |
| 44 (defmacro gtk-style-munge-face (face attribute value) | |
| 45 (let ((func (intern (format "face-%s" (eval attribute))))) | |
| 46 `(add-spec-to-specifier (,func ,face) ,value nil '(gtk default) 'prepend)))) | |
| 462 | 47 |
| 48 ;;; gtk-init-device-faces is responsible for initializing default | |
| 49 ;;; values for faces on a newly created device. | |
| 50 ;;; | |
| 51 (defun gtk-init-device-faces (device) | |
| 52 ;; | |
| 53 ;; If the "default" face didn't have a font specified, try to pick one. | |
| 54 ;; | |
| 711 | 55 (when (eq (device-type device) 'gtk) |
| 707 | 56 (let* ((style (gtk-style-info device)) |
| 711 | 57 (normal 0) ; GTK_STATE_NORMAL |
| 462 | 58 ;;(active 1) ; GTK_STATE_ACTIVE |
| 59 (prelight 2) ; GTK_STATE_PRELIGHT | |
| 60 (selected 3) ; GTK_STATE_SELECTED | |
| 61 ;;(insensitive 4) ; GTK_STATE_INSENSITIVE | |
| 62 ) | |
| 711 | 63 (gtk-style-munge-face 'highlight 'foreground |
| 64 (nth prelight (plist-get style 'text))) | |
| 65 (gtk-style-munge-face 'highlight 'background | |
| 66 (nth prelight (plist-get style 'background))) | |
| 67 (gtk-style-munge-face 'zmacs-region 'foreground | |
| 68 (nth selected (plist-get style 'text))) | |
| 69 (gtk-style-munge-face 'zmacs-region 'background | |
| 70 (nth selected (plist-get style 'background))) | |
| 71 (gtk-style-munge-face 'toolbar 'background | |
| 72 (nth normal (plist-get style 'base))) | |
| 73 (gtk-style-munge-face 'toolbar 'foreground | |
| 74 (nth normal (plist-get style 'text))) | |
| 75 (set-face-background 'modeline [toolbar background] '(gtk default)) | |
| 76 (set-face-foreground 'modeline [toolbar foreground] '(gtk default)) | |
| 77 ) | |
| 78 (gtk-init-pointers))) | |
| 462 | 79 |
| 80 ;;; This is called from `init-frame-faces', which is called from | |
| 81 ;;; init_frame_faces() which is called from Fmake_frame(), to perform | |
| 82 ;;; any device-specific initialization. | |
| 83 ;;; | |
| 84 (defun gtk-init-frame-faces (frame) | |
| 85 ) | |
| 86 | |
| 87 (defun gtk-init-global-faces () | |
| 872 | 88 ) |
| 462 | 89 |
| 90 | |
| 91 ;;; Lots of this stolen from x-faces.el - I'm not sure if this will | |
| 92 ;;; require a rewrite for win32 or not? | |
| 93 (defconst gtk-font-regexp nil) | |
| 94 (defconst gtk-font-regexp-head nil) | |
| 95 (defconst gtk-font-regexp-head-2 nil) | |
| 96 (defconst gtk-font-regexp-weight nil) | |
| 97 (defconst gtk-font-regexp-slant nil) | |
| 98 (defconst gtk-font-regexp-pixel nil) | |
| 99 (defconst gtk-font-regexp-point nil) | |
| 100 (defconst gtk-font-regexp-foundry-and-family nil) | |
| 101 (defconst gtk-font-regexp-registry-and-encoding nil) | |
| 102 (defconst gtk-font-regexp-spacing nil) | |
| 103 | |
| 104 ;;; Regexps matching font names in "Host Portable Character Representation." | |
| 105 ;;; | |
| 106 (let ((- "[-?]") | |
| 107 (foundry "[^-]*") | |
| 108 (family "[^-]*") | |
| 109 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 | |
| 110 ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1 | |
| 111 (weight\? "\\([^-]*\\)") ; 1 | |
| 112 (slant "\\([ior]\\)") ; 2 | |
| 113 ; (slant\? "\\([ior?*]?\\)") ; 2 | |
| 114 (slant\? "\\([^-]?\\)") ; 2 | |
| 115 ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3 | |
| 116 (swidth "\\([^-]*\\)") ; 3 | |
| 117 ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4 | |
| 118 (adstyle "\\([^-]*\\)") ; 4 | |
| 119 (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5 | |
| 120 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6 | |
| 121 ; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7 | |
| 122 ; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8 | |
| 123 (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7 | |
| 124 (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8 | |
| 125 (spacing "[cmp?*]") | |
| 126 (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9 | |
| 127 (registry "[^-]*") ; some fonts have omitted registries | |
| 128 ; (encoding ".+") ; note that encoding may contain "-"... | |
| 129 (encoding "[^-]+") ; false! | |
| 130 ) | |
| 131 (setq gtk-font-regexp | |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
132 (concat "\\`\\*?[-?*]" |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
133 foundry - family - weight\? - slant\? - swidth - adstyle - |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
134 pixelsize - pointsize - resx - resy - spacing - avgwidth - |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
135 registry - encoding "\\'" |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
136 )) |
| 462 | 137 (setq gtk-font-regexp-head |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
138 (concat "\\`[-?*]" foundry - family - weight\? - slant\? |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
139 "\\([-*?]\\|\\'\\)")) |
| 462 | 140 (setq gtk-font-regexp-head-2 |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
141 (concat "\\`[-?*]" foundry - family - weight\? - slant\? |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
142 - swidth - adstyle - pixelsize - pointsize |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
143 "\\([-*?]\\|\\'\\)")) |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
144 (setq gtk-font-regexp-slant (concat - slant -)) |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
145 (setq gtk-font-regexp-weight (concat - weight -)) |
| 462 | 146 ;; if we can't match any of the more specific regexps (unfortunate) then |
| 147 ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits | |
| 148 ;; is pixels. Bogus as hell. | |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
149 (setq gtk-font-regexp-pixel "[-?*]\\([0-9][0-9]?\\)[-?*]") |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
150 (setq gtk-font-regexp-point "[-?*]\\([0-9][0-9]+\\)[-?*]") |
| 462 | 151 ;; the following two are used by x-font-menu.el. |
| 152 (setq gtk-font-regexp-foundry-and-family | |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
153 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)) |
| 462 | 154 (setq gtk-font-regexp-registry-and-encoding |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
155 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")) |
| 462 | 156 (setq gtk-font-regexp-spacing |
|
5229
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
157 (concat - "\\(" spacing "\\)" - avgwidth |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
158 - registry - encoding "\\'")) |
| 462 | 159 ) |
| 160 | |
| 161 (defvaralias 'x-font-regexp 'gtk-font-regexp) | |
| 162 (defvaralias 'x-font-regexp-head 'gtk-font-regexp-head) | |
| 163 (defvaralias 'x-font-regexp-head-2 'gtk-font-regexp-head-2) | |
| 164 (defvaralias 'x-font-regexp-weight 'gtk-font-regexp-weight) | |
| 165 (defvaralias 'x-font-regexp-slant 'gtk-font-regexp-slant) | |
| 166 (defvaralias 'x-font-regexp-pixel 'gtk-font-regexp-pixel) | |
| 167 (defvaralias 'x-font-regexp-point 'gtk-font-regexp-point) | |
| 168 (defvaralias 'x-font-regexp-foundry-and-family 'gtk-font-regexp-foundry-and-family) | |
| 169 (defvaralias 'x-font-regexp-registry-and-encoding 'gtk-font-regexp-registry-and-encoding) | |
| 170 (defvaralias 'x-font-regexp-spacing 'gtk-font-regexp-spacing) | |
| 171 | |
| 172 (defun gtk-frob-font-weight (font which) | |
| 173 (if (font-instance-p font) (setq font (font-instance-name font))) | |
| 174 (cond ((null font) nil) | |
| 175 ((or (string-match gtk-font-regexp font) | |
| 176 (string-match gtk-font-regexp-head font) | |
| 177 (string-match gtk-font-regexp-weight font)) | |
| 178 (concat (substring font 0 (match-beginning 1)) which | |
| 179 (substring font (match-end 1)))) | |
| 180 (t nil))) | |
| 181 | |
| 182 (defun gtk-frob-font-slant (font which) | |
| 183 (if (font-instance-p font) (setq font (font-instance-name font))) | |
| 184 (cond ((null font) nil) | |
| 185 ((or (string-match gtk-font-regexp font) | |
| 186 (string-match gtk-font-regexp-head font)) | |
| 187 (concat (substring font 0 (match-beginning 2)) which | |
| 188 (substring font (match-end 2)))) | |
| 189 ((string-match gtk-font-regexp-slant font) | |
| 190 (concat (substring font 0 (match-beginning 1)) which | |
| 191 (substring font (match-end 1)))) | |
| 192 (t nil))) | |
| 193 | |
| 194 (defun gtk-make-font-bold (font &optional device) | |
| 195 (or (try-font-name (gtk-frob-font-weight font "bold") device) | |
| 196 (try-font-name (gtk-frob-font-weight font "black") device) | |
| 197 (try-font-name (gtk-frob-font-weight font "demibold") device))) | |
| 198 | |
| 199 (defun gtk-make-font-unbold (font &optional device) | |
| 200 (try-font-name (gtk-frob-font-weight font "medium") device)) | |
| 201 | |
| 776 | 202 (defcustom try-oblique-before-italic-fonts t |
| 462 | 203 "*If nil, italic fonts are searched before oblique fonts. |
| 204 If non-nil, oblique fonts are tried before italic fonts. This is mostly | |
| 205 applicable to adobe-courier fonts" | |
| 206 :type 'boolean | |
| 207 :tag "Try Oblique Before Italic Fonts" | |
| 208 :group 'x) | |
| 776 | 209 (define-obsolete-variable-alias '*try-oblique-before-italic-fonts* |
| 210 'try-oblique-before-italic-fonts) | |
| 462 | 211 |
| 212 (defun gtk-make-font-italic (font &optional device) | |
| 776 | 213 (if try-oblique-before-italic-fonts |
| 462 | 214 (or (try-font-name (gtk-frob-font-slant font "o") device) |
| 215 (try-font-name (gtk-frob-font-slant font "i") device)) | |
| 216 (or (try-font-name (gtk-frob-font-slant font "i") device) | |
| 217 (try-font-name (gtk-frob-font-slant font "o") device)))) | |
| 218 | |
| 219 (defun gtk-make-font-unitalic (font &optional device) | |
| 220 (try-font-name (gtk-frob-font-slant font "r") device)) | |
| 221 | |
| 222 (defun gtk-make-font-bold-italic (font &optional device) | |
| 776 | 223 (if try-oblique-before-italic-fonts |
| 462 | 224 (or (try-font-name |
| 225 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device) | |
| 226 (try-font-name | |
| 227 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device) | |
| 228 (try-font-name | |
| 229 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device) | |
| 230 (try-font-name | |
| 231 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device) | |
| 232 (try-font-name | |
| 233 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device) | |
| 234 (try-font-name | |
| 235 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device)) | |
| 236 (or (try-font-name | |
| 237 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device) | |
| 238 (try-font-name | |
| 239 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device) | |
| 240 (try-font-name | |
| 241 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device) | |
| 242 (try-font-name | |
| 243 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device) | |
| 244 (try-font-name | |
| 245 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device) | |
| 246 (try-font-name | |
| 247 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device)))) | |
| 248 | |
| 249 (defun gtk-choose-font () | |
| 250 (interactive) | |
| 251 (require 'x-font-menu) | |
| 252 (require 'font) | |
| 253 (let ((locale (if font-menu-this-frame-only-p | |
| 254 (selected-frame) | |
| 255 nil)) | |
| 256 (dialog nil)) | |
| 257 (setq dialog (gtk-font-selection-dialog-new "Choose default font...")) | |
| 258 (put dialog 'modal t) | |
| 259 (put dialog 'type 'dialog) | |
| 260 | |
| 261 (gtk-widget-set-sensitive (gtk-font-selection-dialog-apply-button dialog) nil) | |
| 262 (gtk-signal-connect dialog 'destroy (lambda (&rest ignored) (gtk-main-quit))) | |
| 263 (gtk-signal-connect (gtk-font-selection-dialog-ok-button dialog) | |
| 264 'clicked | |
| 265 (lambda (button data) | |
| 266 (let* ((dialog (car data)) | |
| 267 (font (font-create-object | |
| 268 (gtk-font-selection-dialog-get-font-name dialog)))) | |
| 269 (gtk-widget-destroy dialog) | |
| 270 (font-menu-set-font (car (font-family font)) nil (* 10 (font-size font))))) | |
| 271 (cons dialog locale)) | |
| 272 (gtk-signal-connect (gtk-font-selection-dialog-cancel-button dialog) | |
| 273 'clicked | |
| 274 (lambda (button dialog) | |
| 275 (gtk-widget-destroy dialog)) dialog) | |
| 276 | |
| 277 (gtk-widget-show-all dialog) | |
| 278 (gtk-main))) |