Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv26571/tests
Modified Files: elephant-tests.lisp testmigration.lisp Log Message: Added functionality and test for migrating persistent references inside lisp aggregates: array, list and hash tables
--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/26 19:12:19 1.26 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/03/11 03:31:10 1.27 @@ -145,6 +145,7 @@ (print (do-test 'migrate-btree)) (print (do-test 'migrate-idx-btree)) (print (do-test 'migrate-pclass)) + (print (do-test 'migrate-mult-pclass)) (print (do-test 'migrate-ipclass))))
(defun do-migration-test-spec (test spec1 spec2) --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/02/03 04:09:14 1.14 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/03/11 03:31:10 1.15 @@ -65,7 +65,7 @@ do (setf (get-value i ibt) (* i i)))) (let ((mig (migrate sc2 ibt))) - (btree-differ ibt mig))) + (btree-differ-p ibt mig))) (close-store sc1) (close-store sc2)))) nil) @@ -103,7 +103,7 @@ (progn (format t "YIKES ~A ~%" i) ))) - (not (btree-differ ibt mig))))) + (not (btree-differ-p ibt mig))))) (progn (setq *store-controller* old-store) (close-store sc1) @@ -144,6 +144,45 @@ (close-store sc2)))) t)
+(deftest migrate-mult-pclass + (progn + (let* ((*store-controller* nil) + (sc1 (open-store *test-spec-primary* :recover t :deadlock-detect t)) + (sc2 (open-store *test-spec-secondary* :recover t :deadlock-detect t))) + (unwind-protect + (progn (elephant::reset-migrate-duplicate-detection) + (let* ((simplesrc (make-instance 'pfoo :slot1 0 :sc sc1)) + (i1 (make-instance 'pfoo :slot1 1 :sc sc1)) + (i2 (make-instance 'pfoo :slot1 2 :sc sc1)) + (i3 (make-instance 'pfoo :slot1 3 :sc sc1)) + (list (list i1 i1)) + (array (make-array '(2 2) :initial-contents `((,i2 1) + (,i2 2)))) + (hash (make-hash-table))) + (setf (gethash 1 hash) i3) + (setf (gethash 2 hash) i3) + (let* ((newsimple (migrate sc2 simplesrc)) + (newlist (migrate sc2 list)) + (newarray (migrate sc2 array)) + (newhash (migrate sc2 hash))) + (values (and (and (slot-boundp newsimple 'slot1) + (eq (slot1 newsimple) 0))) + (and (not (eq i1 (first newlist))) + (eq (first newlist) (second newlist)) + (and (slot-boundp (first newlist) 'slot1) + (eq (slot1 (first newlist)) 1))) + (and (not (eq i2 (aref newarray 0 0))) + (eq (aref newarray 0 0) (aref newarray 1 0)) + (and (slot-boundp (aref newarray 0 0) 'slot1) + (eq (slot1 (aref newarray 0 0)) 2))) + (and (not (eq i3 (gethash 1 newhash))) + (eq (gethash 1 newhash) (gethash 2 newhash)) + (and (slot-boundp (gethash 1 newhash) 'slot1) + (eq (slot1 (gethash 1 newhash)) 3))))))) + (close-store sc1) + (close-store sc2)))) + t t t t t t t t t t) + (defpclass ipfoo () ((slot1 :accessor slot1 :initarg :slot1 :index t)))
@@ -167,7 +206,7 @@ (remove-kv 'ipfoo (elephant::controller-class-root sc2))) (setf (elephant::%index-cache (find-class 'ipfoo)) nil) (find-class-index 'ipfoo :sc sc1) - (format t "Making objects~%") +;; (format t "Making objects~%") ;; (with-transaction (:store-controller sc2) ;; (drop-instances (get-instances-by-class 'ipfoo) :sc sc2)) (with-transaction (:store-controller sc1 :retries 2) @@ -175,12 +214,12 @@ (make-instance 'ipfoo :slot1 1 :sc sc1) (make-instance 'ipfoo :slot1 10 :sc sc1) (make-instance 'ipfoo :slot1 20 :sc sc1)) - (format t "Migrating~%") +;; (format t "Migrating~%") (migrate sc2 sc1) ;; Make sure our ipfoo class now points at a cache in sc2! (assert (equal (elephant::controller-spec sc2) - (:dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo))))) - (format t "Fetching~%") + (elephant::dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo))))) +;; (format t "Fetching~%") (let ((fm1 (get-instances-by-value 'ipfoo 'slot1 1)) (fm2 (get-instances-by-value 'ipfoo 'slot1 10)) (fm3 (get-instances-by-value 'ipfoo 'slot1 20))