Sync up with r21_2_14.

[chise/xemacs-chise.git] / lisp / x-font-menu.el

diff --git a/lisp/x-font-menu.el b/lisp/x-font-menu.el
index 3e902e1..d96fe11 100644 (file)
--- a/lisp/x-font-menu.el
+++ b/lisp/x-font-menu.el
@@ -130,18 +130,45 @@
 ;;; (defvar font-menu-ignore-proportional-fonts nil
 ;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")
 
 ;;; (defvar font-menu-ignore-proportional-fonts nil
 ;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")
 

+(defgroup font-menu ()
+  "Settings for the font menu"
+  :group 'x)
+

 ;;;###autoload
 (defcustom font-menu-ignore-scaled-fonts t
   "*If non-nil, then the font menu will try to show only bitmap fonts."
   :type 'boolean
 ;;;###autoload
 (defcustom font-menu-ignore-scaled-fonts t
   "*If non-nil, then the font menu will try to show only bitmap fonts."
   :type 'boolean

-  :group 'x)
+  :group 'font-menu)

 
 ;;;###autoload
 (defcustom font-menu-this-frame-only-p nil
   "*If non-nil, then changing the default font from the font menu will only
 affect one frame instead of all frames."
   :type 'boolean
 
 ;;;###autoload
 (defcustom font-menu-this-frame-only-p nil
   "*If non-nil, then changing the default font from the font menu will only
 affect one frame instead of all frames."
   :type 'boolean

-  :group 'x)
+  :group 'font-menu)
+
+(defcustom font-menu-max-items 25
+  "*Maximum number of items in the font menu
+If number of entries in a menu is larger than this value, split menu
+into submenus of nearly equal length.  If nil, never split menu into
+submenus."
+  :group 'font-menu
+  :type '(choice (const :tag "no submenus" nil)
+                (integer)))
+
+(defcustom font-menu-submenu-name-format "%-12.12s ... %.12s"
+  "*Format specification of the submenu name.
+Used by `font-menu-split-long-menu' if the number of entries in a menu is
+larger than `font-menu-menu-max-items'.
+This string should contain one %s for the name of the first entry and
+one %s for the name of the last entry in the submenu.
+If the value is a function, it should return the submenu name.  The
+function is be called with two arguments, the names of the first and
+the last entry in the menu."
+  :group 'font-menu
+  :type '(choice (string :tag "Format string")
+                (function)))
+

 
 ;; only call XListFonts (and parse) once per device.
 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
 
 ;; only call XListFonts (and parse) once per device.
 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)

@@ -358,6 +385,40 @@ or if you change your font path, you can call this to re-initialize the menus."
       
     (vector entry family size weight slant)))
 
       
     (vector entry family size weight slant)))
 

+(defun font-menu-split-long-menu (menu)
+  "Split MENU according to `font-menu-max-items'."
+  (let ((len (length menu)))
+    (if (or (null font-menu-max-items)
+           (null (featurep 'lisp-float-type))
+           (<= len font-menu-max-items))
+       menu
+      ;; Submenu is max 2 entries longer than menu, never shorter, number of
+      ;; entries in submenus differ by at most one (with longer submenus first)
+      (let* ((outer (floor (sqrt len)))
+            (inner (/ len outer))
+            (rest (% len outer))
+            (result nil))
+       (setq menu (reverse menu))
+       (while menu
+         (let ((in inner)
+               (sub nil)
+               (to (car menu)))
+           (while (> in 0)
+             (setq in   (1- in)
+                   sub  (cons (car menu) sub)
+                   menu (cdr menu)))
+           (setq result
+                 (cons (cons (if (stringp font-menu-submenu-name-format)
+                                 (format font-menu-submenu-name-format
+                                         (aref (car sub) 0) (aref to 0))
+                               (funcall font-menu-submenu-name-format
+                                        (aref (car sub) 0) (aref to 0)))
+                             sub)
+                       result)
+                 rest  (1+ rest))
+           (if (= rest outer) (setq inner (1+ inner)))))
+       result))))
+

 ;;;###autoload
 (defun font-menu-family-constructor (ignored)
   (catch 'menu
 ;;;###autoload
 (defun font-menu-family-constructor (ignored)
   (catch 'menu

@@ -376,21 +437,28 @@ or if you change your font path, you can call this to re-initialize the menus."
       ;; the same size and weight as the current font (scalable fonts
       ;; exist in every size).  Only the current font is marked as
       ;; selected.
       ;; 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)))))
+      (font-menu-split-long-menu
+       (mapcar
+       (lambda (item)
+         (setq f (aref item 0)
+               entry (vassoc f (aref dcache 0)))
+         ;; The user can no longer easily control the weight using the menu
+         ;; Note it is silly anyway as it could very well be that the font
+         ;; has no common size+weight combinations with the default font.
+;;       (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 (and font-menu-ignore-scaled-fonts (member 0 (aref entry 2)))
+             (disable-menu-item item)
+           (enable-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)
 
 ;;;###autoload
 (defun font-menu-size-constructor (ignored)

@@ -472,12 +540,12 @@ or if you change your font path, you can call this to re-initialize the menus."
       (signal 'error '("couldn't parse font name for default face")))
     (when weight
       (signal 'error '("Setting weight currently not supported")))
       (signal 'error '("couldn't parse font name for default face")))
     (when weight
       (signal 'error '("Setting weight currently not supported")))

-;    (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))
+    (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)
     (dolist (face (delq 'default (face-list)))
       (when (face-font-instance face)
        (message "Changing font of `%s'..." face)

@@ -490,17 +558,20 @@ or if you change your font path, you can call this to re-initialize the menus."
           (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.
           (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.

-    
-    (when (and family (not (equal family from-family)))
-      (setq new-props (append (list :family family) new-props)))
-    (when (and size (not (equal size from-size)))
-      (setq new-props (append (list :size (concat (int-to-string
-                                         (/ size 10)) "pt")) new-props)))
-    (custom-set-face-update-spec 'default '((type x)) new-props)
-    ;;; 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))))
+
+    ;; If we need to be frame local we do the changes ourselves.
+    (if font-menu-this-frame-only-p
+    ;;; 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)))
+      ;; OK Let Customize do it.
+      (when (and family (not (equal family from-family)))
+       (setq new-props (append (list :family family) new-props)))
+      (when (and size (not (equal size from-size)))
+       (setq new-props (append
+          (list :size (concat (int-to-string (/ size 10)) "pt")) new-props)))
+      (custom-set-face-update-spec 'default '((type x)) new-props)
+      (message "Font %s" (face-font-name 'default)))))

 
 
 (defun font-menu-change-face (face
 
 
 (defun font-menu-change-face (face