[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/object

[BKNR Commits]

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