(face-extend-p face nil t)
(face-background face nil t)))))
+(defvar visual-wrap--safe-display-specs
+ '(height raise)
+ "A list of display specs that don't interfere with wrap prefixes.
+A \"safe\" display spec is one that won't interfere with the additional
+text properties that `visual-wrap-prefix-mode' uses.
+
+Specs that replace the text are unsafe, since they generally determine
+the range of text to replace via `eq'. If `visual-wrap-prefix-mode'
+were to add text properties to some subset of this range, it would
+violate this assumption.")
+
+(defun visual-wrap--display-property-safe-p (display)
+ "Return non-nil if the display property DISPLAY is \"safe\".
+A \"safe\" display property is one where all the display specs are
+members of `visual-wrap--safe-display-specs' (which see)."
+ ;; The display property could be a single display spec; if so, wrap it
+ ;; in a list so we can iterate over it in our loop below.
+ (when (and (consp display) (not (consp (car display))))
+ (setq display (list display)))
+ ;; Loop over all the display specs to check if they're safe. Assume
+ ;; any display property other than a vector or list (e.g. a string) is
+ ;; unsafe.
+ (when (or (vectorp display) (listp display))
+ (not (catch 'unsafe
+ (mapc (lambda (spec)
+ (unless (memq (car-safe spec)
+ visual-wrap--safe-display-specs)
+ (throw 'unsafe t)))
+ display)))))
+
(defun visual-wrap--prefix-face (fcp _beg end)
;; If the fill-context-prefix already specifies a face, just use that.
(cond ((get-text-property 0 'face fcp))
;; the buffer.)
(add-display-text-property
position (min (+ position (length first-line-prefix))
- (line-end-position))
+ (pos-eol))
'min-width `((,next-line-prefix . width))))
(setq next-line-prefix (visual-wrap--adjust-prefix next-line-prefix))
(put-text-property
- position (line-end-position) 'wrap-prefix
+ position (pos-eol) 'wrap-prefix
(if (numberp next-line-prefix)
`(space :align-to (,next-line-prefix . width))
next-line-prefix)))))
(forward-line 0)
(setq beg (point))
(while (< (point) end)
- (visual-wrap--apply-to-line (point))
- (forward-line))
+ ;; Check if the display property at the end of this line is "safe".
+ (if (visual-wrap--display-property-safe-p
+ (get-char-property (pos-eol) 'display))
+ ;; If so, we can apply our visual wrapping properties to this
+ ;; line and continue to the next line.
+ (progn
+ (visual-wrap--apply-to-line (point))
+ (forward-line))
+ ;; Otherwise, skip ahead until the end of any unsafe display
+ ;; properties. NOTE: We do this out of an abundance of caution to
+ ;; be as certain as possible that we're not interfering with the
+ ;; display engine. If this results in cases where we fail to add
+ ;; wrapping properties when we should, then we should remove the
+ ;; `while' loop below. Without that loop, this should be the same
+ ;; logic `handle_single_display_spec' in xdisp.c uses for
+ ;; determining what text to replace. See bug#73600.
+ (goto-char (next-single-char-property-change (pos-eol) 'display))
+ (while (not (visual-wrap--display-property-safe-p
+ (get-char-property (point) 'display)))
+ (goto-char (next-single-char-property-change (point) 'display)))
+ (unless (bolp) (forward-line 1))))
`(jit-lock-bounds ,beg . ,end))
;;;###autoload
--- /dev/null
+;;; visual-wrap-tests.el --- Tests for `visual-wrap-prefix-mode' -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tets for `visual-wrap-prefix-mode'.
+
+;;; Code:
+
+(require 'visual-wrap)
+(require 'ert)
+
+;;; Tests:
+
+(ert-deftest visual-wrap-tests/simple ()
+ "Test adding wrapping properties to text without display properties."
+ (with-temp-buffer
+ (insert "greetings\n* hello\n* hi")
+ (visual-wrap-prefix-function (point-min) (point-max))
+ (should (equal-including-properties
+ (buffer-string)
+ #("greetings\n* hello\n* hi"
+ 10 12 ( wrap-prefix (space :align-to (2 . width))
+ display (min-width ((2 . width))))
+ 12 17 ( wrap-prefix (space :align-to (2 . width)))
+ 18 20 ( wrap-prefix (space :align-to (2 . width))
+ display (min-width ((2 . width))))
+ 20 22 ( wrap-prefix (space :align-to (2 . width))))))))
+
+(ert-deftest visual-wrap-tests/safe-display ()
+ "Test adding wrapping properties to text with safe display properties."
+ (with-temp-buffer
+ (insert #("* hello" 2 7 (display (raise 1))))
+ (visual-wrap-prefix-function (point-min) (point-max))
+ (should (equal-including-properties
+ (buffer-string)
+ #("* hello"
+ 0 2 ( wrap-prefix (space :align-to (2 . width))
+ display (min-width ((2 . width))))
+ 2 7 ( wrap-prefix (space :align-to (2 . width))
+ display (raise 1)))))))
+
+(ert-deftest visual-wrap-tests/unsafe-display/within-line ()
+ "Test adding wrapping properties to text with unsafe display properties.
+When these properties don't extend across multiple lines,
+`visual-wrap-prefix-mode' can still add wrapping properties."
+ (with-temp-buffer
+ (insert #("* [img]" 2 7 (display (image :type bmp))))
+ (visual-wrap-prefix-function (point-min) (point-max))
+ (should (equal-including-properties
+ (buffer-string)
+ #("* [img]"
+ 0 2 ( wrap-prefix (space :align-to (2 . width))
+ display (min-width ((2 . width))))
+ 2 7 ( wrap-prefix (space :align-to (2 . width))
+ display (image :type bmp)))))))
+
+(ert-deftest visual-wrap-tests/unsafe-display/spanning-lines ()
+ "Test adding wrapping properties to text with unsafe display properties.
+When these properties do extend across multiple lines,
+`visual-wrap-prefix-mode' must avoid adding wrapping properties."
+ (with-temp-buffer
+ (insert #("* a\n* b" 0 7 (display (image :type bmp))))
+ (visual-wrap-prefix-function (point-min) (point-max))
+ (should (equal-including-properties
+ (buffer-string)
+ #("* a\n* b" 0 7 (display (image :type bmp)))))))
+
+(ert-deftest visual-wrap-tests/unsafe-display/multiple-1 ()
+ "Test adding wrapping properties to text with unsafe display properties.
+This tests a multi-line unsafe display prop immediately followed by a
+single-line unsafe display prop. `visual-wrap-prefix-mode' should *not*
+add wrapping properties to either block."
+ (with-temp-buffer
+ (insert #("* a\n* b"
+ 0 4 (display ((image :type bmp)))
+ 4 7 (display ((image :type bmp) (height 1.5)))))
+ (visual-wrap-prefix-function (point-min) (point-max))
+ (should (equal-including-properties
+ (buffer-string)
+ ;; NOTE: See the note in `visual-wrap-prefix-function'. If
+ ;; applying the change mentioned there, then this case
+ ;; should add wrapping properties to the second block.
+ #("* a\n* b"
+ 0 4 (display ((image :type bmp)))
+ 4 7 (display ((image :type bmp) (height 1.5))))))))
+
+(ert-deftest visual-wrap-tests/unsafe-display/multiple-2 ()
+ "Test adding wrapping properties to text with unsafe display properties.
+This tests a multi-line unsafe display prop immediately followed by
+another multi-line unsafe display prop. `visual-wrap-prefix-mode'
+should *not* add wrapping properties to either block."
+ (with-temp-buffer
+ (insert #("* a\n* b\n"
+ 0 4 (display ((image :type bmp)))
+ 4 8 (display ((image :type bmp) (height 1.5)))))
+ (visual-wrap-prefix-function (point-min) (point-max))
+ (should (equal-including-properties
+ (buffer-string)
+ #("* a\n* b\n"
+ 0 4 (display ((image :type bmp)))
+ 4 8 (display ((image :type bmp) (height 1.5))))))))
+
+;; visual-wrap-tests.el ends here
projects / emacs.git / commitdiff