From 33ddaae3aacd5b5eb1c823f3461019b53ca02c2e Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Thu, 3 Oct 2024 17:24:18 -0700 Subject: [PATCH] Don't add visual-wrap-prefix properties to unsafe multi-line display specs This makes sure we don't interfere with other display specs, e.g. for images displayed in 'image-mode' (bug#73600). * lisp/visual-wrap.el (visual-wrap--safe-display-specs): New variable. (visual-wrap--display-property-safe-p): New function. (visual-wrap--apply-to-line): Use 'pos-eol'; we don't want to respect field boundaries here. (visual-wrap-prefix-function): Check for unsafe display properties at the end of the line and skip past them if present. * test/lisp/visual-wrap-tests.el: New test file. --- lisp/visual-wrap.el | 48 +++++++++++-- test/lisp/visual-wrap-tests.el | 124 +++++++++++++++++++++++++++++++++ 2 files changed, 168 insertions(+), 4 deletions(-) create mode 100644 test/lisp/visual-wrap-tests.el diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el index 76276c0f474..26333089189 100644 --- a/lisp/visual-wrap.el +++ b/lisp/visual-wrap.el @@ -73,6 +73,36 @@ visual-wrap--face-extend-p (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)) @@ -128,11 +158,11 @@ visual-wrap--apply-to-line ;; 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))))) @@ -206,8 +236,18 @@ visual-wrap-prefix-function (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 to the beginning of the first line after + ;; the unsafe display property changes. + (goto-char (next-single-char-property-change (pos-eol) 'display)) + (unless (bolp) (forward-line 1)))) `(jit-lock-bounds ,beg . ,end)) ;;;###autoload diff --git a/test/lisp/visual-wrap-tests.el b/test/lisp/visual-wrap-tests.el new file mode 100644 index 00000000000..7cae3761b6a --- /dev/null +++ b/test/lisp/visual-wrap-tests.el @@ -0,0 +1,124 @@ +;;; 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 . + +;;; 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)) + (message "%S" (buffer-string)) + (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)) + (message "%S" (buffer-string)) + (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 the first block, but do add them to the +second." + (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) + #("* a\n* b" + 0 4 ( display ((image :type bmp))) + 4 6 ( wrap-prefix (space :align-to (2 . width)) + display ((min-width ((2 . width))) + (image :type bmp) (height 1.5))) + 6 7 ( wrap-prefix (space :align-to (2 . width)) + 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 -- 2.25.1