New function 'truncate-string-pixelwise' (bug#80244)

This function will truncate a string on a pixelwise basis in a work buffer and using a binary search rather than brute force. * lisp/emacs-lisp/subr-x.el (work-buffer--prepare-pixelwise): New defun helper function. (string-pixel-width): Use the helper function. (truncate-string-pixelwise): New defun. * test/lisp/misc-tests.el (misc-test-truncate-string-pixelwise): (misc-test-truncate-string-pixelwise-unicode): New test. * doc/lispref/display.texi (Size of Displayed Text): Document the function. * etc/NEWS: Announce the function.
2026-01-23 17:45:09 -05:00 · 2026-01-23 17:45:09 -05:00 · a0748d9791
commit a0748d9791
parent e68239773c
4 changed files with 207 additions and 18 deletions
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@ -2243,6 +2243,9 @@ means hide the excess parts of @var{string} with a @code{display} text
 property (@pxref{Display Property}) showing the ellipsis, instead of
 actually truncating the string.

+See also the function @code{truncate-string-pixelwise} for pixel-level
+resolution.
+
@example
@group
 (truncate-string-to-width "\tab\t" 12 4)
@ -2440,6 +2443,37 @@ non-@code{nil}, use any face remappings (@pxref{Face Remapping}) from
 that buffer when computing the width of @var{string}.
@end defun

+@defun truncate-string-pixelwise string max-pixels &optional buffer ellipsis ellipsis-pixels
+This is a convenience function that uses @code{window-text-pixel-size}
+to truncate @var{string} to @var{max-pixels} pixels.  Caveat: if you
+call this function to measure the width of a string with embedded
+newlines, it will then return the width of the widest substring that
+does not include newlines.  The meaning of this result is the widest
+line taken by the string if inserted into a buffer.  If @var{buffer} is
+non-@code{nil}, use any face remappings (@pxref{Face Remapping}) from
+that buffer when computing the width of @var{string}.
+
+If @var{ellipsis} is non-@code{nil}, it should be a string which will
+replace the end of @var{string} when it is truncated.  In this case,
+more characters will be removed from @var{string} to free enough space
+for @var{ellipsis} to fit within @var{max-pixels} pixels.  However, if
+the pixel width of @var{string} is less than the pixel width of
+@var{ellipsis}, @var{ellipsis} will not be appended to the result.  If
+@var{ellipsis} is non-@code{nil} and not a string, it stands for the
+value returned by the function @code{truncate-string-ellipsis},
+described above.
+
+If @var{ellipsis-pixels} is non-@code{nil} and @var{ellipsis} is
+non-@code{nil}, it should be the number of pixels of @var{ellipsis} that
+you should precompute using @code{string-pixel-width}, specifying the
+same buffer.  This is useful to avoid the cost of recomputing this value
+repeatedly when you have many strings to truncate using the same
+ellipsis string.
+
+See also the function @code{truncate-string-to-width} for
+character-level resolution.
+@end defun
+
@defun line-pixel-height
 This function returns the height in pixels of the line at point in the
 selected window.  The value includes the line spacing of the line
--- a/etc/NEWS
+++ b/etc/NEWS
@ -3847,6 +3847,14 @@ It has been obsolete since Emacs 26.1.  Use the group 'text' instead.
 If supplied, 'string-pixel-width' will use any face remappings from
 BUFFER when computing the string's width.

+++
+** New function 'truncate-string-pixelwise'.
+This function truncates a string to the specified maximum number of
+pixels rather than by characters, as in 'truncate-string-to-width', and
+respects face remappings if BUFFER is specified.  You can also specify
+an optional ellipsis string to append, similar to
+'truncate-string-to-width'.
+
 ---
 ** New macro 'with-work-buffer'.
 This macro is similar to the already existing macro 'with-temp-buffer',
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@ -37,6 +37,7 @@

 (eval-when-compile (require 'cl-lib))

+(require 'mule-util)

 (defmacro internal--thread-argument (first? &rest forms)
  "Internal implementation for `thread-first' and `thread-last'.
@ -357,6 +358,29 @@ buffer when possible, instead of creating a new one on each call."
             (progn ,@body)
           (work-buffer--release ,work-buffer))))))

