Re: address@hidden: some other observations on pcomplete]

[Jason Rumney]

Richard Stallman <address@hidden> writes:

> * Provide user-friendly ways to list all available font families,
>   display a font as a sample, etc.

I have still not got my head around the face customization code to
try to slot this in there.  But I have got this working for
mouse-set-font.  The code follows for people to try out, suggestions
are welcome.

-- 
Jason Rumney


;;; Experimental font selection with a dialog.

(defcustom x-select-font-command-line-alist
  '(("gfontsel" "--print" "-f" nil)
    ("xfontsel" "-print" nil "-pattern"))
  "*Programs and associated arguments suitable for `x-select-font-command'.
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)

(defcustom x-select-font-command (if (executable-find "gfontsel")
                                     "gfontsel"
                                   "xfontsel")
  "*The command used by `x-select-font' to select a font.
The command should be one of those listed in
`x-select-font-command-line-alist'."
  :type `(choice
          ,@(mapcar (lambda (entry)
                      (list 'const :format "%v\n" (car entry)))
                    x-select-font-command-line-alist)
          (string :tag "other"))
  :group 'x)

(defun x-select-font (&optional initial filter)
  "Select a font using `x-select-font-command'.
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-line
            (assoc x-select-font-command x-select-font-command-line-alist))
           (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 x-select-font-command nil t 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-list (x-list-fonts (x-select-font initial filter)))
         (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.")))))


;; 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))))
  (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")))


;; Customize Faces ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Customize options that are relevant.
;; :family :width :height :weight :slant
;;
;; Ideas so far.
;; Can use x-compose-font-name, x-decompose-font-name
;; How to get current values of widgets?
;; How to change widget values?