Mercurial > hg > xemacs-beta

comparison lisp/x-font-menu.el @ 371:cc15677e0335 r21-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents 8e84bee8ddd0
children 6240c7796c7a
comparison
equal deleted inserted replaced
370:bd866891f083 371:cc15677e0335
128 ;; #### - implement these... 128 ;; #### - implement these...
129 ;; 129 ;;
130 ;;; (defvar font-menu-ignore-proportional-fonts nil 130 ;;; (defvar font-menu-ignore-proportional-fonts nil
131 ;;; "*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.")
132 132
133 (defgroup font-menu ()
134 "Settings for the font menu"
135 :group 'x)
136
137 ;;;###autoload 133 ;;;###autoload
138 (defcustom font-menu-ignore-scaled-fonts t 134 (defcustom font-menu-ignore-scaled-fonts t
139 "*If non-nil, then the font menu will try to show only bitmap fonts." 135 "*If non-nil, then the font menu will try to show only bitmap fonts."
140 :type 'boolean 136 :type 'boolean
141 :group 'font-menu) 137 :group 'x)
142 138
143 ;;;###autoload 139 ;;;###autoload
144 (defcustom font-menu-this-frame-only-p nil 140 (defcustom font-menu-this-frame-only-p nil
145 "*If non-nil, then changing the default font from the font menu will only 141 "*If non-nil, then changing the default font from the font menu will only
146 affect one frame instead of all frames." 142 affect one frame instead of all frames."
147 :type 'boolean 143 :type 'boolean
148 :group 'font-menu) 144 :group 'x)
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 145
173 ;; only call XListFonts (and parse) once per device. 146 ;; only call XListFonts (and parse) once per device.
174 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...) 147 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
175 (defvar device-fonts-cache nil) 148 (defvar device-fonts-cache nil)
176 149
383 (setq size (string-to-int (match-string 6 truename)))) 356 (setq size (string-to-int (match-string 6 truename))))
384 (setq slant (capitalize (match-string 2 truename)))) 357 (setq slant (capitalize (match-string 2 truename))))
385 358
386 (vector entry family size weight slant))) 359 (vector entry family size weight slant)))
387 360
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 361 ;;;###autoload
423 (defun font-menu-family-constructor (ignored) 362 (defun font-menu-family-constructor (ignored)
424 (catch 'menu 363 (catch 'menu
425 (unless (eq 'x (device-type (selected-device))) 364 (unless (eq 'x (device-type (selected-device)))
426 (throw 'menu '(["Cannot parse current font" ding nil]))) 365 (throw 'menu '(["Cannot parse current font" ding nil])))
435 (throw 'menu '(["Cannot parse current font" ding nil]))) 374 (throw 'menu '(["Cannot parse current font" ding nil])))
436 ;; Items on the Font menu are enabled iff that font exists in 375 ;; Items on the Font menu are enabled iff that font exists in
437 ;; the same size and weight as the current font (scalable fonts 376 ;; the same size and weight as the current font (scalable fonts
438 ;; exist in every size). Only the current font is marked as 377 ;; exist in every size). Only the current font is marked as
439 ;; selected. 378 ;; selected.
440 (font-menu-split-long-menu 379 (mapcar
441 (mapcar 380 (lambda (item)
442 (lambda (item) 381 (setq f (aref item 0)
443 (setq f (aref item 0) 382 entry (vassoc f (aref dcache 0)))
444 entry (vassoc f (aref dcache 0))) 383 (if (and (member weight (aref entry 1))
445 ;; The user can no longer easily control the weight using the menu 384 (or (member size (aref entry 2))
446 ;; Note it is silly anyway as it could very well be that the font 385 (and (not font-menu-ignore-scaled-fonts)
447 ;; has no common size+weight combinations with the default font. 386 (member 0 (aref entry 2)))))
448 (if (and (not (member size (aref entry 2))) 387 (enable-menu-item item)
449 font-menu-ignore-scaled-fonts (member 0 (aref entry 2))) 388 (disable-menu-item item))
450 (disable-menu-item item) 389 (if (string-equal family f)
451 (enable-menu-item item)) 390 (select-toggle-menu-item item)
452 (if (string-equal family f) 391 (deselect-toggle-menu-item item))
453 (select-toggle-menu-item item) 392 item)
454 (deselect-toggle-menu-item item)) 393 (aref dcache 1)))))
455 item)
456 (aref dcache 1))))))
457 394
458 ;;;###autoload 395 ;;;###autoload
459 (defun font-menu-size-constructor (ignored) 396 (defun font-menu-size-constructor (ignored)
460 (catch 'menu 397 (catch 'menu
461 (unless (eq 'x (device-type (selected-device))) 398 (unless (eq 'x (device-type (selected-device)))
527 (font-data (font-menu-font-data 'default dcache)) 464 (font-data (font-menu-font-data 'default dcache))
528 (from-family (aref font-data 1)) 465 (from-family (aref font-data 1))
529 (from-size (aref font-data 2)) 466 (from-size (aref font-data 2))
530 (from-weight (aref font-data 3)) 467 (from-weight (aref font-data 3))
531 (from-slant (aref font-data 4)) 468 (from-slant (aref font-data 4))
532 new-default-face-font 469 new-default-face-font)
533 new-props)
534 (unless from-family 470 (unless from-family
535 (signal 'error '("couldn't parse font name for default face"))) 471 (signal 'error '("couldn't parse font name for default face")))
536 (when weight
537 (signal 'error '("Setting weight currently not supported")))
538 (setq new-default-face-font 472 (setq new-default-face-font
539 (font-menu-load-font (or family from-family) 473 (font-menu-load-font (or family from-family)
540 (or weight from-weight) 474 (or weight from-weight)
541 (or size from-size) 475 (or size from-size)
542 from-slant 476 from-slant
552 (display-error c nil) 486 (display-error c nil)
553 (sit-for 1))))) 487 (sit-for 1)))))
554 ;; Set the default face's font after hacking the other faces, so that 488 ;; Set the default face's font after hacking the other faces, so that
555 ;; the frame size doesn't change until we are all done. 489 ;; the frame size doesn't change until we are all done.
556 490
557 ;; If we need to be frame local we do the changes ourselves.
558 (if font-menu-this-frame-only-p
559 ;;; WMP - we need to honor font-menu-this-frame-only-p here! 491 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
560 (set-face-font 'default new-default-face-font 492 (set-face-font 'default new-default-face-font
561 (and font-menu-this-frame-only-p (selected-frame))) 493 (and font-menu-this-frame-only-p (selected-frame)))
562 ;; OK Let Customize do it. 494 (message "Font %s" (face-font-name 'default))))
563 (when (and family (not (equal family from-family)))
564 (setq new-props (append (list :family family) new-props)))
565 (when (and size (not (equal size from-size)))
566 (setq new-props (append
567 (list :size (concat (int-to-string (/ size 10)) "pt")) new-props)))
568 (custom-set-face-update-spec 'default '((type x)) new-props)
569 (message "Font %s" (face-font-name 'default)))))
570 495
571 496
572 (defun font-menu-change-face (face 497 (defun font-menu-change-face (face
573 from-family from-weight from-size 498 from-family from-weight from-size
574 to-family to-weight to-size) 499 to-family to-weight to-size)