Author: ksprotte Date: Mon Jan 21 08:59:03 2008 New Revision: 2375

Modified: branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/test-fixtures.lisp Log: now using STORE-TEST + WITH-STORE-REOPENINGS to define tests

Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 08:59:03 2008 @@ -1,50 +1,56 @@ (in-package :bos.test) (in-suite :bos.test.allocation-area)

-(test allocation-area.none-at-startup - (with-fixture empty-store () - (is (null (class-instances 'bos.m2:allocation-area))))) +(store-test allocation-area.none-at-startup + (is (null (class-instances 'bos.m2:allocation-area))))

-(test allocation-area.no-intersection - (with-fixture empty-store () +(store-test allocation-area.no-intersection + (with-store-reopenings () (finishes (make-allocation-rectangle 0 0 100 100)) (signals (error) (make-allocation-rectangle 0 0 100 100))))

-(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)) +(store-test allocation-area.one-contract.no-cache + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor m2-count)) (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))

-(test allocation-area.one-contract.with-cache.1 - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 2 5)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count 10)) - (with-transaction () - (bos.m2::activate-allocation-area area)) +(store-test allocation-area.one-contract.with-cache.1 + (let ((area (make-allocation-rectangle 0 0 2 5)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count 10)) + (with-transaction () + (bos.m2::activate-allocation-area area)) + (with-store-reopenings (area sponsor) (finishes (allocation-area-free-m2s area)) - (is (= 1 (bos.m2.allocation-cache:free-regions-count))) - (reopen-store (:snapshot nil) area sponsor) + (is (= 1 (bos.m2.allocation-cache:free-regions-count))) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area))))))

-(test allocation-area.one-contract.allocate-all-without-cache - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 100 100)) - (sponsor (make-sponsor :login "test-sponsor")) - (m2-count (* 100 100))) +(store-test allocation-area.one-contract.allocate-all-without-cache + (let ((area (make-allocation-rectangle 0 0 100 100)) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-count (* 100 100))) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor m2-count)) (signals (error) (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area))))))

-(test allocation-area.one-contract.notany-m2-contract - (with-fixture empty-store () - (let ((area (make-allocation-rectangle 0 0 8 8)) - (sponsor (make-sponsor :login "test-sponsor"))) +(store-test allocation-area.one-contract.notany-m2-contract + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (with-store-reopenings (area sponsor) + (finishes (make-contract sponsor 10)) + (is (= (- 64 10) (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64))))) + +(store-test allocation-area.one-contract.notany-m2-contract + (let ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor"))) + (with-store-reopenings (area sponsor) (finishes (make-contract sponsor 10)) (is (= (- 64 10) (allocation-area-free-m2s area))) (signals (error) (make-contract sponsor 64)))))

Modified: branches/bos/projects/bos/m2/test-fixtures.lisp ============================================================================== --- branches/bos/projects/bos/m2/test-fixtures.lisp (original) +++ branches/bos/projects/bos/m2/test-fixtures.lisp Mon Jan 21 08:59:03 2008 @@ -26,6 +26,22 @@ (collect store-object-var) (collect `(find-store-object ,id-var)))))))

+(defmacro %with-store-reopenings ((&key snapshot bypass) + (&rest store-object-vars) &body body) + `(progn + ,@(if bypass + body + (iter + (for form in body) + (unless (first-time-p) + (collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) + (collect form))))) + +(defmacro with-store-reopenings ((&rest store-object-vars) &body body) + `(%with-store-reopenings (:snapshot snapshot :bypass bypass) + (,@store-object-vars) + ,@body)) + (def-fixture empty-store () (unwind-protect (progn @@ -35,3 +51,19 @@ (&body)) (close-store)))

+(defmacro store-test (name &body body) + `(progn + ,@(iter + (for config in '((:suffix reopenings-no-snapshot :snapshot nil :bypass nil) + (:suffix reopenings-with-snapshot :snapshot t :bypass nil) + (:suffix nil :snapshot nil :bypass t))) + (for test-name = (if (getf config :suffix) + (intern (format nil "~a.~a" name (getf config :suffix))) + name)) + (collect `(test ,test-name + (with-fixture empty-store () + (let ((snapshot ,(getf config :snapshot)) + (bypass ,(getf config :bypass))) + (declare (ignorable snapshot bypass)) + ,@body))))))) +