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

back out changeset 3682, too - this needs more thought 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-07-30 13:23:06 UTC (rev 3697) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 13:44:57 UTC (rev 3698) @@ -45,25 +45,22 @@ (call-next-method) (close-store)))

-(defvar *tests* (make-hash-table)) - (defmacro define-datastore-test (name &rest body) - `(setf (gethash ,name *tests*) - (make-instance 'datastore-test-class - :unit :datastore - :name ,name - :body (lambda () - ,@body)))) + `(make-instance 'datastore-test-class + :unit :datastore + :name ,name + :body (lambda () + ,@body)))

-(define-datastore-test :store-setup +(define-datastore-test "Datastore setup" (test-assert *test-datastore*))

-(define-datastore-test :create-object +(define-datastore-test "Create object" (let ((obj (make-object 'store-object))) (test-assert obj) (test-equal (list obj) (all-store-objects))))

-(define-datastore-test :create-multiple-objects +(define-datastore-test "Create multiple objects" (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -71,7 +68,7 @@ (test-equal (length (all-store-objects)) 2) (test-assert (subsetp (list o1 o2) (all-store-objects)))))

-(define-datastore-test :delete-multiple-objects +(define-datastore-test "Delete multiple objects" (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -83,23 +80,23 @@ (delete-object o2) (test-equal (all-store-objects) nil)))

-(define-datastore-test :restore +(define-datastore-test "Restore" (make-object 'store-object) (restore) (test-equal (length (all-store-objects)) 1))

-(define-datastore-test :snapshot-and-restore +(define-datastore-test "Snapshot and Restore" (make-object 'store-object) (snapshot) (restore) (test-equal (length (all-store-objects)) 1))

-(define-datastore-test :restore-multiple-objects +(define-datastore-test "Restore multiple objects" (dotimes (i 10) (make-object 'store-object)) (restore) (test-equal (length (all-store-objects)) 10))

-(define-datastore-test :snapshot-restore-multiple-objects +(define-datastore-test "Snapshot and Restore multiple objects" (dotimes (i 10) (make-object 'store-object)) (snapshot) (restore) @@ -107,7 +104,7 @@

(defconstant +stress-size+ 10000)

-(define-datastore-test :stress-test +(define-datastore-test "Stress test object creation" (format t "Creating ~a objects~%" +stress-size+) (time (bknr.datastore::without-sync () (dotimes (i +stress-size+) @@ -124,19 +121,10 @@ (define-persistent-class child () ())

-(define-datastore-test :serialize-circular-in-anon-txn +(define-datastore-test "Serialize circular dependency in anonymous txn" (let ((parent (make-object 'parent))) (with-transaction (:circular) (setf (parent-child parent) (make-object 'child)))) (restore) (test-equal (find-class 'child) - (class-of (parent-child (first (class-instances 'parent)))))) - -(define-datastore-test :delete-object-in-anon-txn - (let (object) - (with-transaction (:make) - (setf object (make-object 'child))) - (with-transaction (:delete) - (delete-object object)) - (restore) - (test-assert (object-destroyed-p object)))) \ No newline at end of file + (class-of (parent-child (first (class-instances 'parent)))))) \ No newline at end of file

Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 13:23:06 UTC (rev 3697) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 13:44:57 UTC (rev 3698) @@ -96,11 +96,11 @@

(defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) - (encode (make-instance 'transaction - :timestamp (get-universal-time) - :function-symbol 'tx-change-slot-values - :args (list object (slot-definition-name slotd) newval)) - (anonymous-transaction-log-buffer *current-transaction*)))) + (push (make-instance 'transaction + :timestamp (get-universal-time) + :function-symbol 'tx-change-slot-values + :args (list object (slot-definition-name slotd) newval)) + (anonymous-transaction-transactions *current-transaction*))))

(defmethod direct-slot-definition-class ((class persistent-class) &key &allow-other-keys) 'persistent-direct-slot-definition) @@ -195,17 +195,17 @@ (if (in-anonymous-transaction-p) (prog1 (call-next-method) - (encode (make-instance 'transaction - :function-symbol 'make-instance - :timestamp (get-universal-time) - :args (cons (class-name (class-of object)) - (loop for slotd in (class-slots (class-of object)) - for slot-name = (slot-definition-name slotd) - for slot-initarg = (first (slot-definition-initargs slotd)) - when (and slot-initarg - (slot-boundp object slot-name)) - appending (list slot-initarg (slot-value object slot-name))))) - (anonymous-transaction-log-buffer *current-transaction*))) + (push (make-instance 'transaction + :function-symbol 'make-instance + :timestamp (get-universal-time) + :args (cons (class-name (class-of object)) + (loop for slotd in (class-slots (class-of object)) + for slot-name = (slot-definition-name slotd) + for slot-initarg = (first (slot-definition-initargs slotd)) + when (and slot-initarg + (slot-boundp object slot-name)) + appending (list slot-initarg (slot-value object slot-name))))) + (anonymous-transaction-transactions *current-transaction*))) (call-next-method)))

(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) @@ -661,8 +661,7 @@ (destroy-object (store-object-with-id id)))

(defun delete-object (object) - (if (and (in-transaction-p) - (not (in-anonymous-transaction-p))) + (if (in-transaction-p) (destroy-object object) (execute (make-instance 'transaction :function-symbol 'tx-delete-object :timestamp (get-universal-time)

Modified: trunk/bknr/datastore/src/data/txn.lisp =================================================================== --- trunk/bknr/datastore/src/data/txn.lisp 2008-07-30 13:23:06 UTC (rev 3697) +++ trunk/bknr/datastore/src/data/txn.lisp 2008-07-30 13:44:57 UTC (rev 3698) @@ -10,67 +10,13 @@ (define-condition not-in-transaction (error) () (:documentation - "Signaled when an operation on persistent slots is executed outside - a transaction context")) + "Thrown when an operation on persistent slots is executed outside a transaction context"))

(define-condition store-not-open (error) () (:documentation - "Signaled when a transaction is executed on a store that is not - opened")) + "Thrown when a transaction is executed on a store that is not opened"))

-(define-condition store-already-open (error) - () - (:documentation - "Signaled when an attempt is made to open a store with another - store being open")) - -(define-condition invalid-store-random-state (error) - () - (:documentation - "Signaled when the on-disk store random state cannot be read, - typically because it has been written with another Lisp")) - -(define-condition unsupported-lambda-list-option (error) - ((option :initarg :option :reader option)) - (:documentation - "Signaled when DEFTRANSACTION is used with an unsupported option in - its lambda list")) - -(define-condition default-arguments-unsupported (error) - ((tx-name :initarg :tx-name :reader tx-name) - (argument :initarg :argument :reader argument)) - (:report (lambda (c stream) - (format stream "argument ~A defaulted in DEFTRANSACTION ~S" - (argument c) (tx-name c)))) - (:documentation - "Signaled when an argument in a DEFTRANSACTION definition has a - default declaration")) - -(define-condition undefined-transaction (error) - ((tx-name :initarg :tx-name :reader tx-name)) - (:report (lambda (c stream) - (format stream "undefined transaction ~A in transaction log, please ensure that all the necessary code is loaded." - (tx-name c)))) - (:documentation - "Signaled when a named transaction is loaded from the transaction - log and no matching function definition could be found")) - -(define-condition invalid-transaction-nesting (error) - () - (:documentation - "Signaled when WITH-TRANSACTION forms are nested.")) - -(define-condition anonymous-transaction-in-named-transaction (error) - () - (:documentation - "Signaled when an anonymous transaction is started from within a named transaction.")) - -(define-condition no-subsystems (error) - () - (:documentation - "Signaled when an attempt is made to snapshot a store without subsystems")) - ;;; store

(defvar *store*) @@ -128,7 +74,7 @@ (restart-case (when (and (boundp '*store*) *store*) - (error 'store-already-open)) + (error "A store is already opened.")) (close-store () :report "Close the opened store." (close-store))))) @@ -207,7 +153,7 @@ (read f) (error (e) (declare (ignore e)) - (error 'invalid-store-random-state)))) + (error "Invalid store random state")))) (initialize-store-random-state () :report "Initialize the random state of the store. Use this to reinitialize the random state of the store when porting over a @@ -299,7 +245,7 @@ (defun store-current-transaction () (if (in-transaction-p) *current-transaction* - (error 'not-in-transaction))) + (error "store-current-transaction called outside of a transaction")))

;;; All transactions are executed by an 'executor', which is the store ;;; itself or, in the case of a nested transaction, the parent @@ -316,7 +262,7 @@

(defmethod execute-transaction :before (executor transaction) (unless (store-open-p) - (error 'store-not-open))) + (error (make-condition 'store-not-open))))

(defmethod execute-transaction ((executor transaction) transaction) (execute-unlogged transaction)) @@ -371,7 +317,7 @@ (&optional) (&rest (setf args (cdr args))) ; skip argument, too (&key (setf in-keywords-p t)) - (otherwise (error 'unsupported-lambda-list-option :option arg)))) + (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) (t (when in-keywords-p (push (intern (symbol-name arg) :keyword) result)) @@ -389,7 +335,7 @@ (body body)) (dolist (arg args) (when (listp arg) - (error 'default-arguments-unsupported :tx-name name :argument (car arg)))) + (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) (let ((tx-name (intern (format nil "TX-~A" name) (symbol-package name)))) `(progn @@ -462,8 +408,8 @@ (with-store-guard () (let ((*current-transaction* transaction)) (apply (or (symbol-function (transaction-function-symbol transaction)) - (error 'undefined-transaction - :tx-name (transaction-function-symbol transaction))) + (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded." + (transaction-function-symbol transaction))) (transaction-args transaction)))))

(defun fsync (stream) @@ -490,7 +436,7 @@ (check-type transaction symbol) ; otherwise care for multiple evaluation `(with-store-guard () (when (in-transaction-p) - (error 'invalid-transaction-nesting)) + (error "can't open nested with-transaction-log blocks")) (with-store-state (:transaction) (prog1 (let ((*current-transaction* ,transaction)) @@ -526,54 +472,61 @@ ;;; The actual writing to the transaction log is performed by the ;;; with-transaction macro.

-;;; An anonymous transaction has a label which is stored in the -;;; transaction log in order to make the source code location where +;;; An anonymous transaction has an optional label which is stored in +;;; the transaction log in order to make the source code location where ;;; the actual transaction code lives identifieable.

(defclass anonymous-transaction (transaction) - ((label :initarg :label - :accessor anonymous-transaction-label - :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)))) + ((label :initarg :label :accessor anonymous-transaction-label) + (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) + (:default-initargs :transactions nil :label nil))

(defmethod print-object ((transaction anonymous-transaction) stream) (print-unreadable-object (transaction stream :type t) - (format stream "~A ~A (~A)" + (format stream "~A ~A ~A" (format-date-time (transaction-timestamp transaction)) (anonymous-transaction-label transaction) - (class-name (class-of (anonymous-transaction-log-buffer transaction)))))) + (anonymous-transaction-transactions transaction))))

(defmethod in-anonymous-transaction-p () (subtypep (type-of *current-transaction*) 'anonymous-transaction))

(defmethod encode-object ((transaction anonymous-transaction) stream) - (%write-tag #\N stream) - (%encode-string (anonymous-transaction-label transaction) stream) - (let ((subtxns (flex:get-output-stream-sequence (anonymous-transaction-log-buffer transaction)))) - (%encode-integer (length subtxns) stream) - (write-sequence subtxns stream))) + (cond + ((anonymous-transaction-label transaction) + (%write-tag #\N stream) + (%encode-string (anonymous-transaction-label transaction) stream)) + (t + (%write-tag #\G stream))) + (%encode-list (reverse (anonymous-transaction-transactions transaction)) stream))

+(defmethod decode-object ((tag (eql #\G)) stream) + (make-instance 'anonymous-transaction + :transactions (%decode-list stream))) + (defvar *txn-log-stream* nil "This variable is bound to the transaction log stream while loading the transaction log. It is used by anonymous transactions to read the subtransactions from the log.")

(defmethod decode-object ((tag (eql #\N)) stream) - (let* ((label (%decode-string stream)) - (length (%decode-integer stream)) - (buffer (make-array length :element-type '(unsigned-byte 8)))) - (read-sequence buffer stream) - (make-instance 'anonymous-transaction - :label label - :log-buffer (flex:make-in-memory-input-stream buffer)))) + ;; When decoding an anonymous transaction from the transaction log, + ;; we only read its name. The subtransaction are not read here, but + ;; rather in EXECUTE-UNLOGGED below. The reason for this is that we + ;; need to execute the subtransactions while reading them, as we'd + ;; otherwise not be able to properly deserialize references to + ;; objects that have been created within this anonymous transaction.

+ ;; Thus, while restoring, the TRANSACTIONS slot of the anonymous + ;; transaction object is not used. + (make-instance 'anonymous-transaction + :label (%decode-string stream))) + (defmacro with-transaction ((&optional label) &body body) (let ((txn (gensym))) `(progn (when (in-transaction-p) - (error 'anonymous-transaction-in-named-transaction)) + (error "tried to start anonymous transaction while in a transaction")) (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) (with-transaction-log (,txn) ,@body))))) @@ -584,14 +537,15 @@ ;; subtransactions from the transaction log. (assert (eq :restore (store-state *store*)) () "Unexpected store state ~A for EXECUTE-UNLOGGED on an anonymous transaction" (store-state *store*)) - (let ((stream (anonymous-transaction-log-buffer transaction))) - (handler-case - (loop - (execute-unlogged (decode stream))) - (end-of-file ())))) + (let ((subtxns (%decode-integer *txn-log-stream*))) + (dotimes (i subtxns) + (execute-unlogged (decode *txn-log-stream*))) + (when (plusp subtxns) + ;; In order to maintain the previous on-disk format, we read the last cdr of the list + (assert (eq nil (decode *txn-log-stream*))))))

-(defmethod execute-transaction :before ((executor anonymous-transaction) transaction) - (encode transaction (anonymous-transaction-log-buffer executor))) +(defmethod execute-transaction :after ((executor anonymous-transaction) transaction) + (push transaction (anonymous-transaction-transactions executor)))

;;; Subsystems

@@ -617,9 +571,9 @@

(defmethod snapshot-store ((store store)) (unless (store-open-p) - (error 'store-not-open)) + (error (make-condition 'store-not-open))) (when (null (store-subsystems store)) - (error 'no-subsystems)) + (error "Cannot snapshot store without subsystems...")) (ensure-store-current-directory store) (with-store-state (:read-only store) (with-store-guard ()