+(defun work-buffer--prepare-pixelwise (string buffer)
+  "Set up the current buffer to correctly compute STRING's pixel width.
+Call this with a work buffer as the current buffer.
+BUFFER is the originating buffer and if non-nil, make the current
+buffer's (work buffer) face remappings match it."
+  (when buffer
+    (dolist (v '(face-remapping-alist
+                 char-property-alias-alist
+                 default-text-properties))
+      (if (local-variable-p v buffer)
+          (set (make-local-variable v)
+               (buffer-local-value v buffer)))))
+  ;; Avoid deactivating the region as side effect.
+  (let (deactivate-mark)
+    (insert string))
+  ;; If `display-line-numbers' is enabled in internal
+  ;; buffers (e.g. globally), it breaks width calculation
+  ;; (bug#59311).  Disable `line-prefix' and `wrap-prefix',
+  ;; for the same reason.
+  (add-text-properties
+   (point-min) (point-max)
+   '(display-line-numbers-disable t line-prefix "" wrap-prefix "")))
+
 ;;;###autoload
 (defun string-pixel-width (string &optional buffer)
  "Return the width of STRING in pixels.
@ -371,26 +395,69 @@ substring that does not include newlines."
    ;; Keeping a work buffer around is more efficient than creating a
    ;; new temporary buffer.
    (with-work-buffer
-      ;; Setup current buffer to correctly compute pixel width.
-      (when buffer
-        (dolist (v '(face-remapping-alist
-                     char-property-alias-alist
-                     default-text-properties))
-          (if (local-variable-p v buffer)
-              (set (make-local-variable v)
-                   (buffer-local-value v buffer)))))
-      ;; Avoid deactivating the region as side effect.
-      (let (deactivate-mark)
-        (insert string))
-      ;; If `display-line-numbers' is enabled in internal
-      ;; buffers (e.g. globally), it breaks width calculation
-      ;; (bug#59311).  Disable `line-prefix' and `wrap-prefix',
-      ;; for the same reason.
-      (add-text-properties
-       (point-min) (point-max)
-       '(display-line-numbers-disable t line-prefix "" wrap-prefix ""))
+     (work-buffer--prepare-pixelwise string buffer)
      (car (buffer-text-pixel-size nil nil t)))))

