mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-03 02:31:03 -08:00
Clean up text properties in 'visual-wrap-prefix-mode'
Before refontifying a region, remove any text properties we care about so that we don't end up with stray properties. Additionally, make sure to remove all the properties when deactivating the mode. * lisp/emacs-lisp/subr-x.el (add-remove--display-text-property): New function, extracted from... (add-display-text-property): ... here. (remove-display-text-property): New function. * lisp/visual-wrap.el (visual-wrap--remove-properties): New function... (visual-wrap-prefix-function, visual-wrap-prefix-mode): ... call it. * test/lisp/emacs-lisp/subr-x-tests.el (subr-x-test-remove-display-text-property): New test. * test/lisp/visual-wrap-tests.el (visual-wrap-tests/wrap-prefix-stickiness, visual-wrap-tests/cleanup): New tests. * doc/lispref/display.texi (Display Property): Document 'remove-display-text-property'. * etc/NEWS: Announce 'remove-display-text-property' (bug#76018).
This commit is contained in:
Jim Porter
parent
24e6cd4233
commit
90c0c9a01e
6 changed files with 174 additions and 23 deletions
|
|
@ -5302,6 +5302,44 @@ specification.
|
|||
If omitted, @var{object} defaults to the current buffer.
|
||||
@end defun
|
||||
|
||||
@defun remove-display-text-property start end spec &optional object
|
||||
Remove the display specification @var{spec} from the text from
|
||||
@var{start} to @var{end}. @var{spec} is the @sc{car} of the display
|
||||
specification to remove, e.g.@: @code{height} or @code{'(margin nil)}.
|
||||
|
||||
If any text in the region has any other @code{display} properties, those
|
||||
properties are retained. For instance:
|
||||
|
||||
@lisp
|
||||
@group
|
||||
(add-display-text-property 1 8 'raise 0.5)
|
||||
(add-display-text-property 4 8 'height 2.0)
|
||||
(remove-display-text-property 2 6 'raise)
|
||||
@end group
|
||||
@end lisp
|
||||
|
||||
After doing this, the text will have the following @code{display}
|
||||
properties:
|
||||
|
||||
@itemize @bullet
|
||||
@item
|
||||
The region from 1 to 2, only @code{raise}
|
||||
|
||||
@item
|
||||
The region from 2 to 4, no properties
|
||||
|
||||
@item
|
||||
The region from 4 to 6, only @code{height}
|
||||
|
||||
@item
|
||||
The region from 6 to 8, both @code{raise} and @code{height}
|
||||
|
||||
@end itemize
|
||||
|
||||
@var{object} is either a string or a buffer to remove the specification
|
||||
from. If omitted, @var{object} defaults to the current buffer.
|
||||
@end defun
|
||||
|
||||
@cindex display property, unsafe evaluation
|
||||
@cindex security, and display specifications
|
||||
Some of the display specifications allow inclusion of Lisp forms,
|
||||
|
|
|
|||
6
etc/NEWS
6
etc/NEWS
|
|
@ -2413,6 +2413,12 @@ This 'display' property was previously supported only as text property.
|
|||
Now overlays can also have this property, with the same effect for the
|
||||
text "covered" by the overlay.
|
||||
|
||||
+++
|
||||
** New function 'remove-display-text-property'.
|
||||
This function removes a display property from the specified region of
|
||||
text, preserving any other display properties already set for that
|
||||
region.
|
||||
|
||||
+++
|
||||
** New macro 'cond*'.
|
||||
The new macro 'cond*' is an alternative to 'cond' and 'pcase'.
|
||||
|
|
|
|||
|
|
@ -416,28 +416,25 @@ indivisible unit."
|
|||
(setq start (1+ start))))
|
||||
(nreverse result)))
|
||||
|
||||
;;;###autoload
|
||||
(defun add-display-text-property (start end spec value &optional object)
|
||||
"Add the display specification (SPEC VALUE) to the text from START to END.
|
||||
If any text in the region has a non-nil `display' property, the existing
|
||||
display specifications are retained.
|
||||
|
||||
OBJECT is either a string or a buffer to add the specification to.
|
||||
If omitted, OBJECT defaults to the current buffer."
|
||||
(defun add-remove--display-text-property (start end spec value
|
||||
&optional object remove)
|
||||
(let ((sub-start start)
|
||||
(sub-end 0)
|
||||
(limit (if (stringp object)
|
||||
(min (length object) end)
|
||||
(min end (point-max))))
|
||||
disp)
|
||||
(while (< sub-end end)
|
||||
(setq sub-end (next-single-property-change sub-start 'display object
|
||||
(if (stringp object)
|
||||
(min (length object) end)
|
||||
(min end (point-max)))))
|
||||
limit))
|
||||
(if (not (setq disp (get-text-property sub-start 'display object)))
|
||||
;; No old properties in this range.
|
||||
(put-text-property sub-start sub-end 'display (list spec value)
|
||||
object)
|
||||
(unless remove
|
||||
(put-text-property sub-start sub-end 'display (list spec value)
|
||||
object))
|
||||
;; We have old properties.
|
||||
(let (type)
|
||||
(let ((changed nil)
|
||||
type)
|
||||
;; Make disp into a list.
|
||||
(setq disp
|
||||
(cond
|
||||
|
|
@ -460,14 +457,41 @@ If omitted, OBJECT defaults to the current buffer."
|
|||
;; regions of text.
|
||||
(setq disp (if (eq type 'list)
|
||||
(remove old disp)
|
||||
(delete old disp))))
|
||||
(setq disp (cons (list spec value) disp))
|
||||
(when (eq type 'vector)
|
||||
(setq disp (seq-into disp 'vector)))
|
||||
;; Finally update the range.
|
||||
(put-text-property sub-start sub-end 'display disp object)))
|
||||
(delete old disp))
|
||||
changed t))
|
||||
(unless remove
|
||||
(setq disp (cons (list spec value) disp)
|
||||
changed t))
|
||||
(when changed
|
||||
(if (not disp)
|
||||
(remove-text-properties sub-start sub-end '(display nil) object)
|
||||
(when (eq type 'vector)
|
||||
(setq disp (seq-into disp 'vector)))
|
||||
;; Finally update the range.
|
||||
(put-text-property sub-start sub-end 'display disp object)))))
|
||||
(setq sub-start sub-end))))
|
||||
|
||||
;;;###autoload
|
||||
(defun add-display-text-property (start end spec value &optional object)
|
||||
"Add the display specification (SPEC VALUE) to the text from START to END.
|
||||
If any text in the region has a non-nil `display' property, the existing
|
||||
display specifications are retained.
|
||||
|
||||
OBJECT is either a string or a buffer to add the specification to.
|
||||
If omitted, OBJECT defaults to the current buffer."
|
||||
(add-remove--display-text-property start end spec value object))
|
||||
|
||||
;;;###autoload
|
||||
(defun remove-display-text-property (start end spec &optional object)
|
||||
"Remove the display specification SPEC from the text from START to END.
|
||||
SPEC is the car of the display specification to remove, e.g. `height'.
|
||||
If any text in the region has other display specifications, those specs
|
||||
are retained.
|
||||
|
||||
OBJECT is either a string or a buffer to remove the specification from.
|
||||
If omitted, OBJECT defaults to the current buffer."
|
||||
(add-remove--display-text-property start end spec nil object 'remove))
|
||||
|
||||
;;;###autoload
|
||||
(defun read-process-name (prompt)
|
||||
"Query the user for a process and return the process object."
|
||||
|
|
|
|||
|
|
@ -226,6 +226,14 @@ by `visual-wrap-extra-indent'."
|
|||
(propertize prefix 'face face)
|
||||
prefix)))
|
||||
|
||||
(defun visual-wrap--remove-properties (start end)
|
||||
"Remove visual wrapping text properties from START to END."
|
||||
;; Remove `min-width' from any prefixes we detected.
|
||||
(remove-display-text-property start end 'min-width)
|
||||
;; Remove `wrap-prefix' related properties from any lines with
|
||||
;; prefixes we detected.
|
||||
(remove-text-properties start end '(wrap-prefix nil)))
|
||||
|
||||
(defun visual-wrap-prefix-function (beg end)
|
||||
"Indent the region between BEG and END with visual filling."
|
||||
;; Any change at the beginning of a line might change its wrap
|
||||
|
|
@ -238,6 +246,7 @@ by `visual-wrap-extra-indent'."
|
|||
(goto-char beg)
|
||||
(forward-line 0)
|
||||
(setq beg (point))
|
||||
(visual-wrap--remove-properties beg end)
|
||||
(while (< (point) end)
|
||||
;; Check if the display property at the end of this line is "safe".
|
||||
(if (visual-wrap--display-property-safe-p
|
||||
|
|
@ -283,7 +292,7 @@ To enable this minor mode across all buffers, enable
|
|||
(with-silent-modifications
|
||||
(save-restriction
|
||||
(widen)
|
||||
(remove-text-properties (point-min) (point-max) '(wrap-prefix nil))))))
|
||||
(visual-wrap--remove-properties (point-min) (point-max))))))
|
||||
|
||||
;;;###autoload
|
||||
(define-globalized-minor-mode global-visual-wrap-prefix-mode
|
||||
|
|
|
|||
|
|
@ -740,6 +740,44 @@
|
|||
4 8 (display ((raise 0.5) (height 2.0)))
|
||||
8 12 (display (raise 0.5)))))))
|
||||
|
||||
(ert-deftest subr-x-test-remove-display-text-property ()
|
||||
(with-temp-buffer
|
||||
(insert "Foo bar zot gazonk")
|
||||
(add-display-text-property 4 12 'height 2.0)
|
||||
(add-display-text-property 2 8 'raise 0.5)
|
||||
(remove-display-text-property 6 10 'height)
|
||||
(should (equal-including-properties
|
||||
(buffer-string)
|
||||
#("Foo bar zot gazonk"
|
||||
1 3 (display (raise 0.5))
|
||||
3 5 (display ((raise 0.5) (height 2.0)))
|
||||
5 7 (display ((raise 0.5)))
|
||||
9 11 (display (height 2.0))))))
|
||||
(with-temp-buffer
|
||||
(insert "Foo bar zot gazonk")
|
||||
(put-text-property 4 12 'display [(height 2.0)])
|
||||
(add-display-text-property 2 8 'raise 0.5)
|
||||
(remove-display-text-property 6 10 'height)
|
||||
(should (equal-including-properties
|
||||
(buffer-string)
|
||||
#("Foo bar zot gazonk"
|
||||
1 3 (display (raise 0.5))
|
||||
3 5 (display [(raise 0.5) (height 2.0)])
|
||||
5 7 (display [(raise 0.5)])
|
||||
9 11 (display [(height 2.0)])))))
|
||||
(with-temp-buffer
|
||||
(should (equal-including-properties
|
||||
(let ((str (copy-sequence "Foo bar zot gazonk")))
|
||||
(add-display-text-property 3 11 'height 2.0 str)
|
||||
(add-display-text-property 1 7 'raise 0.5 str)
|
||||
(remove-display-text-property 5 9 'height str)
|
||||
str)
|
||||
#("Foo bar zot gazonk"
|
||||
1 3 (display (raise 0.5))
|
||||
3 5 (display ((raise 0.5) (height 2.0)))
|
||||
5 7 (display ((raise 0.5)))
|
||||
9 11 (display (height 2.0)))))))
|
||||
|
||||
(ert-deftest subr-x-named-let ()
|
||||
(let ((funs ()))
|
||||
(named-let loop
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; visual-wrap-tests.el --- Tests for `visual-wrap-prefix-mode' -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2024 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2024-2025 Free Software Foundation, Inc.
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
|
|
@ -19,7 +19,7 @@
|
|||
|
||||
;;; Commentary:
|
||||
|
||||
;; Tets for `visual-wrap-prefix-mode'.
|
||||
;; Tests for `visual-wrap-prefix-mode'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
|
|
@ -117,4 +117,40 @@ should *not* add wrapping properties to either block."
|
|||
0 4 (display ((image :type bmp)))
|
||||
4 8 (display ((image :type bmp) (height 1.5))))))))
|
||||
|
||||
(ert-deftest visual-wrap-tests/wrap-prefix-stickiness ()
|
||||
"Test that `wrap-prefix' doesn't persist across multiple lines when typing.
|
||||
See bug#76018."
|
||||
(with-temp-buffer
|
||||
(insert "* this zoo contains goats")
|
||||
(visual-wrap-prefix-function (point-min) (point-max))
|
||||
(should (equal-including-properties
|
||||
(buffer-string)
|
||||
#("* this zoo contains goats"
|
||||
0 2 ( wrap-prefix (space :align-to (2 . width))
|
||||
display (min-width ((2 . width))))
|
||||
2 25 ( wrap-prefix (space :align-to (2 . width))))))
|
||||
(let ((start (point)))
|
||||
(insert-and-inherit "\n\nit also contains pandas")
|
||||
(visual-wrap-prefix-function start (point-max)))
|
||||
(should (equal-including-properties
|
||||
(buffer-string)
|
||||
#("* this zoo contains goats\n\nit also contains pandas"
|
||||
0 2 ( wrap-prefix (space :align-to (2 . width))
|
||||
display (min-width ((2 . width))))
|
||||
2 25 ( wrap-prefix (space :align-to (2 . width))))))))
|
||||
|
||||
(ert-deftest visual-wrap-tests/cleanup ()
|
||||
"Test that deactivating `visual-wrap-prefix-mode' cleans up text properties."
|
||||
(with-temp-buffer
|
||||
(insert "* hello\n* hi")
|
||||
(visual-wrap-prefix-function (point-min) (point-max))
|
||||
;; Make sure we've added the visual-wrapping properties.
|
||||
(should (equal (text-properties-at (point-min))
|
||||
'( wrap-prefix (space :align-to (2 . width))
|
||||
display (min-width ((2 . width))))))
|
||||
(visual-wrap-prefix-mode -1)
|
||||
(should (equal-including-properties
|
||||
(buffer-string)
|
||||
"* hello\n* hi"))))
|
||||
|
||||
;; visual-wrap-tests.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue