Mercurial > hg > xemacs-beta
annotate lisp/gtk-faces.el @ 5257:30bf66dd3ca0
Add fixnum as an accepted destination type, #'coerce
2010-09-03 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
Add fixnum as an accepted destination type.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Fri, 03 Sep 2010 17:14:10 +0100 |
| parents | 7d06a8bf47d2 |
| children | 308d34e9f07d |
| 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 | |
| 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 | |
| 502 | 34 (globally-declare-fboundp |
| 35 '(gtk-init-pointers | |
| 36 gtk-font-selection-dialog-new | |
| 37 gtk-widget-set-sensitive gtk-font-selection-dialog-apply-button | |
| 38 gtk-signal-connect gtk-main-quit | |
| 39 gtk-font-selection-dialog-ok-button | |
| 40 gtk-font-selection-dialog-get-font-name gtk-widget-destroy | |
| 41 font-menu-set-font font-family font-size | |
| 42 gtk-font-selection-dialog-cancel-button gtk-widget-show-all | |
| 771 | 43 gtk-main gtk-style-info)) |
| 462 | 44 |
| 711 | 45 (eval-when-compile |
| 46 (defmacro gtk-style-munge-face (face attribute value) | |
| 47 (let ((func (intern (format "face-%s" (eval attribute))))) | |
| 48 `(add-spec-to-specifier (,func ,face) ,value nil '(gtk default) 'prepend)))) | |
| 462 | 49 |
| 50 ;;; gtk-init-device-faces is responsible for initializing default | |
| 51 ;;; values for faces on a newly created device. | |
| 52 ;;; | |
| 53 (defun gtk-init-device-faces (device) | |
| 54 ;; | |
| 55 ;; If the "default" face didn't have a font specified, try to pick one. | |
| 56 ;; | |
| 711 | 57 (when (eq (device-type device) 'gtk) |
| 707 | 58 (let* ((style (gtk-style-info device)) |
| 711 | 59 (normal 0) ; GTK_STATE_NORMAL |
| 462 | 60 ;;(active 1) ; GTK_STATE_ACTIVE |
| 61 (prelight 2) ; GTK_STATE_PRELIGHT | |
| 62 (selected 3) ; GTK_STATE_SELECTED | |
| 63 ;;(insensitive 4) ; GTK_STATE_INSENSITIVE | |
| 64 ) | |
| 711 | 65 (gtk-style-munge-face 'highlight 'foreground |
| 66 (nth prelight (plist-get style 'text))) | |
| 67 (gtk-style-munge-face 'highlight 'background | |
| 68 (nth prelight (plist-get style 'background))) | |
| 69 (gtk-style-munge-face 'zmacs-region 'foreground | |
| 70 (nth selected (plist-get style 'text))) | |
| 71 (gtk-style-munge-face 'zmacs-region 'background | |
| 72 (nth selected (plist-get style 'background))) | |
| 73 (gtk-style-munge-face 'toolbar 'background | |
| 74 (nth normal (plist-get style 'base))) | |
| 75 (gtk-style-munge-face 'toolbar 'foreground | |
| 76 (nth normal (plist-get style 'text))) | |
| 77 (set-face-background 'modeline [toolbar background] '(gtk default)) | |
| 78 (set-face-foreground 'modeline [toolbar foreground] '(gtk default)) | |
| 79 ) | |
| 80 (gtk-init-pointers))) | |
| 462 | 81 |
| 82 ;;; This is called from `init-frame-faces', which is called from | |
| 83 ;;; init_frame_faces() which is called from Fmake_frame(), to perform | |
| 84 ;;; any device-specific initialization. | |
| 85 ;;; | |
| 86 (defun gtk-init-frame-faces (frame) | |
| 87 ) | |
| 88 | |
| 89 (defun gtk-init-global-faces () | |
| 872 | 90 ) |
| 462 | 91 |
| 92 | |
| 93 ;;; Lots of this stolen from x-faces.el - I'm not sure if this will | |
| 94 ;;; require a rewrite for win32 or not? | |
| 95 (defconst gtk-font-regexp nil) | |
| 96 (defconst gtk-font-regexp-head nil) | |
| 97 (defconst gtk-font-regexp-head-2 nil) | |
| 98 (defconst gtk-font-regexp-weight nil) | |
| 99 (defconst gtk-font-regexp-slant nil) | |
| 100 (defconst gtk-font-regexp-pixel nil) | |
| 101 (defconst gtk-font-regexp-point nil) | |
| 102 (defconst gtk-font-regexp-foundry-and-family nil) | |
| 103 (defconst gtk-font-regexp-registry-and-encoding nil) | |
| 104 (defconst gtk-font-regexp-spacing nil) | |
| 105 | |
| 106 ;;; Regexps matching font names in "Host Portable Character Representation." | |
| 107 ;;; | |
| 108 (let ((- "[-?]") | |
| 109 (foundry "[^-]*") | |
| 110 (family "[^-]*") | |
| 111 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 | |
| 112 ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1 | |
| 113 (weight\? "\\([^-]*\\)") ; 1 | |
| 114 (slant "\\([ior]\\)") ; 2 | |
| 115 ; (slant\? "\\([ior?*]?\\)") ; 2 | |
| 116 (slant\? "\\([^-]?\\)") ; 2 | |
| 117 ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3 | |
| 118 (swidth "\\([^-]*\\)") ; 3 | |
| 119 ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4 | |
| 120 (adstyle "\\([^-]*\\)") ; 4 | |
| 121 (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5 | |
| 122 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6 | |
| 123 ; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7 | |
| 124 ; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8 | |
| 125 (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7 | |
| 126 (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8 | |
| 127 (spacing "[cmp?*]") | |
| 128 (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9 | |
| 129 (registry "[^-]*") ; some fonts have omitted registries | |
| 130 ; (encoding ".+") ; note that encoding may contain "-"... | |
| 131 (encoding "[^-]+") ; false! | |
| 132 ) | |
| 133 (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
|
134 (concat "\\`\\*?[-?*]" |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
135 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
|
136 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
|
137 registry - encoding "\\'" |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
138 )) |
| 462 | 139 (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
|
140 (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
|
141 "\\([-*?]\\|\\'\\)")) |
| 462 | 142 (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
|
143 (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
|
144 - 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
|
145 "\\([-*?]\\|\\'\\)")) |
|
7d06a8bf47d2
Move #'purecopy from alloc.c to being an obsolete alias for #'identity
Aidan Kehoe <kehoea@parhasard.net>
parents:
872
diff
changeset
|
146 (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
|
147 (setq gtk-font-regexp-weight (concat - weight -)) |
| 462 | 148 ;; if we can't match any of the more specific regexps (unfortunate) then |
| 149 ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits | |
| 150 ;; 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
|
151 (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
|
152 (setq gtk-font-regexp-point "[-?*]\\([0-9][0-9]+\\)[-?*]") |
| 462 | 153 ;; the following two are used by x-font-menu.el. |
| 154 (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
|
155 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)) |
| 462 | 156 (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
|
157 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")) |
| 462 | 158 (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
|
159 (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
|
160 - registry - encoding "\\'")) |
| 462 | 161 ) |
| 162 | |
| 163 (defvaralias 'x-font-regexp 'gtk-font-regexp) | |
| 164 (defvaralias 'x-font-regexp-head 'gtk-font-regexp-head) | |
| 165 (defvaralias 'x-font-regexp-head-2 'gtk-font-regexp-head-2) | |
| 166 (defvaralias 'x-font-regexp-weight 'gtk-font-regexp-weight) | |
| 167 (defvaralias 'x-font-regexp-slant 'gtk-font-regexp-slant) | |
| 168 (defvaralias 'x-font-regexp-pixel 'gtk-font-regexp-pixel) | |
| 169 (defvaralias 'x-font-regexp-point 'gtk-font-regexp-point) | |
| 170 (defvaralias 'x-font-regexp-foundry-and-family 'gtk-font-regexp-foundry-and-family) | |
| 171 (defvaralias 'x-font-regexp-registry-and-encoding 'gtk-font-regexp-registry-and-encoding) | |
| 172 (defvaralias 'x-font-regexp-spacing 'gtk-font-regexp-spacing) | |
| 173 | |
| 174 (defun gtk-frob-font-weight (font which) | |
| 175 (if (font-instance-p font) (setq font (font-instance-name font))) | |
| 176 (cond ((null font) nil) | |
| 177 ((or (string-match gtk-font-regexp font) | |
| 178 (string-match gtk-font-regexp-head font) | |
| 179 (string-match gtk-font-regexp-weight font)) | |
| 180 (concat (substring font 0 (match-beginning 1)) which | |
| 181 (substring font (match-end 1)))) | |
| 182 (t nil))) | |
| 183 | |
| 184 (defun gtk-frob-font-slant (font which) | |
| 185 (if (font-instance-p font) (setq font (font-instance-name font))) | |
| 186 (cond ((null font) nil) | |
| 187 ((or (string-match gtk-font-regexp font) | |
| 188 (string-match gtk-font-regexp-head font)) | |
| 189 (concat (substring font 0 (match-beginning 2)) which | |
| 190 (substring font (match-end 2)))) | |
| 191 ((string-match gtk-font-regexp-slant font) | |
| 192 (concat (substring font 0 (match-beginning 1)) which | |
| 193 (substring font (match-end 1)))) | |
| 194 (t nil))) | |
| 195 | |
| 196 (defun gtk-make-font-bold (font &optional device) | |
| 197 (or (try-font-name (gtk-frob-font-weight font "bold") device) | |
| 198 (try-font-name (gtk-frob-font-weight font "black") device) | |
| 199 (try-font-name (gtk-frob-font-weight font "demibold") device))) | |
| 200 | |
| 201 (defun gtk-make-font-unbold (font &optional device) | |
| 202 (try-font-name (gtk-frob-font-weight font "medium") device)) | |
| 203 | |
| 776 | 204 (defcustom try-oblique-before-italic-fonts t |
| 462 | 205 "*If nil, italic fonts are searched before oblique fonts. |
| 206 If non-nil, oblique fonts are tried before italic fonts. This is mostly | |
| 207 applicable to adobe-courier fonts" | |
| 208 :type 'boolean | |
| 209 :tag "Try Oblique Before Italic Fonts" | |
| 210 :group 'x) | |
| 776 | 211 (define-obsolete-variable-alias '*try-oblique-before-italic-fonts* |
| 212 'try-oblique-before-italic-fonts) | |
| 462 | 213 |
| 214 (defun gtk-make-font-italic (font &optional device) | |
| 776 | 215 (if try-oblique-before-italic-fonts |
| 462 | 216 (or (try-font-name (gtk-frob-font-slant font "o") device) |
| 217 (try-font-name (gtk-frob-font-slant font "i") device)) | |
| 218 (or (try-font-name (gtk-frob-font-slant font "i") device) | |
| 219 (try-font-name (gtk-frob-font-slant font "o") device)))) | |
| 220 | |
| 221 (defun gtk-make-font-unitalic (font &optional device) | |
| 222 (try-font-name (gtk-frob-font-slant font "r") device)) | |
| 223 | |
| 224 (defun gtk-make-font-bold-italic (font &optional device) | |
| 776 | 225 (if try-oblique-before-italic-fonts |
| 462 | 226 (or (try-font-name |
| 227 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device) | |
| 228 (try-font-name | |
| 229 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device) | |
| 230 (try-font-name | |
| 231 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device) | |
| 232 (try-font-name | |
| 233 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device) | |
| 234 (try-font-name | |
| 235 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device) | |
| 236 (try-font-name | |
| 237 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device)) | |
| 238 (or (try-font-name | |
| 239 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device) | |
| 240 (try-font-name | |
| 241 (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device) | |
| 242 (try-font-name | |
| 243 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device) | |
| 244 (try-font-name | |
| 245 (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device) | |
| 246 (try-font-name | |
| 247 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device) | |
| 248 (try-font-name | |
| 249 (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device)))) | |
| 250 | |
| 251 (defun gtk-choose-font () | |
| 252 (interactive) | |
| 253 (require 'x-font-menu) | |
| 254 (require 'font) | |
| 255 (let ((locale (if font-menu-this-frame-only-p | |
| 256 (selected-frame) | |
| 257 nil)) | |
| 258 (dialog nil)) | |
| 259 (setq dialog (gtk-font-selection-dialog-new "Choose default font...")) | |
| 260 (put dialog 'modal t) | |
| 261 (put dialog 'type 'dialog) | |
| 262 | |
| 263 (gtk-widget-set-sensitive (gtk-font-selection-dialog-apply-button dialog) nil) | |
| 264 (gtk-signal-connect dialog 'destroy (lambda (&rest ignored) (gtk-main-quit))) | |
| 265 (gtk-signal-connect (gtk-font-selection-dialog-ok-button dialog) | |
| 266 'clicked | |
| 267 (lambda (button data) | |
| 268 (let* ((dialog (car data)) | |
| 269 (font (font-create-object | |
| 270 (gtk-font-selection-dialog-get-font-name dialog)))) | |
| 271 (gtk-widget-destroy dialog) | |
| 272 (font-menu-set-font (car (font-family font)) nil (* 10 (font-size font))))) | |
| 273 (cons dialog locale)) | |
| 274 (gtk-signal-connect (gtk-font-selection-dialog-cancel-button dialog) | |
| 275 'clicked | |
| 276 (lambda (button dialog) | |
| 277 (gtk-widget-destroy dialog)) dialog) | |
| 278 | |
| 279 (gtk-widget-show-all dialog) | |
| 280 (gtk-main))) |