Re: Interactive font selector

[Jason Rumney]

Richard Stallman <address@hidden> writes:

>     To really be usable and similar to other applications, emacs need to
>     reimplement some GTK widgets (or of course, start to use GTK).
> 
> We don't need this large change to add the specific feature that
> you've proposed.

I have the following code that implements interactive font selection
on X, using either gfontsel or xfontsel (or some other user specified
command).  It contains a replacement mouse-set-font, which adds an
extra submenu (I could not find a way to easily add a top level menu
item using easymenu), and an interactive function
`set-font-for-face-at-point', which could be used in the Text
Properties menu.


;;; Experimental font selection with a dialog.

(defcustom x-select-font-commands
  '(("gfontsel" "--print" "-f" nil)
    ("xfontsel" "-print" nil "-pattern"))
  "*Programs and associated arguments for selecting fonts.
`x-select-font' will use the first program from this list that can be
found in the executable path.

The format of each entry is

 (PROGRAM STANDARD-ARGUMENTS INITIAL-SWITCH FILTER-SWITCH)

where PROGRAM is the name of the program, STANDARD-ARGUMENTS are any
arguments required to make the program behave as `x-select-font' or the user
expects, INITIAL-SWITCH is a switch to specify the font initially selected
in the dialog, and FILTER-SWITCH is a switch that can be supplied to limit
the fonts the user may choose from.

If PROGRAM does not support setting the initial font or filtering the list
of fonts, the corresponding switch should be set to nil.
If PROGRAM accepts a filter or an initial font on the command-line without
a preceding switch, then the corresponding switch should be set to t."
  :type '(alist
          :key-type (file :tag "Program")
          :value-type (group (string :tag "Fixed Args")
                             (choice :tag "Initial Font Switch"
                                     (const :tag "Unsupported" nil)
                                     (other :tag "No switch" t)
                                     string)
                             (choice :tag "Filter Switch"
                                     (const :tag "Unsupported" nil)
                                     (other :tag "No switch" t)
                                     string)))
  :group 'x)

(defvar x-select-font-command-cached nil
  "The command last used by `x-select-font' to select a font.
If nil, x-select-font will try to find a suitable program from
`x-select-font-commands'.")

(defun x-select-font (&optional initial filter)
  "Select a font using one of the programs in `x-select-font-commands'.
The font initially selected in the font dialog can optionally be set
with INITIAL if supported by `x-font-select-font-command'.  The range of
fonts to choose from can be limited by providing a FILTER, if supported.
The filter should be a partially qualified XLFD font name."
  (with-temp-buffer
    (let* ((command
            (or x-select-font-command-cached
                (let ((cmds x-select-font-commands)
                      this-cmd)
                  (while (and cmds (not x-select-font-command-cached))
                    (setq this-cmd (car (car cmds)))
                    (if (executable-find this-cmd)
                        (setq x-select-font-command-cached this-cmd))
                    (setq cmds (cdr cmds)))
                  x-select-font-command-cached)))
           (command-line
            (assoc command x-select-font-commands))
           (fixed-args (if command-line (nth 1 command-line)))
           (initial-switch (if command-line (nth 2 command-line)))
           (filter-switch (if command-line (nth 3 command-line)))
           (args (append (list fixed-args)
                         (if (and filter filter-switch)
                             (if (stringp filter-switch)
                                 (list filter-switch filter)
                               filter))
                         (if (and initial initial-switch)
                             (if (stringp initial-switch)
                                 (list initial-switch initial)
                               initial)))))
      (apply 'call-process command nil '(t nil) nil args)
      (buffer-string))))

(defcustom x-select-font-refine-menu-limit 20
  "*Limit on the size of the font refine menu.
When `x-select-font' is used to choose a font in a context that requires
a single font to match, there is a possibility that the pattern returned
from `x-select-font' matches multiple fonts.  This variable sets an upper
limit on the number of fonts that can be matched by the return value
of `x-select-font' before an error is thrown."
  :type 'integer
  :group 'x)

(defun x-select-font-refine-with-menu (fonts menu-pos)
  "Refine a list of fonts by popping up a menu."
  (let ((font-list fonts)
        font-refine-menu
        this-font)
    (while font-list
      (setq this-font (car font-list) font-list (cdr font-list))
      (setq font-refine-menu (cons (list this-font this-font)
                                   font-refine-menu)))
    (setq font-refine-menu (cons "Refine Font"
                                 (list (append '("Font List")
                                               font-refine-menu))))
    (x-popup-menu menu-pos font-refine-menu)))

