Mercurial > hg > xemacs-beta

comparison lisp/x-font-menu.el @ 343:8bec6624d99b r21-1-1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-1-1
author cvs
date Mon, 13 Aug 2007 10:52:53 +0200
parents 19dcec799385
children 8e84bee8ddd0
comparison
equal deleted inserted replaced
342:b036ce23deaa 343:8bec6624d99b
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
133 ;;;###autoload 137 ;;;###autoload
134 (defcustom font-menu-ignore-scaled-fonts t 138 (defcustom font-menu-ignore-scaled-fonts t
135 "*If non-nil, then the font menu will try to show only bitmap fonts." 139 "*If non-nil, then the font menu will try to show only bitmap fonts."
136 :type 'boolean 140 :type 'boolean
137 :group 'x) 141 :group 'font-menu)
138 142
139 ;;;###autoload 143 ;;;###autoload
140 (defcustom font-menu-this-frame-only-p nil 144 (defcustom font-menu-this-frame-only-p nil
141 "*If non-nil, then changing the default font from the font menu will only 145 "*If non-nil, then changing the default font from the font menu will only
142 affect one frame instead of all frames." 146 affect one frame instead of all frames."
143 :type 'boolean 147 :type 'boolean
144 :group 'x) 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
145 172
146 ;; only call XListFonts (and parse) once per device. 173 ;; only call XListFonts (and parse) once per device.
147 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...) 174 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
148 (defvar device-fonts-cache nil) 175 (defvar device-fonts-cache nil)
149 176
356 (setq size (string-to-int (match-string 6 truename)))) 383 (setq size (string-to-int (match-string 6 truename))))
357 (setq slant (capitalize (match-string 2 truename)))) 384 (setq slant (capitalize (match-string 2 truename))))
358 385
359 (vector entry family size weight slant))) 386 (vector entry family size weight slant)))
360 387
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
361 ;;;###autoload 422 ;;;###autoload
362 (defun font-menu-family-constructor (ignored) 423 (defun font-menu-family-constructor (ignored)
363 (catch 'menu 424 (catch 'menu
364 (unless (eq 'x (device-type (selected-device))) 425 (unless (eq 'x (device-type (selected-device)))
365 (throw 'menu '(["Cannot parse current font" ding nil]))) 426 (throw 'menu '(["Cannot parse current font" ding nil])))
374 (throw 'menu '(["Cannot parse current font" ding nil]))) 435 (throw 'menu '(["Cannot parse current font" ding nil])))
375 ;; Items on the Font menu are enabled iff that font exists in 436 ;; Items on the Font menu are enabled iff that font exists in
376 ;; the same size and weight as the current font (scalable fonts 437 ;; the same size and weight as the current font (scalable fonts
377 ;; exist in every size). Only the current font is marked as 438 ;; exist in every size). Only the current font is marked as
378 ;; selected. 439 ;; selected.
379 (mapcar 440 (font-menu-split-long-menu
380 (lambda (item) 441 (mapcar
381 (setq f (aref item 0) 442 (lambda (item)
382 entry (vassoc f (aref dcache 0))) 443 (setq f (aref item 0)
383 (if (and (member weight (aref entry 1)) 444 entry (vassoc f (aref dcache 0)))
384 (or (member size (aref entry 2)) 445 ;; The user can no longer easily control the weight using the menu
385 (and (not font-menu-ignore-scaled-fonts) 446 ;; Note it is silly anyway as it could very well be that the font
386 (member 0 (aref entry 2))))) 447 ;; has no common size+weight combinations with the default font.
387 (enable-menu-item item) 448 ;; (if (and (member weight (aref entry 1))
388 (disable-menu-item item)) 449 ;; (or (member size (aref entry 2))
389 (if (string-equal family f) 450 ;; (and (not font-menu-ignore-scaled-fonts)
390 (select-toggle-menu-item item) 451 ;; (member 0 (aref entry 2)))))
391 (deselect-toggle-menu-item item)) 452 ;; (enable-menu-item item)
392 item) 453 ;; (disable-menu-item item))
393 (aref dcache 1))))) 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))))))
394 462
395 ;;;###autoload 463 ;;;###autoload
396 (defun font-menu-size-constructor (ignored) 464 (defun font-menu-size-constructor (ignored)
397 (catch 'menu 465 (catch 'menu
398 (unless (eq 'x (device-type (selected-device))) 466 (unless (eq 'x (device-type (selected-device)))