Add methods for strings to cl-print

* lisp/emacs-lisp/cl-print.el (cl-print-object) <string>: New method.
(cl-print-object-contents) <string>: New method.
(cl-print--find-sharing): Look in string property lists.

* test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-3): Test
printing of long strings.
(cl-print-tests-4): Test printing of strings nested in other objects.
(cl-print-tests-strings, cl-print-tests-ellipsis-string): New
tests.

1 files changed, 52 insertions, 1 deletions

diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index 2b5eb3402bf..7594d2466b5 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -56,11 +56,13 @@
   (let ((long-list (make-list 5 'a))
         (long-vec (make-vector 5 'b))
         (long-struct (cl-print-tests-con))
+        (long-string (make-string 5 ?a))
         (print-length 4))
     (should (equal "(a a a a ...)" (cl-prin1-to-string long-list)))
     (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec)))
     (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"
-                   (cl-prin1-to-string long-struct)))))
+                   (cl-prin1-to-string long-struct)))
+    (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string)))))
 
 (ert-deftest cl-print-tests-4 ()
   "CL printing observes `print-level'."
@@ -68,11 +70,16 @@
          (buried-vector '(a (b (c (d [e])))))
          (deep-struct (cl-print-tests-con))
          (buried-struct `(a (b (c (d ,deep-struct)))))
+         (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t)))))))
+         (buried-simple-string '(a (b (c (d "hello")))))
          (print-level 4))
     (setf (cl-print-tests-struct-a deep-struct) deep-list)
     (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list)))
     (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector)))
     (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct)))
+    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string)))
+    (should (equal "(a (b (c (d \"hello\"))))"
+                   (cl-prin1-to-string buried-simple-string)))
     (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
                    (cl-prin1-to-string deep-struct)))))
 
@@ -86,6 +93,35 @@
       (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
                      (cl-prin1-to-string quoted-stuff))))))
 
+(ert-deftest cl-print-tests-strings ()
+  "CL printing prints strings and propertized strings."
+  (let* ((str1 "abcdefghij")
+         (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t)))
+         (str3 #("abcdefghij" 0 10 (test t)))
+         (obj '(a b))
+         ;; Since the byte compiler reuses string literals,
+         ;; and the put-text-property call is destructive, use
+         ;; copy-sequence to make a new string.
+         (str4 (copy-sequence "abcdefghij")))
+    (put-text-property 0 5 'test obj str4)
+    (put-text-property 7 10 'test obj str4)
+
+    (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1)))
+    (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))"
+                   (cl-prin1-to-string str2)))
+    (should (equal "#(\"abcdefghij\" 0 10 (test t))"
+                   (cl-prin1-to-string str3)))
+    (let ((print-circle nil))
+      (should
+       (equal
+        "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))"
+        (cl-prin1-to-string str4))))
+    (let ((print-circle t))
+      (should
+       (equal
+        "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))"
+        (cl-prin1-to-string str4))))))
+
 (ert-deftest cl-print-tests-ellipsis-cons ()
   "Ellipsis expansion works in conses."
   (let ((print-length 4)
@@ -113,6 +149,21 @@
     (cl-print-tests-check-ellipsis-expansion
      [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]")))
 
+(ert-deftest cl-print-tests-ellipsis-string ()
+  "Ellipsis expansion works in strings."
+  (let ((print-length 4)
+        (print-level 3))
+    (cl-print-tests-check-ellipsis-expansion
+     "abcdefg" "\"abcd...\"" "efg")
+    (cl-print-tests-check-ellipsis-expansion
+     "abcdefghijk" "\"abcd...\"" "efgh...")
+    (cl-print-tests-check-ellipsis-expansion
+     '(1 (2 (3 #("abcde" 0 5 (test t)))))
+     "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))")
+    (cl-print-tests-check-ellipsis-expansion
+     #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t))
+     "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ...")))
+
 (ert-deftest cl-print-tests-ellipsis-struct ()
   "Ellipsis expansion works in structures."
   (let ((print-length 4)