Mercurial > hg > xemacs-beta

comparison lisp/x11/x-font-menu.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents c0c698873ce1
children 364816949b59
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
87 ;;; ================================= 87 ;;; =================================
88 ;;; When reporting problems, send the following information: 88 ;;; When reporting problems, send the following information:
89 ;;; 89 ;;;
90 ;;; - Exactly what behavior you're seeing; 90 ;;; - Exactly what behavior you're seeing;
91 ;;; - The output of the `xlsfonts' program; 91 ;;; - The output of the `xlsfonts' program;
92 ;;; - The value of the variable `fonts-menu-cache'; 92 ;;; - The value of the variable `device-fonts-cache';
93 ;;; - The values of the following expressions, both before and after 93 ;;; - The values of the following expressions, both before and after
94 ;;; making a selection from any of the fonts-related menus: 94 ;;; making a selection from any of the fonts-related menus:
95 ;;; (face-font 'default) 95 ;;; (face-font 'default)
96 ;;; (font-instance-truename (face-font 'default)) 96 ;;; (font-truename (face-font 'default))
97 ;;; (font-instance-properties (face-font 'default)) 97 ;;; (font-properties (face-font 'default))
98 ;;; - The values of the following variables after making a selection: 98 ;;; - The values of the following variables after making a selection:
99 ;;; font-menu-preferred-resolution 99 ;;; font-menu-preferred-resolution
100 ;;; font-menu-preferred-registry 100 ;;; font-menu-preferred-registry
101 ;;; 101 ;;;
102 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also 102 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
139 ; font family for each font face! Losers. 139 ; font family for each font face! Losers.
140 ; "Axcor" -> "Applix Courier Roman", 140 ; "Axcor" -> "Applix Courier Roman",
141 ; "Axcob" -> "Applix Courier Bold", etc. 141 ; "Axcob" -> "Applix Courier Bold", etc.
142 ) 142 )
143 "\\|")) 143 "\\|"))
144 "A regexp matching font families which are uninteresting (cursor fonts).") 144 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
145 145
146 (defun hack-font-truename (fn) 146 (defun hack-font-truename (fn)
147 "Filter the output of `font-instance-truename' to deal with Japanese fontsets." 147 "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
148 (if (string-match "," (font-instance-truename fn)) 148 (if (string-match "," (font-instance-truename fn))
149 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) 149 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
194 (if (and (getenv "LANG") 194 (if (and (getenv "LANG")
195 (string-match "^\\(ja\\|japanese\\)$" 195 (string-match "^\\(ja\\|japanese\\)$"
196 (getenv "LANG"))) 196 (getenv "LANG")))
197 ;; #### - this is questionable behavior left over from the I18N4 code. 197 ;; #### - this is questionable behavior left over from the I18N4 code.
198 (setq x-font-regexp-ja "jisx[^-]*-[^-]*$" 198 (setq x-font-regexp-ja "jisx[^-]*-[^-]*$"
199 font-menu-preferred-registry '("*" . "*"))) 199 font-menu-preferred-registry '("*" . "*")
200 font-menu-preferred-resolution '("*" . "*")))
200 (let ((all-fonts nil) 201 (let ((all-fonts nil)
201 (case-fold-search t) 202 (case-fold-search t)
202 name family size weight entry monospaced-p 203 name family size weight entry monospaced-p
203 dev-cache 204 dev-cache
204 (cache nil) 205 (cache nil)
210 (t 211 (t
211 (setq all-fonts 212 (setq all-fonts
212 (or debug 213 (or debug
213 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))))) 214 (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)))))
214 (while (setq name (pop all-fonts)) 215 (while (setq name (pop all-fonts))
215 (cond ((and (or (not x-font-regexp-ja) 216 (when (and (or (not x-font-regexp-ja)
216 (string-match x-font-regexp-ja name)) 217 (string-match x-font-regexp-ja name))
217 (string-match x-font-regexp name)) 218 (string-match x-font-regexp name))
218 (setq weight (capitalize (match-string 1 name)) 219 (setq weight (capitalize (match-string 1 name))
219 size (string-to-int (match-string 6 name))) 220 size (string-to-int (match-string 6 name)))
220 (or (string-match x-font-regexp-foundry-and-family name) 221 (or (string-match x-font-regexp-foundry-and-family name)
221 (error "internal error")) 222 (error "internal error"))
222 (setq family (capitalize (match-string 1 name))) 223 (setq family (capitalize (match-string 1 name)))
223 (or (string-match x-font-regexp-spacing name) 224 (or (string-match x-font-regexp-spacing name)
224 (error "internal error")) 225 (error "internal error"))
225 (setq monospaced-p (string= "m" (match-string 1 name))) 226 (setq monospaced-p (string= "m" (match-string 1 name)))
226 (if (string-match fonts-menu-junk-families family) 227 (unless (string-match fonts-menu-junk-families family)
227 nil 228 (setq entry (or (vassoc family cache)
228 (setq entry (or (vassoc family cache) 229 (car (setq cache
229 (car (setq cache 230 (cons (vector family nil nil t)
230 (cons (vector family nil nil t) 231 cache)))))
231 cache))))) 232 (or (member family families)
232 (or (member family families) 233 (setq families (cons family families)))
233 (setq families (cons family families))) 234 (or (member weight weights)
234 (or (member weight weights) 235 (setq weights (cons weight weights)))
235 (setq weights (cons weight weights))) 236 (or (member weight (aref entry 1))
236 (or (member weight (aref entry 1)) 237 (aset entry 1 (cons weight (aref entry 1))))
237 (aset entry 1 (cons weight (aref entry 1)))) 238 (or (member size sizes)
238 (or (member size sizes) 239 (setq sizes (cons size sizes)))
239 (setq sizes (cons size sizes))) 240 (or (member size (aref entry 2))
240 (or (member size (aref entry 2)) 241 (aset entry 2 (cons size (aref entry 2))))
241 (aset entry 2 (cons size (aref entry 2)))) 242 (aset entry 3 (and (aref entry 3) monospaced-p))
242 (aset entry 3 (and (aref entry 3) monospaced-p)) 243 )))
243 ))))
244 ;; 244 ;;
245 ;; Hack scalable fonts. 245 ;; Hack scalable fonts.
246 ;; Some fonts come only in scalable versions (the only size is 0) 246 ;; Some fonts come only in scalable versions (the only size is 0)
247 ;; and some fonts come in both scalable and non-scalable versions 247 ;; and some fonts come in both scalable and non-scalable versions
248 ;; (one size is 0). If there are any scalable fonts at all, make 248 ;; (one size is 0). If there are any scalable fonts at all, make
303 (list 'font-menu-set-font nil x nil) 303 (list 'font-menu-set-font nil x nil)
304 ':style 'radio ':active nil ':selected nil)) 304 ':style 'radio ':active nil ':selected nil))
305 weights))) 305 weights)))
306 (cdr dev-cache)))) 306 (cdr dev-cache))))
307 307
308 (defsubst font-menu-truename (face)
309 (hack-font-truename
310 (if (featurep 'mule)
311 (face-font-instance face nil 'ascii)
312 (face-font-instance face))))
313
314 ;;; Extract a font family from a face.
315 ;;; Use the user-specified one if possible.
316 ;;; If the user didn't specify one (with "*", for example)
317 ;;; get the truename and use the guaranteed family from that.
318 (defun font-menu-family (face)
319 (let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
320 (name (font-instance-name (face-font-instance face)))
321 (family nil))
322 (when (string-match x-font-regexp-foundry-and-family name)
323 (setq family (capitalize (match-string 1 name))))
324 (when (not (and family (vassoc family (aref dcache 0))))
325 (setq name (font-menu-truename face))
326 (string-match x-font-regexp-foundry-and-family name)
327 (setq family (capitalize (match-string 1 name))))
328 family))
329
308 ;;;###autoload 330 ;;;###autoload
309 (defun font-menu-family-constructor (ignored) 331 (defun font-menu-family-constructor (ignored)
310 ;; by Stig@hackvan.com 332 ;; by Stig@hackvan.com
311 (if (not (eq 'x (device-type (selected-device)))) 333 (if (not (eq 'x (device-type (selected-device))))
312 '(["Cannot parse current font" ding nil]) 334 '(["Cannot parse current font" ding nil])
313 (let ((dcache (cdr (assq (selected-device) device-fonts-cache))) 335 (let* ((dcache (cdr (assq (selected-device) device-fonts-cache)))
314 (name (hack-font-truename (face-font-instance 'default))) 336 (name (font-menu-truename 'default))
315 (case-fold-search t) 337 (case-fold-search t)
316 family weight size ; parsed from current font 338 family weight size ; parsed from current font
317 entry ; font cache entry 339 entry ; font cache entry
318 f) 340 f)
319 (or dcache 341 (or dcache
320 (setq dcache (reset-device-font-menus (selected-device)))) 342 (setq dcache (reset-device-font-menus (selected-device))))
321 (if (not (string-match x-font-regexp name)) 343 (if (not (string-match x-font-regexp name))
322 ;; couldn't parse current font 344 ;; couldn't parse current font
323 '(["Cannot parse current font" ding nil]) 345 '(["Cannot parse current font" ding nil])
324 (setq weight (capitalize (match-string 1 name))) 346 (setq weight (capitalize (match-string 1 name)))
325 (setq size (string-to-number (match-string 6 name))) 347 (setq size (string-to-number (match-string 6 name)))
326 (and (string-match x-font-regexp-foundry-and-family name) 348 (setq family (font-menu-family 'default))
327 (setq family (capitalize (match-string 1 name))))
328 (setq entry (vassoc family (aref dcache 0))) 349 (setq entry (vassoc family (aref dcache 0)))
329 (mapcar #'(lambda (item) 350 (mapcar #'(lambda (item)
330 ;; 351 ;;
331 ;; Items on the Font menu are enabled iff that font 352 ;; Items on the Font menu are enabled iff that font
332 ;; exists in the same size and weight as the current 353 ;; exists in the same size and weight as the current
352 (defun font-menu-size-constructor (ignored) 373 (defun font-menu-size-constructor (ignored)
353 ;; by Stig@hackvan.com 374 ;; by Stig@hackvan.com
354 (if (not (eq 'x (device-type (selected-device)))) 375 (if (not (eq 'x (device-type (selected-device))))
355 '(["Cannot parse current font" ding nil]) 376 '(["Cannot parse current font" ding nil])
356 (let ((dcache (cdr (assq (selected-device) device-fonts-cache))) 377 (let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
357 (name (hack-font-truename (face-font-instance 'default))) 378 (name (font-menu-truename 'default))
358 (case-fold-search t) 379 (case-fold-search t)
359 family size ; parsed from current font 380 family size ; parsed from current font
360 entry ; font cache entry 381 entry ; font cache entry
361 s) 382 s)
362 (or dcache 383 (or dcache
363 (setq dcache (reset-device-font-menus (selected-device)))) 384 (setq dcache (reset-device-font-menus (selected-device))))
364 (if (not (string-match x-font-regexp name)) 385 (if (not (string-match x-font-regexp name))
365 ;; couldn't parse current font 386 ;; couldn't parse current font
366 '(["Cannot parse current font" ding nil]) 387 '(["Cannot parse current font" ding nil])
367 (setq size (string-to-number (match-string 6 name))) 388 (setq size (string-to-number (match-string 6 name)))
368 (and (string-match x-font-regexp-foundry-and-family name) 389 (setq family (font-menu-family 'default))
369 (setq family (capitalize (match-string 1 name))))
370 (setq entry (vassoc family (aref dcache 0))) 390 (setq entry (vassoc family (aref dcache 0)))
371 (mapcar 391 (mapcar
372 (lambda (item) 392 (lambda (item)
373 ;; 393 ;;
374 ;; Items on the Size menu are enabled iff current font has 394 ;; Items on the Size menu are enabled iff current font has
393 (defun font-menu-weight-constructor (ignored) 413 (defun font-menu-weight-constructor (ignored)
394 ;; by Stig@hackvan.com 414 ;; by Stig@hackvan.com
395 (if (not (eq 'x (device-type (selected-device)))) 415 (if (not (eq 'x (device-type (selected-device))))
396 '(["Cannot parse current font" ding nil]) 416 '(["Cannot parse current font" ding nil])
397 (let ((dcache (cdr (assq (selected-device) device-fonts-cache))) 417 (let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
398 (name (hack-font-truename (face-font-instance 'default))) 418 (name (font-menu-truename 'default))
399 (case-fold-search t) 419 (case-fold-search t)
400 family weight ; parsed from current font 420 family weight ; parsed from current font
401 entry ; font cache entry 421 entry ; font cache entry
402 w) 422 w)
403 (or dcache 423 (or dcache
404 (setq dcache (reset-device-font-menus (selected-device)))) 424 (setq dcache (reset-device-font-menus (selected-device))))
405 (if (not (string-match x-font-regexp name)) 425 (if (not (string-match x-font-regexp name))
406 ;; couldn't parse current font 426 ;; couldn't parse current font
407 '(["Cannot parse current font" ding nil]) 427 '(["Cannot parse current font" ding nil])
408 (setq weight (capitalize (match-string 1 name))) 428 (setq weight (capitalize (match-string 1 name)))
409 (and (string-match x-font-regexp-foundry-and-family name) 429 (setq family (font-menu-family 'default))
410 (setq family (capitalize (match-string 1 name))))
411 (setq entry (vassoc family (aref dcache 0))) 430 (setq entry (vassoc family (aref dcache 0)))
412 (mapcar #'(lambda (item) 431 (mapcar #'(lambda (item)
413 ;;
414 ;; Items on the Weight menu are enabled iff current font 432 ;; Items on the Weight menu are enabled iff current font
415 ;; has that weight. Only the weight of the current font 433 ;; has that weight. Only the weight of the current font
416 ;; is selected. 434 ;; is selected.
417 ;;
418 (setq w (aref item 0)) 435 (setq w (aref item 0))
419 (if (member w (aref entry 1)) 436 (if (member w (aref entry 1))
420 (enable-menu-item item) 437 (enable-menu-item item)
421 (disable-menu-item item)) 438 (disable-menu-item item))
422 (if (equal weight w) 439 (if (equal weight w)
432 (defun font-menu-set-font (family weight size) 449 (defun font-menu-set-font (family weight size)
433 ;; This is what gets run when an item is selected from any of the three 450 ;; This is what gets run when an item is selected from any of the three
434 ;; fonts menus. It needs to be rather clever. 451 ;; fonts menus. It needs to be rather clever.
435 ;; (size is measured in 10ths of points.) 452 ;; (size is measured in 10ths of points.)
436 (let ((faces (delq 'default (face-list))) 453 (let ((faces (delq 'default (face-list)))
437 (default-name (hack-font-truename (face-font-instance 'default))) 454 (default-name (font-menu-truename 'default))
438 (case-fold-search t) 455 (case-fold-search t)
439 new-default-face-font 456 new-default-face-font
440 from-family from-weight from-size) 457 from-family from-weight from-size)
441 ;; 458 ;;
442 ;; First, parse out the default face's font. 459 ;; First, parse out the default face's font.
443 ;; 460 ;;
444 (or (string-match x-font-regexp-foundry-and-family default-name) 461 (setq from-family (font-menu-family 'default))
445 (signal 'error (list "couldn't parse font name" default-name)))
446 (setq from-family (capitalize (match-string 1 default-name)))
447 (or (string-match x-font-regexp default-name) 462 (or (string-match x-font-regexp default-name)
448 (signal 'error (list "couldn't parse font name" default-name))) 463 (signal 'error (list "couldn't parse font name" default-name)))
449 (setq from-weight (capitalize (match-string 1 default-name))) 464 (setq from-weight (capitalize (match-string 1 default-name)))
450 (setq from-size (match-string 6 default-name)) 465 (setq from-size (match-string 6 default-name))
451 (setq new-default-face-font 466 (setq new-default-face-font
475 490
476 (defun font-menu-change-face (face 491 (defun font-menu-change-face (face
477 from-family from-weight from-size 492 from-family from-weight from-size
478 to-family to-weight to-size) 493 to-family to-weight to-size)
479 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face))) 494 (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
480 (let* ((font (face-font-instance face)) 495 (let* ((name (font-menu-truename face))
481 (name (hack-font-truename font))
482 (case-fold-search t) 496 (case-fold-search t)
483 face-family 497 face-family
484 face-weight 498 face-weight
485 face-size) 499 face-size)
486 ;; First, parse out the face's font. 500 ;; First, parse out the face's font.
525 (or (string-match x-font-regexp from-font) 539 (or (string-match x-font-regexp from-font)
526 (signal 'error (list "couldn't parse font name" from-font))) 540 (signal 'error (list "couldn't parse font name" from-font)))
527 (setq slant (capitalize (match-string 2 from-font)) 541 (setq slant (capitalize (match-string 2 from-font))
528 resx (match-string 7 from-font) 542 resx (match-string 7 from-font)
529 resy (match-string 8 from-font)) 543 resy (match-string 8 from-font))
530 (cond ((equal slant "O") (setq other-slant "I")) ; oh, bite me. 544 (setq other-slant (cond ((equal slant "O") "I") ; oh, bite me.
531 ((equal slant "I") (setq other-slant "O")) 545 ((equal slant "I") "O")
532 (t (setq other-slant nil))) 546 (t nil)))
533 ;; 547 ;;
534 ;; Remember these values for the first font we switch away from 548 ;; Remember these values for the first font we switch away from
535 ;; (the original default font). 549 ;; (the original default font).
536 ;; 550 ;;
537 (or font-menu-preferred-resolution 551 (or font-menu-preferred-resolution