Mercurial > hg > xemacs-beta

comparison lisp/font-menu.el @ 404:2f8bb876ab1d r21-2-32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-32
author cvs
date Mon, 13 Aug 2007 11:16:07 +0200
parents 74fd4e045ea6
children
comparison
equal deleted inserted replaced
403:9f011ab08d48 404:2f8bb876ab1d
165 165
166 (defvar font-menu-size-scaling 166 (defvar font-menu-size-scaling
167 (make-specifier-and-init 'integer '((global ((mswindows) . 1) 167 (make-specifier-and-init 'integer '((global ((mswindows) . 1)
168 ((x) . 10))) t) 168 ((x) . 10))) t)
169 "Scale factor used in defining font sizes.") 169 "Scale factor used in defining font sizes.")
170
171 (defun vassoc (key valist)
172 "Search VALIST for a vector whose first element is equal to KEY.
173 See also `assoc'."
174 ;; by Stig@hackvan.com
175 (let (el)
176 (catch 'done
177 (while (setq el (pop valist))
178 (and (equal key (aref el 0))
179 (throw 'done el))))))
180 170
181 ;; only call XListFonts (and parse) once per device. 171 ;; only call XListFonts (and parse) once per device.
182 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...) 172 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
183 (defvar device-fonts-cache nil) 173 (defvar device-fonts-cache nil)
184 174
205 nil 195 nil
206 (call-device-method 'reset-device-font-menus device device debug) 196 (call-device-method 'reset-device-font-menus device device debug)
207 (message "Getting list of fonts from server... done."))) 197 (message "Getting list of fonts from server... done.")))
208 198
209 (defun font-menu-split-long-menu (menu) 199 (defun font-menu-split-long-menu (menu)
210 "Split MENU according to `font-menu-max-items'." 200 "Split MENU according to `font-menu-max-items' and add accelerator specs."
211 (let ((len (length menu))) 201 (let ((len (length menu)))
212 (if (or (null font-menu-max-items) 202 (if (or (null font-menu-max-items)
213 (null (featurep 'lisp-float-type)) 203 (null (featurep 'lisp-float-type))
214 (<= len font-menu-max-items)) 204 (<= len font-menu-max-items))
215 menu 205 (submenu-generate-accelerator-spec menu)
216 ;; Submenu is max 2 entries longer than menu, never shorter, number of 206 ;; Submenu is max 2 entries longer than menu, never shorter, number of
217 ;; entries in submenus differ by at most one (with longer submenus first) 207 ;; entries in submenus differ by at most one (with longer submenus first)
218 (let* ((outer (floor (sqrt len))) 208 (let* ((outer (floor (sqrt len)))
219 (inner (/ len outer)) 209 (inner (/ len outer))
220 (rest (% len outer)) 210 (rest (% len outer))
229 sub (cons (car menu) sub) 219 sub (cons (car menu) sub)
230 menu (cdr menu))) 220 menu (cdr menu)))
231 (setq result 221 (setq result
232 (cons (cons (if (stringp font-menu-submenu-name-format) 222 (cons (cons (if (stringp font-menu-submenu-name-format)
233 (format font-menu-submenu-name-format 223 (format font-menu-submenu-name-format
234 (aref (car sub) 0) (aref to 0)) 224 (menu-item-strip-accelerator-spec
225 (aref (car sub) 0))
226 (menu-item-strip-accelerator-spec
227 (aref to 0)))
235 (funcall font-menu-submenu-name-format 228 (funcall font-menu-submenu-name-format
236 (aref (car sub) 0) (aref to 0))) 229 (menu-item-strip-accelerator-spec
237 sub) 230 (aref (car sub) 0))
231 (menu-item-strip-accelerator-spec
232 (aref to 0))))
233 (submenu-generate-accelerator-spec sub))
238 result) 234 result)
239 rest (1+ rest)) 235 rest (1+ rest))
240 (if (= rest outer) (setq inner (1+ inner))))) 236 (if (= rest outer) (setq inner (1+ inner)))))
241 result)))) 237 (submenu-generate-accelerator-spec result)))))
242 238
243 ;;;###autoload 239 ;;;###autoload
244 (defun font-menu-family-constructor (ignored) 240 (defun font-menu-family-constructor (ignored)
245 (catch 'menu 241 (catch 'menu
246 (unless (console-on-window-system-p) 242 (unless (console-on-window-system-p)
259 ;; exist in every size). Only the current font is marked as 255 ;; exist in every size). Only the current font is marked as
260 ;; selected. 256 ;; selected.
261 (font-menu-split-long-menu 257 (font-menu-split-long-menu
262 (mapcar 258 (mapcar
263 (lambda (item) 259 (lambda (item)
264 (setq f (aref item 0) 260 (setq f (menu-item-strip-accelerator-spec (aref item 0))
265 entry (vassoc f (aref dcache 0))) 261 entry (vassoc f (aref dcache 0)))
266 (if (and (or (member weight (aref entry 1)) 262 (if (and (or (member weight (aref entry 1))
267 ;; mswindows often allows any weight 263 ;; mswindows often allows any weight
268 (member "" (aref entry 1))) 264 (member "" (aref entry 1)))
269 (or (member size (aref entry 2)) 265 (or (member size (aref entry 2))
307 (disable-menu-item item)) 303 (disable-menu-item item))
308 (if (eq size s) 304 (if (eq size s)
309 (select-toggle-menu-item item) 305 (select-toggle-menu-item item)
310 (deselect-toggle-menu-item item)) 306 (deselect-toggle-menu-item item))
311 item) 307 item)
312 (aref dcache 2))))) 308 (submenu-generate-accelerator-spec (aref dcache 2))))))
313 309
314 ;;;###autoload 310 ;;;###autoload
315 (defun font-menu-weight-constructor (ignored) 311 (defun font-menu-weight-constructor (ignored)
316 (catch 'menu 312 (catch 'menu
317 (unless (console-on-window-system-p) 313 (unless (console-on-window-system-p)
336 (disable-menu-item item)) 332 (disable-menu-item item))
337 (if (string-equal weight w) 333 (if (string-equal weight w)
338 (select-toggle-menu-item item) 334 (select-toggle-menu-item item)
339 (deselect-toggle-menu-item item)) 335 (deselect-toggle-menu-item item))
340 item) 336 item)
341 (aref dcache 3))))) 337 (submenu-generate-accelerator-spec (aref dcache 3))))))
342 338
343 339
344 ;;; Changing font sizes 340 ;;; Changing font sizes
345 341
346 (defun font-menu-set-font (family weight size) 342 (defun font-menu-set-font (family weight size)
349 ;; (size is measured in 10ths of points.) 345 ;; (size is measured in 10ths of points.)
350 (let* ((dcache (device-fonts-cache)) 346 (let* ((dcache (device-fonts-cache))
351 (font-data (font-menu-font-data 'default dcache)) 347 (font-data (font-menu-font-data 'default dcache))
352 (from-family (aref font-data 1)) 348 (from-family (aref font-data 1))
353 (from-size (aref font-data 2)) 349 (from-size (aref font-data 2))
354 (from-weight (aref font-data 3)) 350 (from-weight (aref font-data 3))
355 (from-slant (aref font-data 4)) 351 (from-slant (aref font-data 4))
356 (face-list-to-change (delq 'default (face-list))) 352 (face-list-to-change (delq 'default (face-list)))
357 new-default-face-font 353 new-default-face-font)
358 new-props)
359 (unless from-family 354 (unless from-family
360 (signal 'error '("couldn't parse font name for default face"))) 355 (signal 'error '("couldn't parse font name for default face")))
361 (when weight 356 (when weight
362 (signal 'error '("Setting weight currently not supported"))) 357 (signal 'error '("Setting weight currently not supported")))
363 (setq new-default-face-font 358 (setq new-default-face-font
394 ;;; WMP - we need to honor font-menu-this-frame-only-p here! 389 ;;; WMP - we need to honor font-menu-this-frame-only-p here!
395 (set-face-font 'default new-default-face-font 390 (set-face-font 'default new-default-face-font
396 (and font-menu-this-frame-only-p (selected-frame))) 391 (and font-menu-this-frame-only-p (selected-frame)))
397 ;; OK Let Customize do it. 392 ;; OK Let Customize do it.
398 (custom-set-face-update-spec 'default 393 (custom-set-face-update-spec 'default
399 (list (list 'type (device-type))) 394 (list (list 'type (device-type)))
400 (list :family family 395 (list :family family
401 :size (concat 396 :size (concat
402 (int-to-string 397 (int-to-string
403 (/ (or size from-size) 398 (/ (or size from-size)
404 (specifier-instance font-menu-size-scaling 399 (specifier-instance font-menu-size-scaling
405 (selected-device)))) 400 (selected-device))))
406 "pt"))) 401 "pt")))
407 (message "Font %s" (face-font-name 'default))))) 402 (message "Font %s" (face-font-name 'default)))))
408 403
409 404
410 (defun font-menu-change-face (face 405 (defun font-menu-change-face (face
411 from-family from-weight from-size 406 from-family from-weight from-size