[bknr-cvs] r2375 - branches/bos/projects/bos/m2

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Mon Jan 21 08:59:03 2008
New Revision: 2375

Modified:
   branches/bos/projects/bos/m2/allocation-test.lisp
   branches/bos/projects/bos/m2/test-fixtures.lisp
Log:
now using STORE-TEST + WITH-STORE-REOPENINGS to define tests


Modified: branches/bos/projects/bos/m2/allocation-test.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-test.lisp	(original)
+++ branches/bos/projects/bos/m2/allocation-test.lisp	Mon Jan 21 08:59:03 2008
@@ -1,50 +1,56 @@
 (in-package :bos.test)
 (in-suite :bos.test.allocation-area)
 
-(test allocation-area.none-at-startup
-  (with-fixture empty-store ()
-    (is (null (class-instances 'bos.m2:allocation-area)))))
+(store-test allocation-area.none-at-startup
+  (is (null (class-instances 'bos.m2:allocation-area))))
 
-(test allocation-area.no-intersection
-  (with-fixture empty-store ()
+(store-test allocation-area.no-intersection
+  (with-store-reopenings ()
     (finishes (make-allocation-rectangle 0 0 100 100))
     (signals (error) (make-allocation-rectangle 0 0 100 100))))
 
-(test allocation-area.one-contract.no-cache
-  (with-fixture empty-store ()
-    (let ((area (make-allocation-rectangle 0 0 100 100))
-	  (sponsor (make-sponsor :login "test-sponsor"))
-	  (m2-count 10))
+(store-test allocation-area.one-contract.no-cache
+  (let ((area (make-allocation-rectangle 0 0 100 100))
+	(sponsor (make-sponsor :login "test-sponsor"))
+	(m2-count 10))
+    (with-store-reopenings (area sponsor)
       (finishes (make-contract sponsor m2-count))
       (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))
 
-(test allocation-area.one-contract.with-cache.1
-  (with-fixture empty-store ()
-    (let ((area (make-allocation-rectangle 0 0 2 5))
-	  (sponsor (make-sponsor :login "test-sponsor"))
-	  (m2-count 10))
-      (with-transaction ()
-	(bos.m2::activate-allocation-area area))
+(store-test allocation-area.one-contract.with-cache.1
+  (let ((area (make-allocation-rectangle 0 0 2 5))
+	(sponsor (make-sponsor :login "test-sponsor"))
+	(m2-count 10))
+    (with-transaction ()
+      (bos.m2::activate-allocation-area area))
+    (with-store-reopenings (area sponsor)
       (finishes (allocation-area-free-m2s area))
-      (is (= 1 (bos.m2.allocation-cache:free-regions-count)))
-      (reopen-store (:snapshot nil) area sponsor)
+      (is (= 1 (bos.m2.allocation-cache:free-regions-count)))      
       (is-true (bos.m2.allocation-cache:find-exact-match 10))
       (finishes (make-contract sponsor m2-count))
       (is (zerop (allocation-area-free-m2s area))))))
 
-(test allocation-area.one-contract.allocate-all-without-cache
-  (with-fixture empty-store ()
-    (let ((area (make-allocation-rectangle 0 0 100 100))
-	  (sponsor (make-sponsor :login "test-sponsor"))
-	  (m2-count (* 100 100)))
+(store-test allocation-area.one-contract.allocate-all-without-cache
+  (let ((area (make-allocation-rectangle 0 0 100 100))
+	(sponsor (make-sponsor :login "test-sponsor"))
+	(m2-count (* 100 100)))
+    (with-store-reopenings (area sponsor)
       (finishes (make-contract sponsor m2-count))
       (signals (error) (make-contract sponsor m2-count))
       (is (zerop (allocation-area-free-m2s area))))))
 
-(test allocation-area.one-contract.notany-m2-contract
-  (with-fixture empty-store ()
-    (let ((area (make-allocation-rectangle 0 0 8 8))
-	  (sponsor (make-sponsor :login "test-sponsor")))
+(store-test allocation-area.one-contract.notany-m2-contract
+  (let ((area (make-allocation-rectangle 0 0 8 8))
+	(sponsor (make-sponsor :login "test-sponsor")))
+    (with-store-reopenings (area sponsor)
+      (finishes (make-contract sponsor 10))      
+      (is (= (- 64 10) (allocation-area-free-m2s area)))
+      (signals (error) (make-contract sponsor 64)))))
+
+(store-test allocation-area.one-contract.notany-m2-contract
+  (let ((area (make-allocation-rectangle 0 0 8 8))
+	(sponsor (make-sponsor :login "test-sponsor")))
+    (with-store-reopenings (area sponsor)
       (finishes (make-contract sponsor 10))      
       (is (= (- 64 10) (allocation-area-free-m2s area)))
       (signals (error) (make-contract sponsor 64)))))

Modified: branches/bos/projects/bos/m2/test-fixtures.lisp
==============================================================================
--- branches/bos/projects/bos/m2/test-fixtures.lisp	(original)
+++ branches/bos/projects/bos/m2/test-fixtures.lisp	Mon Jan 21 08:59:03 2008
@@ -26,6 +26,22 @@
 		(collect store-object-var)
 		(collect `(find-store-object ,id-var)))))))
 
+(defmacro %with-store-reopenings ((&key snapshot bypass)
+				  (&rest store-object-vars) &body body)
+  `(progn
+     ,@(if bypass
+	   body
+	   (iter
+	     (for form in body)
+	     (unless (first-time-p)
+	       (collect `(reopen-store (:snapshot ,snapshot) , at store-object-vars)))
+	     (collect form)))))
+
+(defmacro with-store-reopenings ((&rest store-object-vars) &body body)
+  `(%with-store-reopenings (:snapshot snapshot :bypass bypass)
+       (, at store-object-vars)
+     , at body))
+
 (def-fixture empty-store ()  
   (unwind-protect
        (progn
@@ -35,3 +51,19 @@
 	 (&body))
     (close-store)))
 
+(defmacro store-test (name &body body)
+  `(progn
+     ,@(iter
+	(for config in '((:suffix reopenings-no-snapshot :snapshot nil :bypass nil)
+			 (:suffix reopenings-with-snapshot :snapshot t :bypass nil)
+			 (:suffix nil :snapshot nil :bypass t)))
+	(for test-name = (if (getf config :suffix)
+			     (intern (format nil "~a.~a" name (getf config :suffix)))
+			     name))
+	(collect `(test ,test-name
+		    (with-fixture empty-store ()
+		      (let ((snapshot ,(getf config :snapshot))
+			    (bypass ,(getf config :bypass)))
+			(declare (ignorable snapshot bypass))
+			, at body)))))))
+