+;;;###autoload
+(defun truncate-string-pixelwise (string max-pixels &optional buffer
+                                  ellipsis ellipsis-pixels)
+  "Return STRING truncated to fit within MAX-PIXELS.
+If BUFFER is non-nil, use the face remappings, alternative and default
+properties from that buffer when determining the width.
+If you call this function to measure pixel width of a string
+with embedded newlines, it returns the width of the widest
+substring that does not include newlines.
+
+If ELLIPSIS is non-nil, it should be a string which will replace the end
+of STRING if it extends beyond MAX-PIXELS, unless the pixel width of
+STRING is equal to or less than the pixel width of ELLIPSIS.  If it is
+non-nil and not a string, then ELLIPSIS defaults to
+`truncate-string-ellipsis', or to three dots when it's nil.
+
+If ELLIPSIS-PIXELS is non-nil, it is the pixel width of ELLIPSIS, and
+can be used to avoid the cost of recomputing this for multiple calls to
+this function using the same ELLIPSIS."
+  (declare (important-return-value t))
+  (if (zerop (length string))
+      0
+    ;; Keeping a work buffer around is more efficient than creating a
+    ;; new temporary buffer.
+    (with-work-buffer
+      (work-buffer--prepare-pixelwise string buffer)
+      (set-window-buffer nil (current-buffer) 'keep-margins)
+      ;; Use a binary search to prune the number of calls to
+      ;; `window-text-pixel-size'.
+      ;; These are 1-based buffer indexes.
+      (let* ((low 1)
+             (high (1+ (length string)))
+             mid)
+        (when (> (car (window-text-pixel-size nil 1 high)) max-pixels)
+          (when (and ellipsis (not (stringp ellipsis)))
+            (setq ellipsis (truncate-string-ellipsis)))
+          (setq ellipsis-pixels (if ellipsis
+                                    (if ellipsis-pixels
+                                        ellipsis-pixels
+                                      (string-pixel-width ellipsis buffer))
+                                  0))
+          (let ((adjusted-pixels
+                 (if (> max-pixels ellipsis-pixels)
+                     (- max-pixels ellipsis-pixels)
+                   max-pixels)))
+            (while (<= low high)
+              (setq mid (floor (+ low high) 2))
+              (if (<= (car (window-text-pixel-size nil 1 mid))
+                      adjusted-pixels)
+                  (setq low (1+ mid))
+                (setq high (1- mid))))))
+        (set-window-buffer nil buffer 'keep-margins)
+        (if mid
+            ;; Binary search ran.
+            (if (and ellipsis (> max-pixels ellipsis-pixels))
+                (concat (substring string 0 (1- high)) ellipsis)
+              (substring string 0 (1- high)))
+          ;; Fast path.
+          string)))))
+
 ;;;###autoload
 (defun string-glyph-split (string)
  "Split STRING into a list of strings representing separate glyphs.
--- a/test/lisp/misc-tests.el
+++ b/test/lisp/misc-tests.el
@ -25,6 +25,7 @@

 (require 'ert)
 (require 'misc)
+(require 'mule-util)

 (defmacro with-misc-test (original result &rest body)
  (declare (indent 2))
@ -243,5 +244,84 @@
      (setq-default display-line-numbers dln))
    (should (= w0 w1))))

+;; Exercise `truncate-string-pixelwise' with strings of the same
+;; characters of differing widths, with and without ellipses, in varying
+;; faces, and varying face heights and compare results to each
+;; character's measured width.
+(ert-deftest misc-test-truncate-string-pixelwise ()
+  (dolist (c '(?W ?X ?y ?1))
+    (dolist (ellipsis `(nil "..." ,(truncate-string-ellipsis)))
+      (dolist (face '(fixed-pitch variable-pitch))
+        (dolist (height '(1.0 0.5 1.5))
+          (with-temp-buffer
+            (setq-local face-remapping-alist `((,face . default)))
+            (face-remap-add-relative 'default :height height)
+            (let ((char-pixels (string-pixel-width
+                                (make-string 1 c) (current-buffer))))
+              (dotimes (i 20)
+                (setq i (1+ i))
+                (should (eq i (length
+                               (truncate-string-pixelwise
+                                (make-string (* i 2) c)
+                                (* i char-pixels)
+                                (current-buffer)
+                                ellipsis))))))))))))
+
+;; Exercise `truncate-string-pixelwise' with varying unicode strings, in
+;; varying faces, and varying face heights and compare results to a
+;; naive `string-pixel-width' based string truncate function.
+(ert-deftest misc-test-truncate-string-pixelwise-unicode ()
+  :tags '(:expensive-test)
+  (skip-when noninteractive)
+  (let ((max-pixels 500)
+        (truncate-string-naive (lambda (string pixels buffer)
+                                 (while (and (length> string 0)
+                                             (> (string-pixel-width string buffer) pixels))
+                                   (setq string (substring string 0 (1- (length string)))))
+                                 string))
+        (strings (list
+                  "foo bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar baz"
+                  (concat "話說天下大勢，分久必合，合久必分：周末七國分爭，并入於秦。"
+                          "及秦滅之後，楚、漢分爭，又并入於漢。漢朝自高祖斬白蛇而起義，"
+                          "一統天下。後來光武中興，傳至獻帝，遂分為三國。推其致亂之由，"
+                          "殆始於桓、靈二帝。桓帝禁錮善類，崇信宦官。及桓帝崩，靈帝即位，"
+                          "大將軍竇武、太傅陳蕃，共相輔佐。時有宦官曹節等弄權，竇武、陳蕃謀誅之，"
+                          "作事不密，反為所害。中涓自此愈橫")
+                  (concat "короче теперь если по русски написать все четко или все равно"
+                          " короче теперь если по русски написать все четко или все равно"
+                          " короче теперь если по русски написать все четко или все равно"
+                          " короче теперь если по русски написать все четко или все равно")
+                  "будет разрыв строки непонятно где🏁🚩🎌🏴🏳️ 🏳️ <200d>🌈🏳️ <200d>⚧️🏴<200d>☠️"
+                  (apply #'concat (make-list 200 "\u0065\u0301 ")) ; composed é \u00E9
+                  (let ((woman-loves-man ; 👩‍❤️‍👨
+                         (concat "\N{WOMAN}"
+                                 "\N{ZERO WIDTH JOINER}"
+                                 "\N{HEAVY BLACK HEART}"
+                                 "\N{VARIATION SELECTOR-16}"
+                                 "\N{ZERO WIDTH JOINER}"
+                                 "\N{MAN}"
+                                 " ")))
+                    (apply #'concat (make-list 200 woman-loves-man)))
+                  (propertize (let ((varying-height-string
+                                     (mapconcat
+                                      #'identity
+                                      (list "AWi!"
+                                            (propertize "foo" 'face '(:height 2.5))
+                                            (propertize "bar" 'face '(:height 0.5))
+                                            (propertize "baz" 'face '(:height 1.0)))
+                                      " ")))
+                                (apply #'concat (make-list 100 varying-height-string)))
+                              'face 'variable-pitch))))
+    (dolist (face '(fixed-pitch variable-pitch))
+      (dolist (height '(1.0 0.5 1.5))
+        (with-temp-buffer
+          (setq-local face-remapping-alist `((,face . default)))
+          (face-remap-add-relative 'default :height height)
+          (dolist (string strings)
+            (should (eq (length (funcall truncate-string-naive
+                                         string max-pixels (current-buffer)))
+                        (length (truncate-string-pixelwise
+                                 string max-pixels (current-buffer)))))))))))
+
 (provide 'misc-tests)
 ;;; misc-tests.el ends here