Mercurial > hg > xemacs-beta

comparison lisp/x-font-menu.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 74fd4e045ea6
children da8ed4261e83
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
2 2
3 ;; Copyright (C) 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1997 Sun Microsystems 5 ;; Copyright (C) 1997 Sun Microsystems
6 6
7 ;; Author: Jamie Zawinski <jwz@jwz.org> 7 ;; Author: Jamie Zawinski <jwz@netscape.com>
8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com> 8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
9 ;; Mule-ized by: Martin Buchholz 9 ;; Mule-ized by: Martin Buchholz
10 ;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
11 10
12 ;; This file is part of XEmacs. 11 ;; This file is part of XEmacs.
13 12
14 ;; XEmacs is free software; you can redistribute it and/or modify it 13 ;; XEmacs is free software; you can redistribute it and/or modify it
15 ;; under the terms of the GNU General Public License as published by 14 ;; under the terms of the GNU General Public License as published by
23 22
24 ;; You should have received a copy of the GNU General Public License 23 ;; You should have received a copy of the GNU General Public License
25 ;; along with XEmacs; see the file COPYING. If not, write to the 24 ;; along with XEmacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, 59 Temple Place - Suite 330, 25 ;; Free Software Foundation, 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA. 26 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Commentary:
29 ;;;
30 ;;; Creates three menus, "Font", "Size", and "Weight", and puts them on the
31 ;;; "Options" menu. The contents of these menus are the superset of those
32 ;;; properties available on any fonts, but only the intersection of the three
33 ;;; sets is selectable at one time.
34 ;;;
35 ;;; Known Problems:
36 ;;; ===============
37 ;;; Items on the Font menu are selectable if and only if that font exists in
38 ;;; the same size and weight as the current font. This means that some fonts
39 ;;; are simply not reachable from some other fonts - if only one font comes
40 ;;; in only one point size (like "Nil", which comes only in 2), you will never
41 ;;; be able to select it. It would be better if the items on the Fonts menu
42 ;;; were always selectable, and selecting them would set the size to be the
43 ;;; closest size to the current font's size.
44 ;;;
45 ;;; This attempts to change all other faces in an analagous way to the change
46 ;;; that was made to the default face; if it can't, it will skip over the face.
47 ;;; However, this could leave incongruous font sizes around, which may cause
48 ;;; some nonreversibility problems if further changes are made. Perhaps it
49 ;;; should remember the initial fonts of all faces, and derive all subsequent
50 ;;; fonts from that initial state.
51 ;;;
52 ;;; xfontsel(1) is a lot more flexible (but probably harder to understand).
53 ;;;
54 ;;; The code to construct menus from all of the x11 fonts available from the
55 ;;; server is autoloaded and executed the very first time that one of the Font
56 ;;; menus is selected on each device. That is, if XEmacs has frames on two
57 ;;; different devices, then separate font menu information will be maintained
58 ;;; for each X display. If the font path changes after emacs has already
59 ;;; asked the X server on a particular display for its list of fonts, this
60 ;;; won't notice. Also, the first time that a font menu is posted on each
61 ;;; display will entail a lengthy delay, but that's better than slowing down
62 ;;; XEmacs startup. At any time (i.e.: after a font-path change or
63 ;;; immediately after device creation), you can call
64 ;;; `reset-device-font-menus' to rebuild the menus from all currently
65 ;;; available fonts.
66 ;;;
67 ;;; There is knowledge here about the regexp match numbers in
68 ;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in
69 ;;; x-faces.el.
70 ;;;
71 ;;; There are at least three kinds of fonts under X11r5:
72 ;;;
73 ;;; - bitmap fonts, which can be assumed to look as good as possible;
74 ;;; - bitmap fonts which have been (or can be) automatically scaled to
75 ;;; a new size, and which almost always look awful;
76 ;;; - and true outline fonts, which should look ok at any size, but in
77 ;;; practice (on at least some systems) look awful at any size, and
78 ;;; even in theory are unlikely ever to look as good as non-scaled
79 ;;; bitmap fonts.
80 ;;;
81 ;;; It would be nice to get this code to look for non-scaled bitmap fonts
82 ;;; first, then outline fonts, then scaled bitmap fonts as a last resort.
83 ;;; But it's not clear to me how to tell them apart based on their truenames
84 ;;; and/or the result of XListFonts(). I welcome any and all explanations
85 ;;; of the subtleties involved...
86 ;;;
87 ;;;
88 ;;; If You Think You'Re Seeing A Bug:
89 ;;; =================================
90 ;;; When reporting problems, send the following information:
91 ;;;
92 ;;; - Exactly what behavior you're seeing;
93 ;;; - The output of the `xlsfonts' program;
94 ;;; - The value of the variable `device-fonts-cache';
95 ;;; - The values of the following expressions, both before and after
96 ;;; making a selection from any of the fonts-related menus:
97 ;;; (face-font 'default)
98 ;;; (font-truename (face-font 'default))
99 ;;; (font-properties (face-font 'default))
100 ;;; - The values of the following variables after making a selection:
101 ;;; font-menu-preferred-resolution
102 ;;; font-menu-registry-encoding
103 ;;;
104 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
105 ;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
106 ;;; is an 11-point font. It is not -- it is an 11-pixel font at 100dpi,
107 ;;; which is an 8-point font (the number after -11- is the size in tenths
108 ;;; of points). So if you expect to be seeing an "11" entry in the "Size"
109 ;;; menu and are not, this may be why.
110 ;;;
111 ;;; In the real world (aka Solaris), one has to deal with fonts that
112 ;;; appear to be medium-i but are really light-r, and fonts that
113 ;;; resolve to different resolutions depending on the charset:
114 ;;;
115 ;;; (font-instance-truename
116 ;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
117 ;;; ==>
118 ;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
119 ;;;
120 ;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
121 ;;; ==>
122 ;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
123 ;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
124 ;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
125
28 ;;; Code: 126 ;;; Code:
29 127
30 ;; #### - implement these... 128 ;; #### - implement these...
31 ;; 129 ;;
32 ;;; (defvar font-menu-ignore-proportional-fonts nil 130 ;;; (defvar font-menu-ignore-proportional-fonts nil
33 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.") 131 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
34 132
35 (require 'font-menu) 133 (defgroup font-menu ()
36 134 "Settings for the font menu"
37 (defvar x-font-menu-registry-encoding nil 135 :group 'x)
136
137 ;;;###autoload
138 (defcustom font-menu-ignore-scaled-fonts t
139 "*If non-nil, then the font menu will try to show only bitmap fonts."
140 :type 'boolean
141 :group 'font-menu)
142
143 ;;;###autoload
144 (defcustom font-menu-this-frame-only-p nil
145 "*If non-nil, then changing the default font from the font menu will only
146 affect one frame instead of all frames."
147 :type 'boolean
148 :group 'font-menu)
149
150 (defcustom font-menu-max-items 25
151 "*Maximum number of items in the font menu
152 If number of entries in a menu is larger than this value, split menu
153 into submenus of nearly equal length. If nil, never split menu into
154 submenus."
155 :group 'font-menu
156 :type '(choice (const :tag "no submenus" nil)
157 (integer)))
158
159 (defcustom font-menu-submenu-name-format "%-12.12s ... %.12s"
160 "*Format specification of the submenu name.
161 Used by `font-menu-split-long-menu' if the number of entries in a menu is
162 larger than `font-menu-menu-max-items'.
163 This string should contain one %s for the name of the first entry and
164 one %s for the name of the last entry in the submenu.
165 If the value is a function, it should return the submenu name. The
166 function is be called with two arguments, the names of the first and
167 the last entry in the menu."
168 :group 'font-menu
169 :type '(choice (string :tag "Format string")
170 (function)))
171
172
173 ;; only call XListFonts (and parse) once per device.
174 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
175 (defvar device-fonts-cache nil)
176
177 (defvar font-menu-registry-encoding nil
38 "Registry and encoding to use with font menu fonts.") 178 "Registry and encoding to use with font menu fonts.")
39 179
40 (defvar x-fonts-menu-junk-families 180 (defvar font-menu-preferred-resolution "*-*"
181 "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").")
182
183 (defvar fonts-menu-junk-families
41 (purecopy 184 (purecopy
42 (mapconcat 185 (mapconcat
43 #'identity 186 #'identity
44 '("cursor" "glyph" "symbol" ; Obvious losers. 187 '("cursor" "glyph" "symbol" ; Obvious losers.
45 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too 188 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too
48 ; "Axcor" -> "Applix Courier Roman", 191 ; "Axcor" -> "Applix Courier Roman",
49 ; "Axcob" -> "Applix Courier Bold", etc. 192 ; "Axcob" -> "Applix Courier Bold", etc.
50 ) 193 )
51 "\\|")) 194 "\\|"))
52 "A regexp matching font families which are uninteresting (e.g. cursor fonts).") 195 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
196
197 (eval-when-compile
198 (defsubst device-fonts-cache ()
199 (or (cdr (assq (selected-device) device-fonts-cache))
200 (reset-device-font-menus (selected-device)))))
53 201
54 (defun hack-font-truename (fn) 202 (defun hack-font-truename (fn)
55 "Filter the output of `font-instance-truename' to deal with Japanese fontsets." 203 "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
56 (if (string-match "," (font-instance-truename fn)) 204 (if (string-match "," (font-instance-truename fn))
57 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) 205 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
63 (setq flist (cdr flist)) 211 (setq flist (cdr flist))
64 )) 212 ))
65 ret) 213 ret)
66 (font-instance-truename fn))) 214 (font-instance-truename fn)))
67 215
216 ;;;###autoload
217 (fset 'install-font-menus 'reset-device-font-menus)
218 (make-obsolete 'install-font-menus 'reset-device-font-menus)
219
68 (defvar x-font-regexp-ascii nil 220 (defvar x-font-regexp-ascii nil
69 "This is used to filter out font families that can't display ASCII text. 221 "This is used to filter out font families that can't display ASCII text.
70 It must be set at run-time.") 222 It must be set at run-time.")
71 223
224 (defun vassoc (key valist)
225 "Search VALIST for a vector whose first element is equal to KEY.
226 See also `assoc'."
227 ;; by Stig@hackvan.com
228 (let (el)
229 (catch 'done
230 (while (setq el (pop valist))
231 (and (equal key (aref el 0))
232 (throw 'done el))))))
233
72 ;;;###autoload 234 ;;;###autoload
73 (defun x-reset-device-font-menus (device &optional debug) 235 (defun reset-device-font-menus (&optional device debug)
74 "Generates the `Font', `Size', and `Weight' submenus for the Options menu. 236 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
75 This is run the first time that a font-menu is needed for each device. 237 This is run the first time that a font-menu is needed for each device.
76 If you don't like the lazy invocation of this function, you can add it to 238 If you don't like the lazy invocation of this function, you can add it to
77 `create-device-hook' and that will make the font menus respond more quickly 239 `create-device-hook' and that will make the font menus respond more quickly
78 when they are selected for the first time. If you add fonts to your system, 240 when they are selected for the first time. If you add fonts to your system,
79 or if you change your font path, you can call this to re-initialize the menus." 241 or if you change your font path, you can call this to re-initialize the menus."
80 ;; by Stig@hackvan.com 242 ;; by Stig@hackvan.com
81 ;; #### - this should implement a `menus-only' option, which would 243 ;; #### - this should implement a `menus-only' option, which would
82 ;; recalculate the menus from the cache w/o having to do list-fonts again. 244 ;; recalculate the menus from the cache w/o having to do list-fonts again.
83 (unless x-font-regexp-ascii 245 (message "Getting list of fonts from server... ")
84 (setq x-font-regexp-ascii (if (featurep 'mule) 246 (if (or noninteractive
85 (charset-registry 'ascii) 247 (not (or device (setq device (selected-device))))
86 "iso8859-1"))) 248 (not (eq (device-type device) 'x)))
87 (setq x-font-menu-registry-encoding 249 nil
88 (if (featurep 'mule) "*-*" "iso8859-1")) 250 (unless x-font-regexp-ascii
89 (let ((case-fold-search t) 251 (setq x-font-regexp-ascii (if (featurep 'mule)
90 family size weight entry monospaced-p 252 (charset-registry 'ascii)
91 dev-cache cache families sizes weights) 253 "iso8859-1")))
92 (dolist (name (cond ((null debug) ; debugging kludge 254 (setq font-menu-registry-encoding
93 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) 255 (if (featurep 'mule) "*-*" "iso8859-1"))
94 ((stringp debug) (split-string debug "\n")) 256 (let ((case-fold-search t)
95 (t debug))) 257 family size weight entry monospaced-p
96 (when (and (string-match x-font-regexp-ascii name) 258 dev-cache cache families sizes weights)
97 (string-match x-font-regexp name)) 259 (dolist (name (cond ((null debug) ; debugging kludge
98 (setq weight (capitalize (match-string 1 name)) 260 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
99 size (string-to-int (match-string 6 name))) 261 ((stringp debug) (split-string debug "\n"))
100 (or (string-match x-font-regexp-foundry-and-family name) 262 (t debug)))
101 (error "internal error")) 263 (when (and (string-match x-font-regexp-ascii name)
102 (setq family (capitalize (match-string 1 name))) 264 (string-match x-font-regexp name))
103 (or (string-match x-font-regexp-spacing name) 265 (setq weight (capitalize (match-string 1 name))
104 (error "internal error")) 266 size (string-to-int (match-string 6 name)))
105 (setq monospaced-p (string= "m" (match-string 1 name))) 267 (or (string-match x-font-regexp-foundry-and-family name)
106 (unless (string-match x-fonts-menu-junk-families family) 268 (error "internal error"))
107 (setq entry (or (vassoc family cache) 269 (setq family (capitalize (match-string 1 name)))
108 (car (setq cache 270 (or (string-match x-font-regexp-spacing name)
109 (cons (vector family nil nil t) 271 (error "internal error"))
110 cache))))) 272 (setq monospaced-p (string= "m" (match-string 1 name)))
111 (or (member family families) (push family families)) 273 (unless (string-match fonts-menu-junk-families family)
112 (or (member weight weights) (push weight weights)) 274 (setq entry (or (vassoc family cache)
113 (or (member size sizes) (push size sizes)) 275 (car (setq cache
114 (or (member weight (aref entry 1)) (push weight (aref entry 1))) 276 (cons (vector family nil nil t)
115 (or (member size (aref entry 2)) (push size (aref entry 2))) 277 cache)))))
116 (aset entry 3 (and (aref entry 3) monospaced-p))))) 278 (or (member family families) (push family families))
117 ;; 279 (or (member weight weights) (push weight weights))
118 ;; Hack scalable fonts. 280 (or (member size sizes) (push size sizes))
119 ;; Some fonts come only in scalable versions (the only size is 0) 281 (or (member weight (aref entry 1)) (push weight (aref entry 1)))
120 ;; and some fonts come in both scalable and non-scalable versions 282 (or (member size (aref entry 2)) (push size (aref entry 2)))
121 ;; (one size is 0). If there are any scalable fonts at all, make 283 (aset entry 3 (and (aref entry 3) monospaced-p)))))
122 ;; sure that the union of all point sizes contains at least some 284 ;;
123 ;; common sizes - it's possible that some sensible sizes might end 285 ;; Hack scalable fonts.
124 ;; up not getting mentioned explicitly. 286 ;; Some fonts come only in scalable versions (the only size is 0)
125 ;; 287 ;; and some fonts come in both scalable and non-scalable versions
126 (if (member 0 sizes) 288 ;; (one size is 0). If there are any scalable fonts at all, make
127 (let ((common '(60 80 100 120 140 160 180 240))) 289 ;; sure that the union of all point sizes contains at least some
128 (while common 290 ;; common sizes - it's possible that some sensible sizes might end
129 (or;;(member (car common) sizes) ; not enough slack 291 ;; up not getting mentioned explicitly.
130 (let ((rest sizes) 292 ;;
131 (done nil)) 293 (if (member 0 sizes)
132 (while (and (not done) rest) 294 (let ((common '(60 80 100 120 140 160 180 240)))
133 (if (and (> (car common) (- (car rest) 5)) 295 (while common
134 (< (car common) (+ (car rest) 5))) 296 (or;;(member (car common) sizes) ; not enough slack
135 (setq done t)) 297 (let ((rest sizes)
136 (setq rest (cdr rest))) 298 (done nil))
137 done) 299 (while (and (not done) rest)
138 (setq sizes (cons (car common) sizes))) 300 (if (and (> (car common) (- (car rest) 5))
139 (setq common (cdr common))) 301 (< (car common) (+ (car rest) 5)))
140 (setq sizes (delq 0 sizes)))) 302 (setq done t))
141 303 (setq rest (cdr rest)))
142 (setq families (sort families 'string-lessp) 304 done)
143 weights (sort weights 'string-lessp) 305 (setq sizes (cons (car common) sizes)))
144 sizes (sort sizes '<)) 306 (setq common (cdr common)))
145 307 (setq sizes (delq 0 sizes))))
146 (dolist (entry cache) 308
147 (aset entry 1 (sort (aref entry 1) 'string-lessp)) 309 (setq families (sort families 'string-lessp)
148 (aset entry 2 (sort (aref entry 2) '<))) 310 weights (sort weights 'string-lessp)
149 311 sizes (sort sizes '<))
150 (setq dev-cache (assq device device-fonts-cache)) 312
151 (or dev-cache 313 (dolist (entry cache)
152 (setq dev-cache (car (push (list device) device-fonts-cache)))) 314 (aset entry 1 (sort (aref entry 1) 'string-lessp))
153 (setcdr 315 (aset entry 2 (sort (aref entry 2) '<)))
154 dev-cache 316
155 (vector 317 (message "Getting list of fonts from server... done.")
156 cache 318
157 (mapcar (lambda (x) 319 (setq dev-cache (assq device device-fonts-cache))
158 (vector x 320 (or dev-cache
159 (list 'font-menu-set-font x nil nil) 321 (setq dev-cache (car (push (list device) device-fonts-cache))))
160 ':style 'radio ':active nil ':selected nil)) 322 (setcdr
161 families) 323 dev-cache
162 (mapcar (lambda (x) 324 (vector
163 (vector (if (/= 0 (% x 10)) 325 cache
164 ;; works with no LISP_FLOAT_TYPE 326 (mapcar (lambda (x)
165 (concat (int-to-string (/ x 10)) "." 327 (vector x
166 (int-to-string (% x 10))) 328 (list 'font-menu-set-font x nil nil)
167 (int-to-string (/ x 10))) 329 ':style 'radio ':active nil ':selected nil))
168 (list 'font-menu-set-font nil nil x) 330 families)
169 ':style 'radio ':active nil ':selected nil)) 331 (mapcar (lambda (x)
170 sizes) 332 (vector (if (/= 0 (% x 10))
171 (mapcar (lambda (x) 333 ;; works with no LISP_FLOAT_TYPE
172 (vector x 334 (concat (int-to-string (/ x 10)) "."
173 (list 'font-menu-set-font nil x nil) 335 (int-to-string (% x 10)))
174 ':style 'radio ':active nil ':selected nil)) 336 (int-to-string (/ x 10)))
175 weights))) 337 (list 'font-menu-set-font nil nil x)
176 (cdr dev-cache))) 338 ':style 'radio ':active nil ':selected nil))
339 sizes)
340 (mapcar (lambda (x)
341 (vector x
342 (list 'font-menu-set-font nil x nil)
343 ':style 'radio ':active nil ':selected nil))
344 weights)))
345 (cdr dev-cache))))
177 346
178 ;; Extract font information from a face. We examine both the 347 ;; Extract font information from a face. We examine both the
179 ;; user-specified font name and the canonical (`true') font name. 348 ;; user-specified font name and the canonical (`true') font name.
180 ;; These can appear to have totally different properties. 349 ;; These can appear to have totally different properties.
181 ;; For examples, see the prolog above. 350 ;; For examples, see the prolog above.
182 351
183 ;; We use the user-specified one if possible, else use the truename. 352 ;; We use the user-specified one if possible, else use the truename.
184 ;; If the user didn't specify one (with "-dt-*-*", for example) 353 ;; If the user didn't specify one (with "-dt-*-*", for example)
185 ;; get the truename and use the possibly suboptimal data from that. 354 ;; get the truename and use the possibly suboptimal data from that.
186 ;;;###autoload 355 (defun* font-menu-font-data (face dcache)
187 (defun* x-font-menu-font-data (face dcache)
188 (let* ((case-fold-search t) 356 (let* ((case-fold-search t)
189 (domain (if font-menu-this-frame-only-p 357 (domain (if font-menu-this-frame-only-p
190 (selected-frame) 358 (selected-frame)
191 (selected-device))) 359 (selected-device)))
192 (name (font-instance-name (face-font-instance face domain))) 360 (name (font-instance-name (face-font-instance face domain)))
200 (when (and (null entry) 368 (when (and (null entry)
201 (string-match x-font-regexp-foundry-and-family truename)) 369 (string-match x-font-regexp-foundry-and-family truename))
202 (setq family (capitalize (match-string 1 truename))) 370 (setq family (capitalize (match-string 1 truename)))
203 (setq entry (vassoc family (aref dcache 0)))) 371 (setq entry (vassoc family (aref dcache 0))))
204 (when (null entry) 372 (when (null entry)
205 (return-from x-font-menu-font-data (make-vector 5 nil))) 373 (return-from font-menu-font-data (make-vector 5 nil)))
206 374
207 (when (string-match x-font-regexp name) 375 (when (string-match x-font-regexp name)
208 (setq weight (capitalize (match-string 1 name))) 376 (setq weight (capitalize (match-string 1 name)))
209 (setq size (string-to-int (match-string 6 name)))) 377 (setq size (string-to-int (match-string 6 name))))
210 378
215 (setq size (string-to-int (match-string 6 truename)))) 383 (setq size (string-to-int (match-string 6 truename))))
216 (setq slant (capitalize (match-string 2 truename)))) 384 (setq slant (capitalize (match-string 2 truename))))
217 385
218 (vector entry family size weight slant))) 386 (vector entry family size weight slant)))
219 387
220 (defun x-font-menu-load-font (family weight size slant resolution) 388 (defun font-menu-split-long-menu (menu)
389 "Split MENU according to `font-menu-max-items'."
390 (let ((len (length menu)))
391 (if (or (null font-menu-max-items)
392 (null (featurep 'lisp-float-type))
393 (<= len font-menu-max-items))
394 menu
395 ;; Submenu is max 2 entries longer than menu, never shorter, number of
396 ;; entries in submenus differ by at most one (with longer submenus first)
397 (let* ((outer (floor (sqrt len)))
398 (inner (/ len outer))
399 (rest (% len outer))
400 (result nil))
401 (setq menu (reverse menu))
402 (while menu
403 (let ((in inner)
404 (sub nil)
405 (to (car menu)))
406 (while (> in 0)
407 (setq in (1- in)
408 sub (cons (car menu) sub)
409 menu (cdr menu)))
410 (setq result
411 (cons (cons (if (stringp font-menu-submenu-name-format)
412 (format font-menu-submenu-name-format
413 (aref (car sub) 0) (aref to 0))
414 (funcall font-menu-submenu-name-format
415 (aref (car sub) 0) (aref to 0)))
416 sub)
417 result)
418 rest (1+ rest))
419 (if (= rest outer) (setq inner (1+ inner)))))
420 result))))
421
422 ;;;###autoload
423 (defun font-menu-family-constructor (ignored)
424 (catch 'menu
425 (unless (eq 'x (device-type (selected-device)))
426 (throw 'menu '(["Cannot parse current font" ding nil])))
427 (let* ((dcache (device-fonts-cache))
428 (font-data (font-menu-font-data 'default dcache))
429 (entry (aref font-data 0))
430 (family (aref font-data 1))
431 (size (aref font-data 2))
432 (weight (aref font-data 3))
433 f)
434 (unless family
435 (throw 'menu '(["Cannot parse current font" ding nil])))
436 ;; Items on the Font menu are enabled iff that font exists in
437 ;; the same size and weight as the current font (scalable fonts
438 ;; exist in every size). Only the current font is marked as
439 ;; selected.
440 (font-menu-split-long-menu
441 (mapcar
442 (lambda (item)
443 (setq f (aref item 0)
444 entry (vassoc f (aref dcache 0)))
445 ;; The user can no longer easily control the weight using the menu
446 ;; Note it is silly anyway as it could very well be that the font
447 ;; has no common size+weight combinations with the default font.
448 ;; (if (and (member weight (aref entry 1))
449 ;; (or (member size (aref entry 2))
450 ;; (and (not font-menu-ignore-scaled-fonts)
451 ;; (member 0 (aref entry 2)))))
452 ;; (enable-menu-item item)
453 ;; (disable-menu-item item))
454 (if (and font-menu-ignore-scaled-fonts (member 0 (aref entry 2)))
455 (disable-menu-item item)
456 (enable-menu-item item))
457 (if (string-equal family f)
458 (select-toggle-menu-item item)
459 (deselect-toggle-menu-item item))
460 item)
461 (aref dcache 1))))))
462
463 ;;;###autoload
464 (defun font-menu-size-constructor (ignored)
465 (catch 'menu
466 (unless (eq 'x (device-type (selected-device)))
467 (throw 'menu '(["Cannot parse current font" ding nil])))
468 (let* ((dcache (device-fonts-cache))
469 (font-data (font-menu-font-data 'default dcache))
470 (entry (aref font-data 0))
471 (family (aref font-data 1))
472 (size (aref font-data 2))
473 ;;(weight (aref font-data 3))
474 s)
475 (unless family
476 (throw 'menu '(["Cannot parse current font" ding nil])))
477 ;; Items on the Size menu are enabled iff current font has
478 ;; that size. Only the size of the current font is selected.
479 ;; (If the current font comes in size 0, it is scalable, and
480 ;; thus has every size.)
481 (mapcar
482 (lambda (item)
483 (setq s (nth 3 (aref item 1)))
484 (if (or (member s (aref entry 2))
485 (and (not font-menu-ignore-scaled-fonts)
486 (member 0 (aref entry 2))))
487 (enable-menu-item item)
488 (disable-menu-item item))
489 (if (eq size s)
490 (select-toggle-menu-item item)
491 (deselect-toggle-menu-item item))
492 item)
493 (aref dcache 2)))))
494
495 ;;;###autoload
496 (defun font-menu-weight-constructor (ignored)
497 (catch 'menu
498 (unless (eq 'x (device-type (selected-device)))
499 (throw 'menu '(["Cannot parse current font" ding nil])))
500 (let* ((dcache (device-fonts-cache))
501 (font-data (font-menu-font-data 'default dcache))
502 (entry (aref font-data 0))
503 (family (aref font-data 1))
504 ;;(size (aref font-data 2))
505 (weight (aref font-data 3))
506 w)
507 (unless family
508 (throw 'menu '(["Cannot parse current font" ding nil])))
509 ;; Items on the Weight menu are enabled iff current font
510 ;; has that weight. Only the weight of the current font
511 ;; is selected.
512 (mapcar
513 (lambda (item)
514 (setq w (aref item 0))
515 (if (member w (aref entry 1))
516 (enable-menu-item item)
517 (disable-menu-item item))
518 (if (string-equal weight w)
519 (select-toggle-menu-item item)
520 (deselect-toggle-menu-item item))
521 item)
522 (aref dcache 3)))))
523
524
525 ;;; Changing font sizes
526
527 (defun font-menu-set-font (family weight size)
528 ;; This is what gets run when an item is selected from any of the three
529 ;; fonts menus. It needs to be rather clever.
530 ;; (size is measured in 10ths of points.)
531 (let* ((dcache (device-fonts-cache))
532 (font-data (font-menu-font-data 'default dcache))
533 (from-family (aref font-data 1))
534 (from-size (aref font-data 2))
535 (from-weight (aref font-data 3))
536 (from-slant (aref font-data 4))
537 new-default-face-font
538 new-props)
539 (unless from-family
540 (signal 'error '("couldn't parse font name for default face")))
541 (when weight
542 (signal 'error '("Setting weight currently not supported")))
543 (setq new-default-face-font
544 (font-menu-load-font (or family from-family)
545 (or weight from-weight)
546 (or size from-size)
547 from-slant
548 font-menu-preferred-resolution))
549 (dolist (face (delq 'default (face-list)))
550 (when (face-font-instance face)
551 (message "Changing font of `%s'..." face)
552 (condition-case c
553 (font-menu-change-face face
554 from-family from-weight from-size
555 family weight size)
556 (error
557 (display-error c nil)
558 (sit-for 1)))))
559 ;; Set the default face's font after hacking the other faces, so that
560 ;; the frame size doesn't change until we are all done.
561
562 ;; If we need to be frame local we do the changes ourselves.
563 (if font-menu-this-frame-only-p
564 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
565 (set-face-font 'default new-default-face-font
566 (and font-menu-this-frame-only-p (selected-frame)))
567 ;; OK Let Customize do it.
568 (when (and family (not (equal family from-family)))
569 (setq new-props (append (list :family family) new-props)))
570 (when (and size (not (equal size from-size)))
571 (setq new-props (append
572 (list :size (concat (int-to-string (/ size 10)) "pt")) new-props)))
573 (custom-set-face-update-spec 'default '((type x)) new-props)
574 (message "Font %s" (face-font-name 'default)))))
575
576
577 (defun font-menu-change-face (face
578 from-family from-weight from-size
579 to-family to-weight to-size)
580 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
581 (let* ((dcache (device-fonts-cache))
582 (font-data (font-menu-font-data face dcache))
583 (face-family (aref font-data 1))
584 (face-size (aref font-data 2))
585 (face-weight (aref font-data 3))
586 (face-slant (aref font-data 4)))
587
588 (or face-family
589 (signal 'error (list "couldn't parse font name for face" face)))
590
591 ;; If this face matches the old default face in the attribute we
592 ;; are changing, then change it to the new attribute along that
593 ;; dimension. Also, the face must have its own global attribute.
594 ;; If its value is inherited, we don't touch it. If any of this
595 ;; is not true, we leave it alone.
596 (when (and (face-font face 'global)
597 (cond
598 (to-family (string-equal face-family from-family))
599 (to-weight (string-equal face-weight from-weight))
600 (to-size (= face-size from-size))))
601 (set-face-font face
602 (font-menu-load-font (or to-family face-family)
603 (or to-weight face-weight)
604 (or to-size face-size)
605 face-slant
606 font-menu-preferred-resolution)
607 (and font-menu-this-frame-only-p
608 (selected-frame))))))
609
610 (defun font-menu-load-font (family weight size slant resolution)
221 "Try to load a font with the requested properties. 611 "Try to load a font with the requested properties.
222 The weight, slant and resolution are only hints." 612 The weight, slant and resolution are only hints."
223 (when (integerp size) (setq size (int-to-string size))) 613 (when (integerp size) (setq size (int-to-string size)))
224 (let (font) 614 (let (font)
225 (catch 'got-font 615 (catch 'got-font
235 (list resolution "*-*"))) 625 (list resolution "*-*")))
236 (when (setq font 626 (when (setq font
237 (make-font-instance 627 (make-font-instance
238 (concat "-*-" family "-" weight "-" slant "-*-*-*-" 628 (concat "-*-" family "-" weight "-" slant "-*-*-*-"
239 size "-" resolution "-*-*-" 629 size "-" resolution "-*-*-"
240 x-font-menu-registry-encoding) 630 font-menu-registry-encoding)
241 nil t)) 631 nil t))
242 (throw 'got-font font)))))))) 632 (throw 'got-font font))))))))
243 633
634 (defun flush-device-fonts-cache (device)
635 ;; by Stig@hackvan.com
636 (let ((elt (assq device device-fonts-cache)))
637 (and elt
638 (setq device-fonts-cache (delq elt device-fonts-cache)))))
639
640 (add-hook 'delete-device-hook 'flush-device-fonts-cache)
641
244 (provide 'x-font-menu) 642 (provide 'x-font-menu)
245 643
246 ;;; x-font-menu.el ends here 644 ;;; x-font-menu.el ends here