Changeset 3423

Show
Ignore:
Timestamp:
07/10/08 17:41:02 (4 months ago)
Author:
ksprotte
Message:

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

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

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

    r3422 r3423  
    77      (with-store-reopenings () 
    88        (bos.web::make-sat-layer image geo-box :test 0) 
    9         (delete-object (first (class-instances 'bos.web::sat-layer))) 
     9        (progn 
     10          (bos.web::remove-sat-layer-from-quad-tree (find-store-object 1)) 
     11          (delete-object (first (class-instances 'bos.web::sat-layer)))) 
    1012        (pass))))) 

  • trunk/projects/bos/web/sat-tree.lisp

    r3421 r3423  
    33(defclass sat-node (node-extension) 
    44  ((image :accessor image :initarg :image))) 
    5  
    6 (defmethod delete-node-extension :before ((obj sat-node)) 
    7   (delete-object (image obj))) 
    85 
    96(defpersistent-class sat-layer () 
    …… 
    1916 
    2017(defmethod destroy-object :before ((obj sat-layer)) 
    21   ;; (dolist (top-level-node (sat-layer-top-level-nodes obj)) 
    22   ;;     (delete-node-extension top-level-node)) 
     18  (when (boundp '*quad-tree*) 
     19    ;; when the transaction log is being loaded, *quad-tree* is still 
     20    ;; unbound, because it is only initialized, when the entire store 
     21    ;; has been loaded -- an example for the fact that the quad-tree 
     22    ;; should have been implemented as a proper store index 
     23    (assert (null (sat-layer-top-level-nodes obj)) nil 
     24            "Please invoke (remove-sat-layer-from-quad-tree (find-store-object ~D)) before deleting ~s." 
     25            (store-object-id obj) obj)) 
    2326  (dolist (sat-image (class-instances 'sat-image)) 
    24     (delete-object sat-image))) 
     27    (when (eq obj (layer sat-image)) 
     28      (delete-object sat-image)))) 
     29 
     30(defun remove-sat-layer-from-quad-tree (sat-layer) 
     31  (let ((nodes (collect-nodes (constantly t) (first (sat-layer-top-level-nodes sat-layer))))) 
     32    (mapc #'delete-node-extension nodes) 
     33    (values))) 
    2534 
    2635(defun sat-layer-top-level-nodes (sat-layer) 
    …… 
    161170           (nodes (remove-if-not #'pw-ph-large-enough (layer-quad-nodes))) 
    162171           (max-scaling (max-scaling nodes))) 
    163       (format t "; creating ~a at depth ~a~%" name start-depth) 
     172      (format t "; creating ~a at depth ~a~%" name start-depth) ; 
    164173      (dolist (node nodes layer) 
    165174        (make-sat-image-tile image geo-box (quad-node node)