(defun x-select-single-font (&optional initial filter)
  "Select a single font, using `x-select-font-command'.
If neccesary, pop up a menu to refine the choices further."
  (interactive)
  ;; Take note of the mouse position now while the frame is active.
  ;; Translate it to what x-popup-menu expects.
  (let* ((menu-pos (mouse-pixel-position))
         (menu-pos-window (car menu-pos))
         (menu-pos-x (car (cdr menu-pos)))
         (menu-pos-y (cdr (cdr menu-pos)))
         (menu-pos-expected-format (list
                                    (list (if menu-pos-x menu-pos-x
                                            0)
                                          (if menu-pos-y menu-pos-y
                                            0))
                                    menu-pos-window))
         (font-pattern (x-select-font initial filter))
         (font-list (or (x-list-fonts font-pattern)
                        (list font-pattern)))
                        
         (nfonts (length font-list)))
    (cond ((eq font-list nil)
           (error "No fonts match."))
          ((eq nfonts 1)
           (car font-list))
          ((< nfonts x-select-font-refine-menu-limit)
           (car (x-select-font-refine-with-menu
                 font-list menu-pos-expected-format)))
          (t
           (error "Too many fonts match.")))))


(defun x-select-font-for-face (face frame)
 "Select the font to be used for FACE on FRAME.
`x-select-font-command' will be used to make the selection."
 (let ((family (face-attribute face :family frame 'default))
       (width (face-attribute face :width frame 'default))
       (height (face-attribute face :height frame 'default))
       (weight (face-attribute face :weight frame 'default))
       (slant (face-attribute face :slant frame 'default))
       (font (face-attribute face :font frame nil))
       new-font new-attributes)
   (if (eq font 'unspecified)
       (setq font nil))
   (setq new-font
         (x-select-font
          (if font
              font
            (x-compose-font-name
             (list nil family weight slant nil nil
                   (if (integerp height) height nil)
                   (if (integerp height) nil (floor (* 10 height)))
                   nil nil nil width nil nil)))))
   ;; If face was specified by a :font attribute, replace it with the new one
   (if font
       (set-face-attribute face frame :font new-font)
     ;; Otherwise replace changed attributes individually.
     (setq new-attributes (x-decompose-font-name new-font))
     (if (not (equal (nth 2 new-attributes) family))
         (set-face-attribute face frame :family (nth 2 new-attributes)))
     (if (not (equal (nth 3 new-attributes) weight))
         (set-face-attribute face frame :weight (nth 3 new-attributes)))
     (if (not (equal (nth 4 new-attributes) slant))
         (set-face-attribute face frame :slant (nth 4 new-attributes)))
     ;; If height was in pixels before, keep it in pixels.
     (if (integerp height)
         (if (not (equal (nth 7 new-attributes) height))
             (set-face-attribute face frame :height
                                 (nth 7 new-attributes)))
       (let ((float-height (/ (nth 8 new-attributes) 10.0)))
         (if (not (equal float-height height))
             (set-face-attribute face frame :height float-height))))
     (if (not (equal (nth 12 new-attributes) width))
         (set-face-attribute face frame :width (nth 12 new-attributes))))))

;; Replacement mouse-set-font ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The following adds an extra submenu with a single option, which
;; launches the font dialog.  It would be nicer to do this with
;; an item on the main menu instead of a submenu, but that involves
;; more code changes.

(setq x-fixed-font-alist (append x-fixed-font-alist '(("More fonts" 
("Choose..." . x-select-single-font)))))

(defun mouse-set-font (&rest fonts)
  "Select an emacs font from a list of known good fonts and fontsets."
  (interactive
   (and (display-multi-font-p)
        (let ((selected-font (x-popup-menu
                              last-nonmenu-event
                              ;; Append list of fontsets currently defined.
                              (append x-fixed-font-alist
                                      (list (generate-fontset-menu))))))
          (if (functionp selected-font)
              (list (call-interactively selected-font))
            selected-font))))
  (message "%S" fonts)
  (if fonts
      (let (font)
        (while fonts
          (condition-case nil
              (progn
                (set-default-font (car fonts))
                (setq font (car fonts))
                (setq fonts nil))
            (error
             (setq fonts (cdr fonts)))))
        (if (null font)
            (error "Font not found")))
    (message "Cannot change fonts on this display")))


;; Selecting a font for a face ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun set-font-for-face-at-point ()
  "Set the font to use for the face currently under point."
  (interactive)
  (let ((face (get-text-property (point) 'face)))
    (x-select-font-for-face (if face face 'default) nil)))