[bknr-cvs] hans changed trunk/bknr/datastore/src/data/

[BKNR Commits]

Revision: 3946
Author: hans
URL: http://bknr.net/trac/changeset/3946

Implement rollback for anonymous transactions.  All slot changes
made in a transaction will be undone when an error is signalled
from within the transaction.  As changes to the ID slots of created
objects are undone as well, objects created in the transaction will
be removed from their indices and eventually garbage collected.

U   trunk/bknr/datastore/src/data/object-tests.lisp
U   trunk/bknr/datastore/src/data/object.lisp
U   trunk/bknr/datastore/src/data/txn.lisp

Modified: trunk/bknr/datastore/src/data/object-tests.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object-tests.lisp	2008-09-22 19:18:24 UTC (rev 3945)
+++ trunk/bknr/datastore/src/data/object-tests.lisp	2008-09-22 22:24:04 UTC (rev 3946)
@@ -277,5 +277,16 @@
          (o2 (make-instance 'inherit-multiple :child o1)))
     (test-equal o1 (parent-child o2))))
 
+(defdstest abort-anonymous-transaction ()
+  (let (parent)
+    (with-transaction (:initial)
+      (setf parent (make-instance 'parent :child nil)))
+    (ignore-errors
+      (with-transaction (:abort)
+        (setf (parent-child parent) (make-instance 'child))
+        (error "abort")))
+    (test-equal nil (parent-child parent))
+    (test-equal nil (class-instances 'child))))
+
 (defun run-datastore-test (name)
   (unit-test:run-test (gethash name *tests*)))

Modified: trunk/bknr/datastore/src/data/object.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object.lisp	2008-09-22 19:18:24 UTC (rev 3945)
+++ trunk/bknr/datastore/src/data/object.lisp	2008-09-22 22:24:04 UTC (rev 3946)
@@ -101,6 +101,11 @@
 another persistent object and the pointed-to object is deleted, slot
 reads will return nil."))
 
+(defun undo-set-slot (object slot-name value)
+  (if (eq value 'unbound)
+      (slot-makunbound object slot-name)
+      (setf (slot-value object slot-name) value)))
+
 (defmethod (setf slot-value-using-class) :before ((newval t)
                                                   (class persistent-class)
                                                   object
@@ -110,6 +115,14 @@
       (unless (or (in-transaction-p)
                   (member slot-name '(last-change id)))
         (error 'persistent-slot-modified-outside-of-transaction :slot-name slot-name :object object))
+      (when (in-anonymous-transaction-p)
+        (push (list #'undo-set-slot
+                    object
+                    (slot-definition-name slotd)
+                    (if (slot-boundp object (slot-definition-name slotd))
+                        (slot-value object (slot-definition-name slotd))
+                        'unbound))
+              (anonymous-transaction-undo-log *current-transaction*)))
       (when (and (not (eq :restore (store-state *store*)))
                  (not (member slot-name '(last-change id))))
         (setf (slot-value object 'last-change) (current-transaction-timestamp))))))

Modified: trunk/bknr/datastore/src/data/txn.lisp
===================================================================
--- trunk/bknr/datastore/src/data/txn.lisp	2008-09-22 19:18:24 UTC (rev 3945)
+++ trunk/bknr/datastore/src/data/txn.lisp	2008-09-22 22:24:04 UTC (rev 3946)
@@ -64,10 +64,10 @@
   (:documentation
    "Signaled when WITH-TRANSACTION forms are nested."))
 
-(define-condition anonymous-transaction-in-named-transaction (store-error)
+(define-condition anonymous-transaction-in-transaction (store-error)
   ()
   (:documentation
-   "Signaled when an anonymous transaction is started from within a named transaction."))
+   "Signaled when an anonymous transaction is started from within another transaction, transactions do not nest."))
 
 (define-condition no-subsystems (store-error)
   ()
@@ -555,7 +555,9 @@
           :initform (error "missing label in anonymous transaction definition"))
    (log-buffer :initarg :log-buffer
                :accessor anonymous-transaction-log-buffer
-               :initform (flex:make-in-memory-output-stream))))
+               :initform (flex:make-in-memory-output-stream))
+   (undo-log :initform nil
+             :accessor anonymous-transaction-undo-log)))
 
 (defmethod print-object ((transaction anonymous-transaction) stream)
   (print-unreadable-object (transaction stream :type t)
@@ -592,14 +594,38 @@
                    :label label
                    :log-buffer (flex:make-in-memory-input-stream buffer))))
 
+(define-condition rollback-failed (error)
+  ((transaction :initarg transaction)
+   (original-error :initarg :original-error))
+  (:report (lambda (e stream)
+             (with-slots (transaction original-error) e
+               (format stream "Rollback of transaction ~A failed: ~A" transaction original-error)))))
+
+(defun anonymous-transaction-undo (transaction)
+  (handler-case
+      (dolist (command (anonymous-transaction-undo-log transaction))
+        (apply (car command) (cdr command)))
+    (error (e)
+      (error 'rollback-failed
+             :transaction transaction
+             :original-error e))))
+
+(defun do-with-transaction (label thunk)
+  (when (in-transaction-p)
+    (error 'anonymous-transaction-in-transaction))
+  (let ((txn (make-instance 'anonymous-transaction :label label))
+        (next-object-id (next-object-id (store-object-subsystem))))
+    (with-transaction-log (txn)
+      (handler-case
+          (funcall thunk)
+        (error (e)
+          (setf (next-object-id (store-object-subsystem)) next-object-id)
+          (anonymous-transaction-undo txn)
+          (error e))))))
+
 (defmacro with-transaction ((&optional label) &body body)
-  (let ((txn (gensym)))
-    `(progn
-       (when (in-transaction-p)
- 	 (error 'anonymous-transaction-in-named-transaction))
-       (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label))))
-         (with-transaction-log (,txn)
-           , at body)))))
+  `(do-with-transaction ,(if (symbolp label) (symbol-name label) label)
+     (lambda () , at body)))
 
 (defmethod execute-unlogged ((transaction anonymous-transaction))
   ;; EXECUTE-UNLOGGED is called for anonymous transactions only when