Revision: 3940 Author: hans URL: http://bknr.net/trac/changeset/3940
Store next object id to use in snapshot file. This removes the previous buggy behaviour that the store would re-use an object IDs of objects deleted right before the snapshot has been written.
U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp
Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 18:31:17 UTC (rev 3939) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 18:33:13 UTC (rev 3940) @@ -54,15 +54,19 @@ (defvar *tests* (make-hash-table))
(defun do-run-test (thunk) - (let ((bknr.datastore::*store-verbose* nil) - initial-objects) + "Run the test in THUNK, then verify that the store contains the +`same' objects after a restore and after snapshot and a restore." + (let ((bknr.datastore::*store-verbose* nil) initial-objects) (funcall thunk) - (setf initial-objects (object-classes-and-ids)) - (restore) - (test-equal initial-objects (object-classes-and-ids)) - (snapshot) - (restore) - (test-equal initial-objects (object-classes-and-ids)))) + (let ((next-object-id (bknr.datastore::next-object-id (bknr.datastore::store-object-subsystem)))) + (setf initial-objects (object-classes-and-ids)) + (restore) + (test-equal initial-objects (object-classes-and-ids)) + (test-equal next-object-id (bknr.datastore::next-object-id (bknr.datastore::store-object-subsystem))) + (snapshot) + (restore) + (test-equal initial-objects (object-classes-and-ids)) + (test-equal next-object-id (bknr.datastore::next-object-id (bknr.datastore::store-object-subsystem))))))
(defmacro defdstest (name args &body body) (when args @@ -150,6 +154,13 @@ (time (map-store-objects #'delete-object)) (test-equal (all-store-objects) nil)))
+(defdstest holes-test () + (dotimes (i +stress-size+) + (let ((delete (zerop (random 2)))) + (with-transaction (:foo) + (funcall (if delete #'delete-object #'identity) + (make-instance 'store-object)))))) + (defdstest make-instance-in-anon-txn () (with-transaction () (make-instance 'store-object)) @@ -228,14 +239,7 @@ (restore) (test-assert (< object-id (store-object-id (make-instance 'store-object))))))
-#+(or) (defdstest delete-object-and-check-object-id-of-next-3 () -;; This test currently fails: The store has no explicit knowledge of -;; the object ID that it created. Instead, the next free object ID is -;; determined during restore by looking at the IDs of the objects -;; being restored. If the last object that has been created is -;; deleted right before the snapshot is written, the next object after -;; a restore will receive the same ID. (let (object-id) (with-transaction (:make) (let ((object (make-instance 'store-object)))
Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 18:31:17 UTC (rev 3939) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 18:33:13 UTC (rev 3940) @@ -498,7 +498,8 @@ (when class (let ((object (allocate-instance class))) (setf (slot-value object 'id) object-id - (next-object-id (store-object-subsystem)) (1+ object-id)) + (next-object-id (store-object-subsystem)) (max (1+ object-id) + (next-object-id (store-object-subsystem)))) (dolist (index (class-slot-indices class 'id)) (index-add index object)))))))
@@ -590,6 +591,10 @@ id slot-name (type-of container) (if container (store-object-id container) "unknown object"))))))
+(defun encode-current-object-id (stream) + (%write-tag #\I stream) + (%encode-integer (next-object-id (store-object-subsystem)) stream)) + (defmethod snapshot-subsystem ((store store) (subsystem store-object-subsystem)) (let ((snapshot (store-subsystem-snapshot-pathname store subsystem))) (with-open-file (s snapshot @@ -600,6 +605,7 @@ (let ((class-layouts (make-hash-table))) (with-transaction (:prepare-for-snapshot) (map-store-objects #'prepare-for-snapshot)) + (encode-current-object-id s) (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object) (encode-create-object class-layouts object s)))) (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object) @@ -644,10 +650,11 @@ (report-progress "~A of ~A objects initialized.~%" read-slots created-objects) (force-output)) (let ((char (%read-tag s nil nil))) - (unless (member char '(#\O #\L #\S nil)) + (unless (member char '(#\I #\L #\O #\S nil)) (error "unknown char ~A at offset ~A~%" char (file-position s))) (ecase char ((nil) (return)) + (#\I (setf (next-object-id (store-object-subsystem)) (%decode-integer s))) (#\L (snapshot-read-layout s class-layouts)) (#\O (snapshot-read-object s class-layouts) (incf created-objects)) (#\S (snapshot-read-slots s class-layouts) (incf read-slots))))))