From fde9363a57d0d38d592122fe5ca01aaafd0afa52 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Wed, 24 Nov 2021 19:38:41 +0100
Subject: [PATCH] Add new function 'add-display-text-property'

* doc/lispref/display.texi (Display Property): Document it.
* lisp/emacs-lisp/subr-x.el (add-display-text-property): New function.
---
 doc/lispref/display.texi             | 25 ++++++++++++++++
 etc/NEWS                             |  7 +++++
 lisp/emacs-lisp/subr-x.el            | 45 ++++++++++++++++++++++++++++
 test/lisp/emacs-lisp/subr-x-tests.el | 18 +++++++++++
 4 files changed, 95 insertions(+)

diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index fdebba939be..7204581e407 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -4904,6 +4904,31 @@ with @code{get-char-property}, for instance (@pxref{Examining
 Properties}).
 @end defun
 
+@defun add-display-text-property start end prop value &optional append object
+Add @code{display} property @var{prop} of @var{value} to the text from
+@var{start} to @var{end}.
+
+If any text in the region has a non-@code{nil} @code{display}
+property, those properties are retained.  For instance:
+
+@lisp
+(add-display-text-property 4 8 'height 2.0)
+(add-display-text-property 2 12 'raise 0.5)
+@end lisp
+
+After doing this, the region from 2 to 4 will have the @code{raise}
+@code{display} property, the region from 4 to 8 will have both the
+@code{raise} and @code{height} @code{display} properties, and finally
+the region from 8 to 12 will only have the @code{raise} @code{display}
+property.
+
+If @var{append} is non-@code{nil}, append to the list of display
+properties; otherwise prepend.
+
+If @var{object} is non-@code{nil}, it should be a string or a buffer.
+If @code{nil}, this 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,
diff --git a/etc/NEWS b/etc/NEWS
index 24b8cb27961..8b7c2f78508 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -676,10 +676,17 @@ Use 'exif-parse-file' and 'exif-field' instead.
 
 * Lisp Changes in Emacs 29.1
 
++++
 ** New function 'get-display-property'.
 This is like 'get-text-property', but works on the 'display' text
 property.
 
++++
+** New function 'add-text-display-property'.
+This is like 'put-text-property', but works on the 'display' text
+property.
+
++++
 ** New 'min-width' 'display' property.
 This allows setting a minimum display width for a region of text.
 
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 95254b946e5..3ec880f8b8f 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -469,6 +469,51 @@ This takes into account combining characters and grapheme clusters."
         (setq start (1+ start))))
     (nreverse result)))
 
+;;;###autoload
+(defun add-display-text-property (start end prop value
+                                        &optional append object)
+  "Add display property PROP with VALUE to the text from START to END.
+If any text in the region has a non-nil `display' property, those
+properties are retained.
+
+If APPEND is non-nil, append to the list of display properties;
+otherwise prepend.
+
+If OBJECT is non-nil, it should be a string or a buffer.  If nil,
+this defaults to the current buffer."
+  (let ((sub-start start)
+        (sub-end 0)
+        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)))))
+      (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 prop value))
+        ;; We have old properties.
+        (let ((vector nil))
+          ;; Make disp into a list.
+          (setq disp
+                (cond
+                 ((vectorp disp)
+                  (setq vector t)
+                  (seq-into disp 'list))
+                 ((not (consp (car disp)))
+                  (list disp))
+                 (t
+                  disp)))
+          (setq disp
+                (if append
+                    (append disp (list (list prop value)))
+                  (append (list (list prop value)) disp)))
+          (when vector
+            (setq disp (seq-into disp 'vector)))
+          ;; Finally update the range.
+          (put-text-property sub-start sub-end 'display disp)))
+      (setq sub-start sub-end))))
+
 (provide 'subr-x)
 
 ;;; subr-x.el ends here
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index f9cfea888c7..69d59e84f6d 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -676,5 +676,23 @@
       (buffer-string))
     "foo\n")))
 
+(ert-deftest test-add-display-text-property ()
+  (with-temp-buffer
+    (insert "Foo bar zot gazonk")
+    (add-display-text-property 4 8 'height 2.0)
+    (add-display-text-property 2 12 'raise 0.5)
+    (should (equal (get-text-property 2 'display) '(raise 0.5)))
+    (should (equal (get-text-property 5 'display)
+                   '((raise 0.5) (height 2.0))))
+    (should (equal (get-text-property 9 'display) '(raise 0.5))))
+  (with-temp-buffer
+    (insert "Foo bar zot gazonk")
+    (put-text-property 4 8 'display [(height 2.0)])
+    (add-display-text-property 2 12 'raise 0.5)
+    (should (equal (get-text-property 2 'display) '(raise 0.5)))
+    (should (equal (get-text-property 5 'display)
+                   [(raise 0.5) (height 2.0)]))
+    (should (equal (get-text-property 9 'display) '(raise 0.5)))))
+
 (provide 'subr-x-tests)
 ;;; subr-x-tests.el ends here
-- 
2.39.5