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