[bknr-cvs] hans changed trunk/bknr/datastore/src/data/
BKNR Commits
bknr at bknr.net
Wed Jul 30 13:44:57 UTC 2008
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 ()
- , at body))))
+ `(make-instance 'datastore-test-class
+ :unit :datastore
+ :name ,name
+ :body (lambda ()
+ , at 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)
, at 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 ()
More information about the Bknr-cvs
mailing list