procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix `string-pixel-width' with alternate text properties

Browse source 
Fix possible wrong result of `string-pixel-width' with alternate
and default properties.  Create new regression tests.
* lisp/emacs-lisp/subr-x.el (string-pixel-width): Like for
`face-remapping-alist', use in work buffer the value of
`char-property-alias-alist' and `default-text-properties'
local to the passed buffer, to correctly compute pixel width.
(Bug#77042)

* test/lisp/misc-tests.el: Add tests for `string-pixel-width'.
This commit is contained in:
David Ponce 2025-03-16 11:31:21 +01:00 • committed by Eli Zaretskii
parent cace07f27d
commit b1db48c0fc
2 changed files with 76 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
lisp/emacs-lisp/subr-x.el
View file

@ -389,8 +389,8 @@ buffer when possible, instead of creating a new one on each call."
;;;###autoload
(defun string-pixel-width (string &optional buffer)
"Return the width of STRING in pixels.
If BUFFER is non-nil, use the face remappings from that buffer when
determining the width.
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."
@ -400,11 +400,14 @@ substring that does not include newlines."
;; Keeping a work buffer around is more efficient than creating a
;; new temporary buffer.
(with-work-buffer
(if buffer
(setq-local face-remapping-alist
(with-current-buffer buffer
face-remapping-alist))
(kill-local-variable 'face-remapping-alist))
;; 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))
@ -413,12 +416,8 @@ substring that does not include newlines."
;; (bug#59311). Disable `line-prefix' and `wrap-prefix',
;; for the same reason.
(add-text-properties
(point-min) (point-max) '(display-line-numbers-disable t))
;; Prefer `remove-text-properties' to `propertize' to avoid
;; creating a new string on each call.
(remove-text-properties
(point-min) (point-max) '(line-prefix nil wrap-prefix nil))
(setq line-prefix nil wrap-prefix nil)
(point-min) (point-max)
'(display-line-numbers-disable t line-prefix "" wrap-prefix ""))
(car (buffer-text-pixel-size nil nil t)))))
;;;###autoload

64
test/lisp/misc-tests.el
View file

@ -178,6 +178,70 @@
(should (equal (point) (+ 14 vdelta hdelta)))
(should (equal (mark) (+ 2 hdelta)))))))))
;; Check that `string-pixel-width' returns a consistent result in the
;; various situations that can lead to erroneous results.
(ert-deftest misc-test-string-pixel-width-char-property-alias-alist ()
"Test `string-pixel-width' with `char-property-alias-alist'."
(with-temp-buffer
(let ((text0 (propertize "This text"
'display "xxxx"
'face 'variable-pitch))
(text1 (propertize "This text"
'my-display "xxxx"
'my-face 'variable-pitch)))
(setq-local char-property-alias-alist '((display my-display)
(face my-face)))
(should (= (string-pixel-width text0 (current-buffer))
(string-pixel-width text1 (current-buffer)))))))
;; This test never fails in batch mode.
(ert-deftest misc-test-string-pixel-width-face-remapping-alist ()
"Test `string-pixel-width' with `face-remapping-alist'."
(with-temp-buffer
(setq-local face-remapping-alist '((variable-pitch . default)))
(let ((text0 (propertize "This text" 'face 'default))
(text1 (propertize "This text" 'face 'variable-pitch)))
(should (= (string-pixel-width text0 (current-buffer))
(string-pixel-width text1 (current-buffer)))))))
(ert-deftest misc-test-string-pixel-width-default-text-properties ()
"Test `string-pixel-width' with `default-text-properties'."
(with-temp-buffer
(setq-local default-text-properties '(display "XXXX"))
(let ((text0 (propertize "This text" 'display "XXXX"))
(text1 "This text"))
(should (= (string-pixel-width text0 (current-buffer))
(string-pixel-width text1 (current-buffer)))))))
(ert-deftest misc-test-string-pixel-width-line-and-wrap-prefix ()
"Test `string-pixel-width' with `line-prefix' and `wrap-prefix'."
(let ((lp (default-value 'line-prefix))
(wp (default-value 'line-prefix))
(text (make-string 2000 ?X))
w0 w1)
(unwind-protect
(progn
(setq-default line-prefix nil wrap-prefix nil)
(setq w0 (string-pixel-width text))
(setq-default line-prefix "PPPP" wrap-prefix "WWWW")
(setq w1 (string-pixel-width text)))
(setq-default line-prefix lp wrap-prefix wp))
(should (= w0 w1))))
;; This test never fails in batch mode.
(ert-deftest misc-test-string-pixel-width-display-line-numbers ()
"Test `string-pixel-width' with `display-line-numbers'."
(let ((dln (default-value 'display-line-numbers))
(text "This text")
w0 w1)
(unwind-protect
(progn
(setq-default display-line-numbers nil)
(setq w0 (string-pixel-width text))
(setq-default display-line-numbers t)
(setq w1 (string-pixel-width text)))
(setq-default display-line-numbers dln))
(should (= w0 w1))))
(provide 'misc-tests)
;;; misc-tests.el ends here