[nongnu] elpa/extmap 352eca4463 08/39: Fix text properties being stripped from strings in the database.

[ELPA Syncer]

branch: elpa/extmap
commit 352eca4463d38843c4f08d5ffd40d8bc8b464215
Author: Paul Pogonyshev <pogonyshev@gmail.com>
Commit: Paul Pogonyshev <pogonyshev@gmail.com>

    Fix text properties being stripped from strings in the database.
---
 extmap.el           | 13 ++++++---
 test/extmap-test.el | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 92 insertions(+), 5 deletions(-)

diff --git a/extmap.el b/extmap.el
index c4afa9c6d5..6bd225c992 100644
--- a/extmap.el
+++ b/extmap.el
@@ -366,19 +366,19 @@ Only available on Emacs 25, as this requires `generator' 
package."
             (insert (encode-coding-string (symbol-name key) 'utf-8 t))
             (insert 0)
             (with-temp-buffer
-              (let ((serialized (if (stringp value) value (prin1-to-string 
value))))
-                (unless (or (stringp value) (condition-case _ (equal (read 
serialized) value) (error nil)))
+              (let ((serialized (if (extmap--plain-string-p value) value 
(prin1-to-string value))))
+                (unless (or (extmap--plain-string-p value) (condition-case _ 
(equal (read serialized) value) (error nil)))
                   (error "Value for key `%s' cannot be saved in database: it 
cannot be read back or is different after reading" key))
                 (insert (encode-coding-string serialized 'utf-8 t))
                 (let ((num-bytes (buffer-size)))
                   (if (<= num-bytes max-inline-bytes)
                       (let ((serialized-in (current-buffer)))
                         (with-current-buffer buffer
-                          (insert (bindat-pack extmap--item-short-bindat-spec 
`((type . ,(if (stringp value) 0 1)) (length . ,num-bytes))))
+                          (insert (bindat-pack extmap--item-short-bindat-spec 
`((type . ,(if (extmap--plain-string-p value) 0 1)) (length . ,num-bytes))))
                           (insert-buffer-substring serialized-in)))
                     (write-region (point-min) (point-max) filename t)
                     (with-current-buffer buffer
-                      (insert (bindat-pack extmap--item-bindat-spec `((type . 
,(if (stringp value) 2 3)) (length . ,num-bytes) (offset . ,offset))))
+                      (insert (bindat-pack extmap--item-bindat-spec `((type . 
,(if (extmap--plain-string-p value) 2 3)) (length . ,num-bytes) (offset . 
,offset))))
                       (setq offset (+ offset num-bytes))))))))))
       (write-region (point-min) (point-max) filename t)
       ;; Update the header.
