Improve selection of fonts available from `mouse-set-font'

People get confused on a build without font dialogs (such as a
Lucid build) if `menu-set-font' and `mouse-set-font' don't
present them a list of the fonts actually available on their
system.

* lisp/mouse.el (mouse-generate-font-name-for-menu)
(mouse-generate-font-menu): New functions.
(mouse-select-font): Allow the user to select from all fonts
available on the system.
(mouse-set-font): Use `mouse-select-font' to display font menu.

1 files changed, 62 insertions, 13 deletions

diff --git a/lisp/mouse.el b/lisp/mouse.el
index 502683d3d1e..acaf6611af5 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -2755,18 +2755,72 @@ and selects that window."
 
 (declare-function generate-fontset-menu "fontset" ())
 
+(defun mouse-generate-font-name-for-menu (entity)
+  "Return a short name for font entity ENTITY.
+The name should be used to describe ENTITY in the case that its
+family is already known, such as in a pane generated by
+`mouse-generate-font-menu'."
+  (let ((weight (font-get entity :weight))
+        (slant (font-get entity :slant))
+        (width (font-get entity :width))
+        (size (font-get entity :size))
+        (adstyle (font-get entity :adstyle))
+        (name ""))
+    (when weight
+      (setq name (concat name (symbol-name weight) " ")))
+    (when (and slant
+               (not (eq slant 'normal)))
+      (setq name (concat name (symbol-name slant) " ")))
+    (when (and width (not (eq width 'normal)))
+      (setq name (concat name (symbol-name width) " ")))
+    (when (and size (not (zerop size)))
+      (setq name (concat name (number-to-string size) " ")))
+    (when adstyle
+      (setq name (concat name (if (symbolp adstyle)
+                                  (symbol-name adstyle)
+                                (number-to-string adstyle))
+                         " ")))
+    (string-trim-right name)))
+
+(defun mouse-generate-font-menu ()
+  "Return a list of menu panes for each font family."
+  (let ((families (font-family-list))
+        (panes (list "Font families")))
+    (dolist (family families)
+      (when family
+        (let* ((fonts (list-fonts (font-spec :family family)))
+               (pane (if fonts (list family)
+                       (list family (cons family family)))))
+          (when fonts
+            (dolist (font fonts)
+              (setq pane
+                    (nconc pane
+                           (list (list (or (font-get font :name)
+                                           (mouse-generate-font-name-for-menu font))
+                                       (font-xlfd-name font)))))))
+          (setq panes (nconc panes (list pane))))))
+    panes))
+
 (defun mouse-select-font ()
   "Prompt for a font name, using `x-popup-menu', and return it."
   (interactive)
   (unless (display-multi-font-p)
     (error "Cannot change fonts on this display"))
-  (car
-   (x-popup-menu
-    (if (listp last-nonmenu-event)
-	last-nonmenu-event
-      (list '(0 0) (selected-window)))
-    (append x-fixed-font-alist
-	    (list (generate-fontset-menu))))))
+  (let ((result (car
+                 (x-popup-menu
+                  (if (listp last-nonmenu-event)
+	              last-nonmenu-event
+                    (list '(0 0) (selected-window)))
+                  (append x-fixed-font-alist
+	                  (list (generate-fontset-menu))
+                          '(("More Fonts" ("By Family" more))))))))
+    (if (eq result 'more)
+        (car (x-popup-menu
+              (if (listp last-nonmenu-event)
+	          last-nonmenu-event
+                (list '(0 0) (selected-window)))
+              (mouse-generate-font-menu)))
+      result)))
 
 (declare-function text-scale-mode "face-remap")
 
@@ -2780,12 +2834,7 @@ choose a font."
   (interactive
    (progn (unless (display-multi-font-p)
 	    (error "Cannot change fonts on this display"))
-	  (x-popup-menu
-	   (if (listp last-nonmenu-event)
-	       last-nonmenu-event
-	     (list '(0 0) (selected-window)))
-	   ;; Append list of fontsets currently defined.
-	   (append x-fixed-font-alist (list (generate-fontset-menu))))))
+	  (list (mouse-select-font))))
   (if fonts
       (let (font)
 	(while fonts