Author: ksprotte Date: Mon Jan 21 07:40:18 2008 New Revision: 2374

Modified: branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/allocation.lisp branches/bos/projects/bos/m2/test-fixtures.lisp Log: Started some testing using REOPEN-STORE.

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 07:40:18 2008 @@ -25,7 +25,9 @@ (m2-count 10)) (with-transaction () (bos.m2::activate-allocation-area area)) + (finishes (allocation-area-free-m2s area)) (is (= 1 (bos.m2.allocation-cache:free-regions-count))) + (reopen-store (:snapshot nil) area sponsor) (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area))))))

Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Mon Jan 21 07:40:18 2008 @@ -46,10 +46,13 @@

(defmethod print-object ((allocation-area allocation-area) stream) (print-unreadable-object (allocation-area stream :type t) - (format stream "~a x ~a ~:[inactive~;active~] ID: ~a" + (format stream "~a x ~a ~:[inactive~;active~] free: ~s ID: ~a" (allocation-area-width allocation-area) (allocation-area-height allocation-area) (allocation-area-active-p allocation-area) + (if (slot-boundp allocation-area 'free-m2s) + (allocation-area-free-m2s allocation-area) + :unbound) (store-object-id allocation-area))))

(defmethod initialize-persistent-instance :after ((allocation-area allocation-area)) @@ -181,13 +184,13 @@ (null (allocation-area-free-m2s allocation-area))))) (all-allocation-areas)))

-(defun activate-allocation-area (area) +(deftransaction activate-allocation-area (area) (warn "activating ~S" area) (setf (slot-value area 'active-p) t) (bos.m2.allocation-cache:rebuild-cache) area)

-(defun deactivate-allocation-area (area) +(deftransaction deactivate-allocation-area (area) (warn "deactivating ~S" area) (setf (slot-value area 'active-p) nil) (bos.m2.allocation-cache:rebuild-cache)

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 07:40:18 2008 @@ -1,5 +1,31 @@ (in-package :bos.test)

+(defun %reopen-store (&key snapshot) + (format t "~&;; ++ reopen-store~%") + (when snapshot + (format t "~&;; ++ taking snapshot~%") + (snapshot)) + (bos.m2::reinit :directory (bknr.datastore::store-directory *store*) + :website-url bos.m2::*website-url*) + (format t "~&;; ++ reopen-store done~%")) + +(defmacro reopen-store ((&key snapshot) &body store-object-vars) + (let ((id-vars (iter + (with *print-case* = :upcase) + (for store-object-var in store-object-vars) + (for id-var = (gensym (format nil "~A-ID" store-object-var))) + (collect id-var)))) + `(let (,@(iter + (for id-var in id-vars) + (for store-object-var in store-object-vars) + (collect `(,id-var (store-object-id ,store-object-var))))) + (%reopen-store :snapshot ,snapshot) + (setf ,@(iter + (for id-var in id-vars) + (for store-object-var in store-object-vars) + (collect store-object-var) + (collect `(find-store-object ,id-var))))))) + (def-fixture empty-store () (unwind-protect (progn