[bknr-cvs] ksprotte changed trunk/projects/bos/test/

[BKNR Commits]

Revision: 3422
Author: ksprotte
URL: http://bknr.net/trac/changeset/3422

quick fix to test delete-sat-layer-and-snapshot

U   trunk/projects/bos/test/fixtures.lisp
U   trunk/projects/bos/test/web/sat-tree.lisp

Modified: trunk/projects/bos/test/fixtures.lisp
===================================================================
--- trunk/projects/bos/test/fixtures.lisp	2008-07-10 13:37:33 UTC (rev 3421)
+++ trunk/projects/bos/test/fixtures.lisp	2008-07-10 14:31:04 UTC (rev 3422)
@@ -18,24 +18,28 @@
     `(let (,@(iter
 	      (for id-var in id-vars)
 	      (for store-object-var in store-object-vars)
-	      (collect `(,id-var (store-object-id ,store-object-var)))))
+	      (collect `(,id-var (when (and ,store-object-var
+                                            (not (object-destroyed-p ,store-object-var)))
+                                   (store-object-id ,store-object-var))))))
        (%reopen-store :snapshot ,snapshot)
        (setf ,@(iter
 		(for id-var in id-vars)
 		(for store-object-var in store-object-vars)
 		(collect store-object-var)
-		(collect `(find-store-object ,id-var)))))))
+		(collect `(when ,id-var (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)))))
+  `(let ((snapshot ,snapshot)
+         (bypass ,bypass))
+     (if bypass
+         (progn , at body)
+         (progn
+           ,@(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)

Modified: trunk/projects/bos/test/web/sat-tree.lisp
===================================================================
--- trunk/projects/bos/test/web/sat-tree.lisp	2008-07-10 13:37:33 UTC (rev 3421)
+++ trunk/projects/bos/test/web/sat-tree.lisp	2008-07-10 14:31:04 UTC (rev 3422)
@@ -1,19 +1,10 @@
 (in-package :bos.test)
 (in-suite :bos.test.web)
 
-(test delete-sat-layer-and-snapshot    
-  (with-fixture initial-bos-store ()
-    (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100)))))
-      (cl-gd:with-image (image 1000 1000)
+(store-test delete-sat-layer-and-snapshot
+  (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100)))))
+    (cl-gd:with-image (image 1000 1000)
+      (with-store-reopenings ()
         (bos.web::make-sat-layer image geo-box :test 0)
         (delete-object (first (class-instances 'bos.web::sat-layer)))
-        (finishes (snapshot))))))
-
-;; (store-test delete-sat-layer-and-snapshot.2 
-;;   (let ((geo-box (bos.web::rectangle-geo-box (bos.web::make-rectangle2 '(10 10 100 100)))))
-;;     (cl-gd:with-image (image 1000 1000)
-;;       (with-store-reopenings ()
-;;         (bos.web::make-sat-layer image geo-box :test 0)
-;;         (delete-object (first (class-instances 'bos.web::sat-layer)))
-;;         (pass)))))
-
+        (pass)))))