Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv18077

Modified Files: testcollections.lisp testmigration.lisp Log Message: This directory used for some initial tests.

--- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/01/25 15:36:32 1.7 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/04 20:34:02 1.8 @@ -713,3 +713,20 @@ ;; (equal (get-value 10 ibt) 4))) ;; ) ;; t) + + + +;; (deftest class-change-deletion +;; (progn +;; (defclass blob-tbc () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot2 :accessor slot2 :initarg :slot2))) +;; (add-to-root "blob" (make-instance 'blob-tbc)) +;; (defclass blob-tbc () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot3 :accessor slot3 :initarg :slot3))) +;; (remove-from-root "blob") +;; (get-from-root "blob") +;; ) +;; nil nil) + --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/01/24 18:25:01 1.3 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/04 20:34:02 1.4 @@ -156,46 +156,38 @@ (progn (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") t) - (finishes - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t)) - (unwind-protect - (let ((osc (if (subtypep (type-of *store-controller*) 'sql-store-controller) - (open-store *test-path-primary*) - (open-store *test-path-secondary*) - ))) -;; really need to test the an error is thrown when attempting to migrate -;; non-persistent object! - (let* ((f1 (make-instance 'pfoo :sc *store-controller*)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*)) - (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*)) - ) - (let ((fm1 - (ele::migraten-pobj - osc f1 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (fm2 - (ele::migraten-pobj - osc f2 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (bm1 (ele::migraten-pobj - osc b1 - #'(lambda (dst src) - (if (slot-boundp src 'slot2) - (setf (slot2 dst) (slot2 src)))))) - ) - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 bm1) (slot2 b1)))))) - (progn - (setq *store-controller* old-store) + (let ((*prev-commit* *auto-commit*)) + (prog2 + (setq *auto-commit* t) + (let ( + (sc1 (open-store *test-path-primary*)) + (sc2 (open-store *test-path-secondary*))) + (let* ((f1 (make-instance 'pfoo :sc sc1)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) + (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) + ) + (let ((fm1 + (ele::migraten-pobj + sc2 f1 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) + (fm2 + (ele::migraten-pobj + sc2 f2 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) + (bm1 (ele::migraten-pobj + sc2 b1 + #'(lambda (dst src) + (if (slot-boundp src 'slot2) + (setf (slot2 dst) (slot2 src)))))) + ) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1)))))) (setq *auto-commit* *prev-commit*)))) - )) - t) + t)