[bknr-cvs] r2357 - in branches/bos/projects/bos: m2 test

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Fri Jan 18 11:44:59 2008
New Revision: 2357

Modified:
   branches/bos/projects/bos/m2/allocation-cache.lisp
   branches/bos/projects/bos/m2/bos.m2.asd
   branches/bos/projects/bos/m2/m2.lisp
   branches/bos/projects/bos/m2/packages.lisp
   branches/bos/projects/bos/test/allocation-area.lisp
   branches/bos/projects/bos/test/fixtures.lisp
Log:
added allocation-cache-subsystem

Modified: branches/bos/projects/bos/m2/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-cache.lisp	(original)
+++ branches/bos/projects/bos/m2/allocation-cache.lisp	Fri Jan 18 11:44:59 2008
@@ -183,3 +183,11 @@
     (unless (zerop region-count)
       (leave size))))
 
+;;; subsystem
+(defclass allocation-cache-subsystem ()
+  ())
+
+(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) &key until)
+  (declare (ignore until))
+  (rebuild-cache))
+

Modified: branches/bos/projects/bos/m2/bos.m2.asd
==============================================================================
--- branches/bos/projects/bos/m2/bos.m2.asd	(original)
+++ branches/bos/projects/bos/m2/bos.m2.asd	Fri Jan 18 11:44:59 2008
@@ -1,21 +1,21 @@
 (in-package :cl-user)
 
 (asdf:defsystem :bos.m2
-    :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate)
-    :components ((:file "packages")
-		 (:file "config" :depends-on ("packages"))
-		 (:file "utils" :depends-on ("config"))
-		 (:file "news" :depends-on ("poi"))
-		 (:file "tiled-index" :depends-on ("config"))
-		 (:file "mail-generator" :depends-on ("config"))
-		 (:file "make-certificate" :depends-on ("config"))
-                 (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator"))
-		 (:file "contract-expiry" :depends-on ("m2"))
-                 (:file "allocation" :depends-on ("m2"))
-		 (:file "allocation-cache" :depends-on ("packages"))
-		 (:file "poi" :depends-on ("utils" "allocation"))
-                 (:file "bitmap" :depends-on ("allocation"))
-                 (:file "import" :depends-on ("m2"))
-                 (:file "map" :depends-on ("m2" "allocation"))
-                 (:file "export" :depends-on ("m2"))
-		 (:file "cert-daemon" :depends-on ("config"))))
+  :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate)
+  :components ((:file "packages")
+	       (:file "config" :depends-on ("packages"))
+	       (:file "utils" :depends-on ("config"))
+	       (:file "news" :depends-on ("poi"))
+	       (:file "tiled-index" :depends-on ("config"))
+	       (:file "mail-generator" :depends-on ("config"))
+	       (:file "make-certificate" :depends-on ("config"))
+	       (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator"))
+	       (:file "contract-expiry" :depends-on ("m2"))
+	       (:file "allocation" :depends-on ("m2"))
+	       (:file "allocation-cache" :depends-on ("packages"))
+	       (:file "poi" :depends-on ("utils" "allocation"))
+	       (:file "bitmap" :depends-on ("allocation"))
+	       (:file "import" :depends-on ("m2"))
+	       (:file "map" :depends-on ("m2" "allocation"))
+	       (:file "export" :depends-on ("m2"))
+	       (:file "cert-daemon" :depends-on ("config"))))

Modified: branches/bos/projects/bos/m2/m2.lisp
==============================================================================
--- branches/bos/projects/bos/m2/m2.lisp	(original)
+++ branches/bos/projects/bos/m2/m2.lisp	Fri Jan 18 11:44:59 2008
@@ -462,7 +462,8 @@
 		 :directory directory
 		 :subsystems (list (make-instance 'store-object-subsystem)
 				   (make-instance 'blob-subsystem
-						  :n-blobs-per-directory 1000)))
+						  :n-blobs-per-directory 1000)
+				   (make-instance 'bos.m2.allocation-cache:allocation-cache-subsystem)))
   (format t "~&; Startup der Quadratmeterdatenbank done.~%")
   (force-output))
 
@@ -473,5 +474,7 @@
      while (and (or (null percentage)
 		    (< (allocation-area-percent-used (first (class-instances 'allocation-area))) percentage))
 		(make-contract sponsor
-			       (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30)))
+			       (random-elt (cons (1+ (random 300))
+						 '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10
+						   10 10 10 10 10 30 30 30)))
 			       :paidp t))))
\ No newline at end of file

Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp	(original)
+++ branches/bos/projects/bos/m2/packages.lisp	Fri Jan 18 11:44:59 2008
@@ -233,5 +233,6 @@
 	   #:add-area
 	   #:free-regions-count
 	   #:free-regions-pprint
-	   #:rebuild-cache))
+	   #:rebuild-cache
+	   #:allocation-cache-subsystem))
 

Modified: branches/bos/projects/bos/test/allocation-area.lisp
==============================================================================
--- branches/bos/projects/bos/test/allocation-area.lisp	(original)
+++ branches/bos/projects/bos/test/allocation-area.lisp	Fri Jan 18 11:44:59 2008
@@ -10,10 +10,19 @@
     (finishes (make-allocation-rectangle 0 0 100 100))
     (signals (error) (make-allocation-rectangle 0 0 100 100))))
 
-(test allocation-area.one-contract
+(test allocation-area.one-contract.no-cache
   (with-fixture empty-store ()
     (let ((area (make-allocation-rectangle 0 0 100 100))
 	  (sponsor (make-sponsor :login "test-sponsor"))
 	  (m2-count 10))
-      (finishes (make-contract sponsor m2-count)))))
+      (finishes (make-contract sponsor m2-count))
+      (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))
+
+(test allocation-area.one-contract.with-cache
+  (with-fixture empty-store ()
+    (let ((area (make-allocation-rectangle 0 0 2 5))
+	  (sponsor (make-sponsor :login "test-sponsor"))
+	  (m2-count 10))
+      (finishes (make-contract sponsor m2-count))
+      (is (zerop (allocation-area-free-m2s area))))))
 

Modified: branches/bos/projects/bos/test/fixtures.lisp
==============================================================================
--- branches/bos/projects/bos/test/fixtures.lisp	(original)
+++ branches/bos/projects/bos/test/fixtures.lisp	Fri Jan 18 11:44:59 2008
@@ -1,10 +1,11 @@
 (in-package :bos.test)
 
-(def-fixture empty-store ()
-  (bos.m2::reinit :delete t
-		  :directory #p"/tmp/test-store.tmp/"
-		  :website-url bos.m2::*website-url*)
+(def-fixture empty-store ()  
   (unwind-protect
-       (&body)
+       (progn
+	 (bos.m2::reinit :delete t
+			 :directory #p"/tmp/test-store.tmp/"
+			 :website-url bos.m2::*website-url*)
+	 (&body))
     (close-store)))