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

[BKNR Commits]

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

removed allocation-cache-subsystem; rebuild-allocation-cache is now called via the initialization-subsystem
invoke-transient-init-functions is more verbose

U   trunk/projects/bos/m2/allocation-cache.lisp
U   trunk/projects/bos/m2/initialization-subsystem.lisp
U   trunk/projects/bos/m2/m2.lisp
U   trunk/projects/bos/web/contract-tree.lisp

Modified: trunk/projects/bos/m2/allocation-cache.lisp
===================================================================
--- trunk/projects/bos/m2/allocation-cache.lisp	2008-07-25 12:53:57 UTC (rev 3637)
+++ trunk/projects/bos/m2/allocation-cache.lisp	2008-07-25 12:59:11 UTC (rev 3638)
@@ -231,9 +231,9 @@
 	(unless (zerop count)
 	  (format t "~5D~10T~5D~%" size count))))))
 
-(defun rebuild-cache ()
-  (assert (in-transaction-p) nil
-          "rebuild-cache may only be called in a transaction context")
+(defun rebuild-allocation-cache ()  
+  (assert (or (in-transaction-p) (eql :snapshot (store-state *store*))) nil
+          "rebuild-allocation-cache may only be called in a transaction context")  
   (unless *allocation-cache*
     (setq *allocation-cache* (make-allocation-cache)))
   (clear-cache)
@@ -241,6 +241,8 @@
     (when (allocation-area-active-p allocation-area)
       (add-area allocation-area))))
 
+(register-transient-init-function 'rebuild-allocation-cache)
+
 (defun suggest-free-region-size ()
   (iter
     (for regions in-vector (allocation-cache-index *allocation-cache*))
@@ -255,14 +257,3 @@
       (index-push (length m2s) (make-cache-entry :area allocation-area
                                                  :region m2s)))))
 
-;;; subsystem
-(defclass allocation-cache-subsystem ()
-  ())
-
-(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem)
-                                              &key until)
-  (declare (ignore until))
-  (rebuild-cache))
-
-(defmethod bknr.datastore::snapshot-subsystem (store (subsystem allocation-cache-subsystem))
-  )
\ No newline at end of file

Modified: trunk/projects/bos/m2/initialization-subsystem.lisp
===================================================================
--- trunk/projects/bos/m2/initialization-subsystem.lisp	2008-07-25 12:53:57 UTC (rev 3637)
+++ trunk/projects/bos/m2/initialization-subsystem.lisp	2008-07-25 12:59:11 UTC (rev 3638)
@@ -52,9 +52,11 @@
 
 (defun invoke-transient-init-functions ()
   (dolist (function-name *transient-init-functions*)
+    (format t "~&initialization-subsystem is calling ~A..." function-name)
     (with-simple-restart (skip-init-function "Skip transient-init-function ~A"
                                              function-name)
-      (funcall function-name))))
+      (funcall function-name))
+    (format t "done~%")))
 
 ;;; initialization-subsystem
 (defclass initialization-subsystem ()

Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp	2008-07-25 12:53:57 UTC (rev 3637)
+++ trunk/projects/bos/m2/m2.lisp	2008-07-25 12:59:11 UTC (rev 3638)
@@ -710,8 +710,7 @@
 		 :directory directory
 		 :subsystems (list (make-instance 'store-object-subsystem)
 				   (make-instance 'blob-subsystem
-						  :n-blobs-per-directory 1000)
-				   (make-instance 'bos.m2.allocation-cache:allocation-cache-subsystem)
+						  :n-blobs-per-directory 1000)				   
                                    (make-instance 'initialization-subsystem)))
   (format t "~&; Startup der Quadratmeterdatenbank done.~%")
   (force-output))

Modified: trunk/projects/bos/web/contract-tree.lisp
===================================================================
--- trunk/projects/bos/web/contract-tree.lisp	2008-07-25 12:53:57 UTC (rev 3637)
+++ trunk/projects/bos/web/contract-tree.lisp	2008-07-25 12:59:11 UTC (rev 3638)
@@ -357,14 +357,12 @@
                                        :name '*contract-tree*))
   (dolist (contract (class-instances 'contract))
     (when (contract-published-p contract)
-      (insert-contract *contract-tree* contract)))
-  (format t "~&rendering contract-tree images if needed...") (force-output)  
-  (format t "done.~%") (force-output)  
+      (insert-contract *contract-tree* contract)))    
   (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*
                                      (list 0 0 +width+ +width+)
                                      #'contract-tree-changed))
 
 (register-transient-init-function 'make-contract-tree-from-m2
-                                        'make-quad-tree
-                                        'geometry:make-rect-publisher)
+                                  'make-quad-tree
+                                  'geometry:make-rect-publisher)