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))