branch: elpa/extmap
commit 352eca4463d38843c4f08d5ffd40d8bc8b464215
Author: Paul Pogonyshev <pogonys...@gmail.com>
Commit: Paul Pogonyshev <pogonys...@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)))))
