Mercurial > hg > xemacs-beta

comparison lisp/gtk-faces.el @ 462:0784d089fdc9 r21-2-46

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-46
author cvs
date Mon, 13 Aug 2007 11:44:37 +0200
parents
children 7039e6323819
comparison
equal deleted inserted replaced
461:120ed4009e51 462:0784d089fdc9
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
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)))