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

[BKNR Commits]

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

fixed again sat-layer destroy-object, so that deleting a sat-layer is
possible without breaking the store

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

Modified: trunk/projects/bos/test/web/sat-tree.lisp
===================================================================
--- trunk/projects/bos/test/web/sat-tree.lisp	2008-07-10 14:31:04 UTC (rev 3422)
+++ trunk/projects/bos/test/web/sat-tree.lisp	2008-07-10 15:41:02 UTC (rev 3423)
@@ -6,5 +6,7 @@
     (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)))
+        (progn
+          (bos.web::remove-sat-layer-from-quad-tree (find-store-object 1))
+          (delete-object (first (class-instances 'bos.web::sat-layer))))
         (pass)))))

Modified: trunk/projects/bos/web/sat-tree.lisp
===================================================================
--- trunk/projects/bos/web/sat-tree.lisp	2008-07-10 14:31:04 UTC (rev 3422)
+++ trunk/projects/bos/web/sat-tree.lisp	2008-07-10 15:41:02 UTC (rev 3423)
@@ -3,9 +3,6 @@
 (defclass sat-node (node-extension)
   ((image :accessor image :initarg :image)))
 
-(defmethod delete-node-extension :before ((obj sat-node))
-  (delete-object (image obj)))
-
 (defpersistent-class sat-layer ()
   ((name :reader name :initarg :name
          :index-type unique-index
@@ -18,11 +15,23 @@
     (format stream "name: ~s" (name obj))))
 
 (defmethod destroy-object :before ((obj sat-layer))
-  ;; (dolist (top-level-node (sat-layer-top-level-nodes obj))
-  ;;     (delete-node-extension top-level-node))
+  (when (boundp '*quad-tree*)
+    ;; when the transaction log is being loaded, *quad-tree* is still
+    ;; unbound, because it is only initialized, when the entire store
+    ;; has been loaded -- an example for the fact that the quad-tree
+    ;; should have been implemented as a proper store index
+    (assert (null (sat-layer-top-level-nodes obj)) nil
+            "Please invoke (remove-sat-layer-from-quad-tree (find-store-object ~D)) before deleting ~s."
+            (store-object-id obj) obj))
   (dolist (sat-image (class-instances 'sat-image))
-    (delete-object sat-image)))
+    (when (eq obj (layer sat-image))
+      (delete-object sat-image))))
 
+(defun remove-sat-layer-from-quad-tree (sat-layer)
+  (let ((nodes (collect-nodes (constantly t) (first (sat-layer-top-level-nodes sat-layer)))))
+    (mapc #'delete-node-extension nodes)
+    (values)))
+
 (defun sat-layer-top-level-nodes (sat-layer)
   (check-type sat-layer sat-layer)
   (let ((nodes ())
@@ -160,7 +169,7 @@
     (let* ((name (name layer))
            (nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes)))
            (max-scaling (max-scaling nodes)))
-      (format t "; creating ~a at depth ~a~%" name start-depth)
+      (format t "; creating ~a at depth ~a~%" name start-depth) ;
       (dolist (node nodes layer)
         (make-sat-image-tile image geo-box (quad-node node)
                              (tile-geo-box node) name max-scaling))