Add new tests for eieio persistence

* test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el:
  (hash-equal): New comparison test for hash-tables.
  (persist-test-save-and-compare): Use test for hash-tables.
  (eieio-test-persist-hash-and-vector,
  eieio-test-persist-interior-lists): New tests.

1 files changed, 103 insertions, 10 deletions

diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
index a3ab3834899..ff4aaf7aeb8 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
@@ -1,4 +1,4 @@
-;;; eieio-persist.el --- Tests for eieio-persistent class
+;;; eieio-test-persist.el --- Tests for eieio-persistent class
 
 ;; Copyright (C) 2011-2018 Free Software Foundation, Inc.
 
@@ -40,6 +40,17 @@ This is usually a symbol that starts with `:'."
 	(car tuple)
       nil)))
 
+(defun hash-equal (hash1 hash2)
+  "Compare two hash tables to see whether they are equal."
+  (and (= (hash-table-count hash1)
+          (hash-table-count hash2))
+       (catch 'flag
+         (maphash (lambda (x y)
+                    (or (equal (gethash x hash2) y)
+                        (throw 'flag nil)))
+                  hash1)
+         (throw 'flag t))))
+
 (defun persist-test-save-and-compare (original)
   "Compare the object ORIGINAL against the one read fromdisk."
 
@@ -49,8 +60,8 @@ This is usually a symbol that starts with `:'."
 	 (class (eieio-object-class original))
 	 (fromdisk (eieio-persistent-read file class))
 	 (cv (cl--find-class class))
-	 (slots  (eieio--class-slots cv))
-	 )
+	 (slots  (eieio--class-slots cv)))
+
     (unless (object-of-class-p fromdisk class)
       (error "Persistent class %S != original class %S"
 	     (eieio-object-class fromdisk)
@@ -62,18 +73,24 @@ This is usually a symbol that starts with `:'."
 	     (origvalue (eieio-oref original oneslot))
 	     (fromdiskvalue (eieio-oref fromdisk oneslot))
 	     (initarg-p (eieio--attribute-to-initarg
-                         (cl--find-class class) oneslot))
-	     )
+                         (cl--find-class class) oneslot)))
 
 	(if initarg-p
-	    (unless (equal origvalue fromdiskvalue)
+	    (unless
+		(cond ((and (hash-table-p origvalue) (hash-table-p fromdiskvalue))
+		       (hash-equal origvalue fromdiskvalue))
+		      (t (equal origvalue fromdiskvalue)))
 	      (error "Slot %S Original Val %S != Persistent Val %S"
 		     oneslot origvalue fromdiskvalue))
 	  ;; Else !initarg-p
-	  (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue)
+	  (let ((origval (cl--slot-descriptor-initform slot))
+		(diskval fromdiskvalue))
+	    (unless
+		(cond ((and (hash-table-p origval) (hash-table-p diskval))
+		       (hash-equal origval diskval))
+		      (t (equal origval diskval)))
 	    (error "Slot %S Persistent Val %S != Default Value %S"
-		   oneslot fromdiskvalue (cl--slot-descriptor-initform slot))))
-	))))
+		   oneslot diskval origvalue))))))))
 
 ;;; Simple Case
 ;;
@@ -205,13 +222,16 @@ persistent class.")
   ((slot1 :initarg :slot1
           :type (or persistent-random-class null persist-not-persistent))
    (slot2 :initarg :slot2
-          :type (or persist-not-persistent persist-random-class null))))
+          :type (or persist-not-persistent persistent-random-class null))
+   (slot3 :initarg :slot3
+          :type persistent-random-class)))
 
 (ert-deftest eieio-test-multiple-class-slot ()
   (let ((persist
          (persistent-multiclass-slot "random string"
           :slot1 (persistent-random-class)
           :slot2 (persist-not-persistent)
+          :slot3 (persistent-random-class)
           :file (concat default-directory "test-ps5.pt"))))
     (unwind-protect
         (persist-test-save-and-compare persist)
@@ -238,4 +258,77 @@ persistent class.")
     (persist-test-save-and-compare persist-wols)
     (delete-file (oref persist-wols file))))
 
+;;; Tests targeted at popular libraries in the wild.
+
+;; Objects inside hash tables and vectors (pcache), see bug#29220.
+(defclass person ()
+  ((name :type string :initarg :name)))
+
+(defclass classy (eieio-persistent)
+  ((teacher
+    :type person
+    :initarg :teacher)
+   (students
+    :initarg :students :initform (make-hash-table :test 'equal))
+   (janitors
+    :type list
+    :initarg :janitors)
+   (random-vector
+    :type vector
+    :initarg :random-vector)))
+
+(ert-deftest eieio-test-persist-hash-and-vector ()
+  (let* ((jane (make-instance 'person :name "Jane"))
+         (bob  (make-instance 'person :name "Bob"))
+         (hans (make-instance 'person :name "Hans"))
+         (dierdre (make-instance 'person :name "Dierdre"))
+         (class (make-instance 'classy
+			       :teacher jane
+                               :janitors (list [tuesday nil]
+                                              [friday nil])
+                               :random-vector [nil]
+			       :file (concat default-directory "classy-" emacs-version ".eieio"))))
+    (puthash "Bob" bob (slot-value class 'students))
+    (aset (slot-value class 'random-vector) 0
+          (make-instance 'persistent-random-class))
+    (aset (car (slot-value class 'janitor)) 1 hans)
+    (aset (nth 1 (slot-value class 'janitor)) 1 dierdre)
+    (unwind-protect
+        (persist-test-save-and-compare class)
+      (delete-file (oref class file)))))
+
+;; Extra quotation of lists inside other objects (Gnus registry), also
+;; bug#29220.
+
+(defclass eieio-container (eieio-persistent)
+  ((alist
+    :initarg :alist
+    :type list)
+   (vec
+    :initarg :vec
+    :type vector)
+   (htab
+    :initarg :htab
+    :type hash-table)))
+
+(ert-deftest eieio-test-persist-interior-lists ()
+  (let* ((thing (make-instance
+                 'eieio-container
+                 :vec [nil]
+                 :htab (make-hash-table :test #'equal)
+                 :file (concat default-directory
+                               "container-" emacs-version ".eieio")))
+         (john (make-instance 'person :name "John"))
+         (alexie (make-instance 'person :name "Alexie"))
+         (alst '(("first" (one two three))
+                 ("second" (four five six)))))
+    (setf (nth 2 (cadar alst)) john
+          (nth 2 (cadadr alst)) alexie)
+    (setf (slot-value thing 'alist) alst)
+    (puthash "alst" alst (slot-value thing 'htab))
+    (aset (slot-value thing 'vec) 0 alst)
+    (unwind-protect
+        (persist-test-save-and-compare thing)
+      (delete-file (slot-value thing 'file)))))
+
 ;;; eieio-test-persist.el ends here