diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 4211b435db5..464c0badc36 100644 --- 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 diff --git a/etc/NEWS b/etc/NEWS index be507f525ba..2cf91cfd5f7 100644 --- 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', diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 8d04958487f..db854863b32 100644 --- 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. diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el index b6f5f01ad2a..5d0b9ae0604 100644 --- 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 é \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