From: Gemini Lasswell Date: Fri, 15 Jun 2018 17:26:13 +0000 (-0700) Subject: Add methods for strings to cl-print X-Git-Tag: emacs-27.0.90~4655^2~16 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8a7620955b4d859caecd9a5dc9f2a986baf994fd;p=emacs.git Add methods for strings to cl-print * lisp/emacs-lisp/cl-print.el (cl-print-object) : New method. (cl-print-object-contents) : 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. --- diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index e638e58275a..337efa465a0 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -285,6 +285,95 @@ into a button whose action shows the function's disassembly.") (princ " " stream) (cl-print-insert-ellipsis object limit stream)))) +(cl-defmethod cl-print-object ((object string) stream) + (unless stream (setq stream standard-output)) + (let* ((has-properties (or (text-properties-at 0 object) + (next-property-change 0 object))) + (len (length object)) + (limit (if (natnump print-length) (min print-length len) len))) + (if (and has-properties + cl-print--depth + (natnump print-level) + (> cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + ;; Print all or part of the string + (when has-properties + (princ "#(" stream)) + (if (= limit len) + (prin1 (if has-properties (substring-no-properties object) object) + stream) + (let ((part (concat (substring-no-properties object 0 limit) "..."))) + (prin1 part stream) + (when (bufferp stream) + (with-current-buffer stream + (cl-print-propertize-ellipsis object limit + (- (point) 4) + (- (point) 1) stream))))) + ;; Print the property list. + (when has-properties + (let* ((interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (if (text-properties-at 0 object) + 0 (next-property-change 0 object))) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (princ " " stream) (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream))) + (princ ")" stream))))) + +(cl-defmethod cl-print-object-contents ((object string) start stream) + ;; If START is an integer, it is an index into the string, and the + ;; ellipsis that needs to be expanded is part of the string. If + ;; START is a cons, its car is an index into the string, and the + ;; ellipsis that needs to be expanded is in the property list. + (let* ((len (length object))) + (if (atom start) + ;; Print part of the string. + (let* ((limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (substr (substring-no-properties object start limit)) + (printed (prin1-to-string substr)) + (trimmed (substring printed 1 (1- (length printed))))) + (princ trimmed) + (when (< limit len) + (cl-print-insert-ellipsis object limit stream))) + + ;; Print part of the property list. + (let* ((first t) + (interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (car start)) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (if first + (setq first nil) + (princ " " stream)) + (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream)))))) ;;; Circularity and sharing. @@ -346,8 +435,17 @@ into a button whose action shows the function's disassembly.") (push cdr stack) (push car stack)) ((pred stringp) - ;; We presumably won't print its text-properties. - nil) + (let* ((len (length object)) + (start (if (text-properties-at 0 object) + 0 (next-property-change 0 object))) + (end (and start + (next-property-change start object len)))) + (while (and start (< start len)) + (let ((props (text-properties-at start object))) + (when props + (push props stack)) + (setq start end + end (next-property-change start object len)))))) ((or (pred arrayp) (pred byte-code-function-p)) ;; FIXME: Inefficient for char-tables! (dotimes (i (length object)) 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)