From aa7e5ce651b1872180e8da94ac80fbc25e33eec0 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Fri, 11 Dec 2020 14:40:20 +0100
Subject: [PATCH] Add new function `object-intervals'

* doc/lispref/text.texi (Examining Properties): Document it.
* src/fns.c (Fobject_intervals): New defun.
(collect_interval): New function.
---
 doc/lispref/text.texi | 16 ++++++++++++++++
 etc/NEWS              |  6 ++++++
 src/fns.c             | 35 +++++++++++++++++++++++++++++++++++
 test/src/fns-tests.el | 16 ++++++++++++++++
 4 files changed, 73 insertions(+)

diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index c6ca4eed2e1..b712768a213 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -2931,6 +2931,22 @@ used instead.  Here is an example:
 @end example
 @end defvar
 
+@defun object-intervals OBJECT
+This function returns a copy of the intervals (i.e., text properties)
+in @var{object} as a list of intervals.  @var{object} must be a string
+or a buffer.  Altering the structure of this list does not change the
+intervals in the object.
+
+@example
+(object-intervals (propertize "foo" 'face 'bold))
+     @result{} ((0 3 (face bold)))
+@end example
+
+Each element in the returned list represents one interval.  Each
+interval has three parts: The first is the start, the second is the
+end, and the third part is the text property itself.
+@end defun
+
 @node Changing Properties
 @subsection Changing Text Properties
 @cindex changing text properties
diff --git a/etc/NEWS b/etc/NEWS
index befcf08cec3..1640e277987 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1389,6 +1389,12 @@ that makes it a valid button.
 
 ** Miscellaneous
 
++++
+*** New function 'object-intervals'.
+This function returns a copy of the list of intervals (i.e., text
+properties) in the object in question (which must either be a string
+or a buffer).
+
 ---
 *** 'hexl-mode' scrolling commands now heed 'next-screen-context-lines'.
 Previously, 'hexl-scroll-down' and 'hexl-scroll-up' would scroll
diff --git a/src/fns.c b/src/fns.c
index e9b6a96f344..a0c4a1fbf1a 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -5573,6 +5573,40 @@ Case is always significant and text properties are ignored. */)
 
   return make_int (string_byte_to_char (haystack, res - SSDATA (haystack)));
 }
+
+static void
+collect_interval (INTERVAL interval, Lisp_Object collector)
+{
+  nconc2 (collector,
+	  list1(list3 (make_fixnum (interval->position),
+		       make_fixnum (interval->position + LENGTH (interval)),
+		       interval->plist)));
+}
+
+DEFUN ("object-intervals", Fobject_intervals, Sobject_intervals, 1, 1, 0,
+       doc: /* Return a copy of the text properties of OBJECT.
+OBJECT must be a buffer or a string.
+
+Altering this copy does not change the layout of the text properties
+in OBJECT.  */)
+  (register Lisp_Object object)
+{
+  Lisp_Object collector = Fcons (Qnil, Qnil);
+  INTERVAL intervals;
+
+  if (STRINGP (object))
+    intervals = string_intervals (object);
+  else if (BUFFERP (object))
+    intervals = buffer_intervals (XBUFFER (object));
+  else
+    wrong_type_argument (Qbuffer_or_string_p, object);
+
+  if (! intervals)
+    return Qnil;
+
+  traverse_intervals (intervals, 0, collect_interval, collector);
+  return CDR (collector);
+}
 
 
 void
@@ -5614,6 +5648,7 @@ syms_of_fns (void)
   defsubr (&Smaphash);
   defsubr (&Sdefine_hash_table_test);
   defsubr (&Sstring_search);
+  defsubr (&Sobject_intervals);
 
   /* Crypto and hashing stuff.  */
   DEFSYM (Qiv_auto, "iv-auto");
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 86b8d655d26..14c0437d5f0 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -983,3 +983,19 @@
   (should (equal (string-search (string-to-multibyte "o\303\270") "foo\303\270")
                  2))
   (should (equal (string-search "\303\270" "foo\303\270") 3)))
+
+(ert-deftest object-intervals ()
+  (should (equal (object-intervals (propertize "foo" 'bar 'zot))
+                 ((0 3 (bar zot)))))
+  (should (equal (object-intervals (concat (propertize "foo" 'bar 'zot)
+                                           (propertize "foo" 'gazonk "gazonk")))
+                 ((0 3 (bar zot)) (3 6 (gazonk "gazonk")))))
+  (should (equal
+           (with-temp-buffer
+             (insert "foobar")
+             (put-text-property 1 3 'foo 1)
+             (put-text-property 3 6 'bar 2)
+             (put-text-property 2 5 'zot 3)
+             (object-intervals (current-buffer)))
+           ((0 1 (foo 1)) (1 2 (zot 3 foo 1)) (2 4 (zot 3 bar 2))
+            (4 5 (bar 2)) (5 6 nil)))))
-- 
2.39.2