@@ -389,6 +389,11 @@ Only available on Emacs 25, as this requires `generator' 
package."
                                                         (offset    . 
,offset))))
       (write-region (point-min) (point-max) filename 0))))
 
+(defun extmap--plain-string-p (object)
+  (and (stringp object)
+       (null (text-properties-at 0 object))
+       (null (next-property-change 0 object))))
+
 
 (provide 'extmap)
 
diff --git a/test/extmap-test.el b/test/extmap-test.el
index edbb660a67..2a27e63772 100644
--- a/test/extmap-test.el
+++ b/test/extmap-test.el
@@ -25,6 +25,56 @@
 (defvar extmap--test-filename nil)
 
 
+;; This is like built-in `equal-including-properties', except that
+;; property values are compared with the same function, not with `eq'.
+;; Probably not complete.  Slow.
+(defun extmap--equal-including-properties (a b)
+  (cond ((stringp a)
+         (and (stringp b)
+              (string= a b)
+              (let ((at    0)
+                    (equal t))
+                (while (and at equal)
+                  (let ((next (next-property-change at a)))
+                    (setq equal (and (equal next (next-property-change at b))
+                                     (let ((a-properties    
(text-properties-at at a))
+                                           (b-properties    
(text-properties-at at b))
+                                           (a-property-hash (make-hash-table))
+                                           (b-property-hash (make-hash-table)))
+                                       (while a-properties
+                                         (puthash (pop a-properties) (pop 
a-properties) a-property-hash))
+                                       (while b-properties
+                                         (puthash (pop b-properties) (pop 
b-properties) b-property-hash))
+                                       (extmap--equal-including-properties 
a-property-hash b-property-hash)))
+                          at    next)))
+                equal)))
+        ((consp a)
+         ;; Recursive for lists, but that's not important for testing.
+         (and (consp b)
+              (extmap--equal-including-properties (car a) (car b))
+              (extmap--equal-including-properties (cdr a) (cdr b))))
+        ((vectorp a)
+         (and (vectorp b)
+              (let ((length (length a)))
+                (and (= length (length b))
+                     (let ((equal t)
+                           (k     0))
+                       (while (and equal (< k length))
+                         (setq equal (extmap--equal-including-properties (aref 
a k) (aref b k))
+                               k     (1+ k)))
+                       equal)))))
+        ((hash-table-p a)
+         (and (hash-table-p b)
+              (= (hash-table-count a) (hash-table-count b))
+              (catch 'equal
+                (maphash (lambda (key value)
+                           (unless (extmap--equal-including-properties value 
(gethash key b (not a)))
+                             (throw 'equal nil)))
+                         a)
+                t)))
+        (t
+         (equal a b))))
+
 (defun extmap--test-alist (data &rest options)
   (let ((filename (concat extmap--test-directory (or extmap--test-filename 
"test.extmap"))))
     (apply #'extmap-from-alist filename data :overwrite t options)
@@ -32,7 +82,7 @@
       (should (equal (extmap--test-sort-keys (mapcar #'car data)) 
(extmap--test-sort-keys (extmap-keys extmap))))
       (dolist (entry data)
         (should (extmap-contains-key extmap (car entry)))
-        (should (equal (extmap-get extmap (car entry)) (cdr entry)))
+        (should (extmap--equal-including-properties (extmap-get extmap (car 
entry)) (cdr entry)))
         (should (extmap-value-loaded extmap (car entry)))))))
 
 (defun extmap--test-sort-keys (keys)
@@ -50,3 +100,35 @@
                         (два    . "два")
                         (три    . ,(cons "ноль" (number-sequence 1 100)))
                         (четыре . "В траве сидел кузнечик, // В траве сидел 
кузнечик, // Совсем как огуречик, // Зелененький он был."))))
+
+(ert-deftest extmap-with-text-properties-1 ()
+  (extmap--test-alist `((foo  . 1)
+                        (bar  . ,(propertize "string" 'face 'bold))
+                        (baz  . ,(number-sequence 0 100))
+                        (spam . ,(propertize "lalala lalala lalala lalala 
lalala lalala lalala lalala lalala lalala lalala" 'face '(bold italic)))
+                        (ham  . ,(list (propertize "string" 'face '(bold 
italic)))))))
+
+
+(ert-deftest extmap-plain-string-p ()
+  (should (extmap--plain-string-p "foo"))
+  (should (extmap--plain-string-p "проверка"))
+  (should-not (extmap--plain-string-p nil))
+  (should-not (extmap--plain-string-p (propertize "foo" 'face 'bold)))
+  (should-not (extmap--plain-string-p (concat (propertize "foo" 'face 'bold) 
"bar")))
+  (should-not (extmap--plain-string-p (concat "foo" (propertize "bar" 'face 
'bold)))))
+
+(ert-deftest extmap-internal-equal ()
+  (should-not (extmap--equal-including-properties 1 2))
+  (should-not (extmap--equal-including-properties "foo" "bar"))
+  (should-not (extmap--equal-including-properties [1 2 3 4] [1 2 4 5]))
+  (should-not (extmap--equal-including-properties [1 2 3] [1 2 3 4]))
+  (should-not (extmap--equal-including-properties '(1 2 3) '(1 2 "3")))
+  (should-not (extmap--equal-including-properties '(1 2 3) '(1 2 3 4)))
+  (should-not (extmap--equal-including-properties (propertize "foo" 'face 
'bold) "foo"))
+  (should (extmap--equal-including-properties nil nil))
+  (should (extmap--equal-including-properties 1 1))
+  (should (extmap--equal-including-properties (cons 'a 'b) (cons 'a 'b)))
+  (should (extmap--equal-including-properties (list 1 2 3) (list 1 2 3)))
+  (should (extmap--equal-including-properties (vector 1 2 3) (vector 1 2 3)))
+  (should (extmap--equal-including-properties "foo" "foo"))
+  (should (extmap--equal-including-properties (propertize "foo" 'face (list 
'bold 'italic)) (propertize "foo" 'face (list 'bold 'italic)))))