-;;;###autoload
-(defun font-menu-family-constructor (ignored)
- (catch 'menu
- (unless (eq 'x (device-type (selected-device)))
- (throw 'menu '(["Cannot parse current font" ding nil])))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (entry (aref font-data 0))
- (family (aref font-data 1))
- (size (aref font-data 2))
- (weight (aref font-data 3))
- f)
- (unless family
- (throw 'menu '(["Cannot parse current font" ding nil])))
- ;; Items on the Font menu are enabled iff that font exists in
- ;; the same size and weight as the current font (scalable fonts
- ;; exist in every size). Only the current font is marked as
- ;; selected.
- (mapcar
- (lambda (item)
- (setq f (aref item 0)
- entry (vassoc f (aref dcache 0)))
- (if (and (member weight (aref entry 1))
- (or (member size (aref entry 2))
- (and (not font-menu-ignore-scaled-fonts)
- (member 0 (aref entry 2)))))
- (enable-menu-item item)
- (disable-menu-item item))
- (if (string-equal family f)
- (select-toggle-menu-item item)
- (deselect-toggle-menu-item item))
- item)
- (aref dcache 1)))))
-
-;;;###autoload
-(defun font-menu-size-constructor (ignored)
- (catch 'menu
- (unless (eq 'x (device-type (selected-device)))
- (throw 'menu '(["Cannot parse current font" ding nil])))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (entry (aref font-data 0))
- (family (aref font-data 1))
- (size (aref font-data 2))
- ;;(weight (aref font-data 3))
- s)
- (unless family
- (throw 'menu '(["Cannot parse current font" ding nil])))
- ;; Items on the Size menu are enabled iff current font has
- ;; that size. Only the size of the current font is selected.
- ;; (If the current font comes in size 0, it is scalable, and
- ;; thus has every size.)
- (mapcar
- (lambda (item)
- (setq s (nth 3 (aref item 1)))
- (if (or (member s (aref entry 2))
- (and (not font-menu-ignore-scaled-fonts)
- (member 0 (aref entry 2))))
- (enable-menu-item item)
- (disable-menu-item item))
- (if (eq size s)
- (select-toggle-menu-item item)
- (deselect-toggle-menu-item item))
- item)
- (aref dcache 2)))))
-
-;;;###autoload
-(defun font-menu-weight-constructor (ignored)
- (catch 'menu
- (unless (eq 'x (device-type (selected-device)))
- (throw 'menu '(["Cannot parse current font" ding nil])))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (entry (aref font-data 0))
- (family (aref font-data 1))
- ;;(size (aref font-data 2))
- (weight (aref font-data 3))
- w)
- (unless family
- (throw 'menu '(["Cannot parse current font" ding nil])))
- ;; Items on the Weight menu are enabled iff current font
- ;; has that weight. Only the weight of the current font
- ;; is selected.
- (mapcar
- (lambda (item)
- (setq w (aref item 0))
- (if (member w (aref entry 1))
- (enable-menu-item item)
- (disable-menu-item item))
- (if (string-equal weight w)
- (select-toggle-menu-item item)
- (deselect-toggle-menu-item item))
- item)
- (aref dcache 3)))))
-
-\f
-;;; Changing font sizes
-
-(defun font-menu-set-font (family weight size)
- ;; This is what gets run when an item is selected from any of the three
- ;; fonts menus. It needs to be rather clever.
- ;; (size is measured in 10ths of points.)
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (from-family (aref font-data 1))
- (from-size (aref font-data 2))
- (from-weight (aref font-data 3))
- (from-slant (aref font-data 4))
- new-default-face-font)
- (unless from-family
- (signal 'error '("couldn't parse font name for default face")))
- (setq new-default-face-font
- (font-menu-load-font (or family from-family)
- (or weight from-weight)
- (or size from-size)
- from-slant
- font-menu-preferred-resolution))
- (dolist (face (delq 'default (face-list)))
- (when (face-font-instance face)
- (message "Changing font of `%s'..." face)
- (condition-case c
- (font-menu-change-face face
- from-family from-weight from-size
- family weight size)
- (error
- (display-error c nil)
- (sit-for 1)))))
- ;; Set the default face's font after hacking the other faces, so that
- ;; the frame size doesn't change until we are all done.
-
- ;;; WMP - we need to honor font-menu-this-frame-only-p here!
- (set-face-font 'default new-default-face-font
- (and font-menu-this-frame-only-p (selected-frame)))
- (message "Font %s" (face-font-name 'default))))
-
-
-(defun font-menu-change-face (face
- from-family from-weight from-size
- to-family to-weight to-size)
- (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data face dcache))
- (face-family (aref font-data 1))
- (face-size (aref font-data 2))
- (face-weight (aref font-data 3))
- (face-slant (aref font-data 4)))
-
- (or face-family
- (signal 'error (list "couldn't parse font name for face" face)))
-
- ;; If this face matches the old default face in the attribute we
- ;; are changing, then change it to the new attribute along that
- ;; dimension. Also, the face must have its own global attribute.
- ;; If its value is inherited, we don't touch it. If any of this
- ;; is not true, we leave it alone.
- (when (and (face-font face 'global)
- (cond
- (to-family (string-equal face-family from-family))
- (to-weight (string-equal face-weight from-weight))
- (to-size (= face-size from-size))))
- (set-face-font face
- (font-menu-load-font (or to-family face-family)
- (or to-weight face-weight)
- (or to-size face-size)
- face-slant
- font-menu-preferred-resolution)
- (and font-menu-this-frame-only-p
- (selected-frame))))))
-
-(defun font-menu-load-font (family weight size slant resolution)