Changeset 3698
- Timestamp:
- 07/30/08 15:44:57 (4 months ago)
- Files:
-
- trunk/bknr/datastore/src/data/object-tests.lisp (modified) (7 diffs)
- trunk/bknr/datastore/src/data/object.lisp (modified) (3 diffs)
- trunk/bknr/datastore/src/data/txn.lisp (modified) (15 diffs)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
trunk/bknr/datastore/src/data/object-tests.lisp
r3694 r3698 46 46 (close-store))) 47 47 48 (defvar *tests* (make-hash-table)) 48 (defmacro define-datastore-test (name &rest body) 49 `(make-instance 'datastore-test-class 50 :unit :datastore 51 :name ,name 52 :body (lambda () 53 ,@body))) 49 54 50 (defmacro define-datastore-test (name &rest body) 51 `(setf (gethash ,name *tests*) 52 (make-instance 'datastore-test-class 53 :unit :datastore 54 :name ,name 55 :body (lambda () 56 ,@body)))) 57 58 (define-datastore-test :store-setup 55 (define-datastore-test "Datastore setup" 59 56 (test-assert *test-datastore*)) 60 57 61 (define-datastore-test :create-object58 (define-datastore-test "Create object" 62 59 (let ((obj (make-object 'store-object))) 63 60 (test-assert obj) 64 61 (test-equal (list obj) (all-store-objects)))) 65 62 66 (define-datastore-test :create-multiple-objects63 (define-datastore-test "Create multiple objects" 67 64 (let ((o1 (make-object 'store-object)) 68 65 (o2 (make-object 'store-object))) … … 72 69 (test-assert (subsetp (list o1 o2) (all-store-objects))))) 73 70 74 (define-datastore-test :delete-multiple-objects71 (define-datastore-test "Delete multiple objects" 75 72 (let ((o1 (make-object 'store-object)) 76 73 (o2 (make-object 'store-object))) … … 84 81 (test-equal (all-store-objects) nil))) 85 82 86 (define-datastore-test :restore83 (define-datastore-test "Restore" 87 84 (make-object 'store-object) 88 85 (restore) 89 86 (test-equal (length (all-store-objects)) 1)) 90 87 91 (define-datastore-test :snapshot-and-restore88 (define-datastore-test "Snapshot and Restore" 92 89 (make-object 'store-object) 93 90 (snapshot) … … 95 92 (test-equal (length (all-store-objects)) 1)) 96 93 97 (define-datastore-test :restore-multiple-objects94 (define-datastore-test "Restore multiple objects" 98 95 (dotimes (i 10) (make-object 'store-object)) 99 96 (restore) 100 97 (test-equal (length (all-store-objects)) 10)) 101 98 102 (define-datastore-test :snapshot-restore-multiple-objects99 (define-datastore-test "Snapshot and Restore multiple objects" 103 100 (dotimes (i 10) (make-object 'store-object)) 104 101 (snapshot) … … 108 105 (defconstant +stress-size+ 10000) 109 106 110 (define-datastore-test :stress-test107 (define-datastore-test "Stress test object creation" 111 108 (format t "Creating ~a objects~%" +stress-size+) 112 109 (time (bknr.datastore::without-sync () … … 125 122 ()) 126 123 127 (define-datastore-test :serialize-circular-in-anon-txn124 (define-datastore-test "Serialize circular dependency in anonymous txn" 128 125 (let ((parent (make-object 'parent))) 129 126 (with-transaction (:circular) … … 132 129 (test-equal (find-class 'child) 133 130 (class-of (parent-child (first (class-instances 'parent)))))) 134 135 (define-datastore-test :delete-object-in-anon-txn136 (let (object)137 (with-transaction (:make)138 (setf object (make-object 'child)))139 (with-transaction (:delete)140 (delete-object object))141 (restore)142 (test-assert (object-destroyed-p object))))trunk/bknr/datastore/src/data/object.lisp
r3694 r3698 97 97 (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) 98 98 (when (in-anonymous-transaction-p) 99 ( encode(make-instance 'transaction100 101 102 103 (anonymous-transaction-log-buffer*current-transaction*))))99 (push (make-instance 'transaction 100 :timestamp (get-universal-time) 101 :function-symbol 'tx-change-slot-values 102 :args (list object (slot-definition-name slotd) newval)) 103 (anonymous-transaction-transactions *current-transaction*)))) 104 104 105 105 (defmethod direct-slot-definition-class ((class persistent-class) &key &allow-other-keys) … … 196 196 (prog1 197 197 (call-next-method) 198 ( encode(make-instance 'transaction199 200 201 202 203 204 205 206 207 208 (anonymous-transaction-log-buffer*current-transaction*)))198 (push (make-instance 'transaction 199 :function-symbol 'make-instance 200 :timestamp (get-universal-time) 201 :args (cons (class-name (class-of object)) 202 (loop for slotd in (class-slots (class-of object)) 203 for slot-name = (slot-definition-name slotd) 204 for slot-initarg = (first (slot-definition-initargs slotd)) 205 when (and slot-initarg 206 (slot-boundp object slot-name)) 207 appending (list slot-initarg (slot-value object slot-name))))) 208 (anonymous-transaction-transactions *current-transaction*))) 209 209 (call-next-method))) 210 210 … … 662 662 663 663 (defun delete-object (object) 664 (if (and (in-transaction-p) 665 (not (in-anonymous-transaction-p))) 664 (if (in-transaction-p) 666 665 (destroy-object object) 667 666 (execute (make-instance 'transaction :function-symbol 'tx-delete-object trunk/bknr/datastore/src/data/txn.lisp
r3682 r3698 11 11 () 12 12 (:documentation 13 "Signaled when an operation on persistent slots is executed outside 14 a transaction context")) 13 "Thrown when an operation on persistent slots is executed outside a transaction context")) 15 14 16 15 (define-condition store-not-open (error) 17 16 () 18 17 (:documentation 19 "Signaled when a transaction is executed on a store that is not 20 opened")) 21 22 (define-condition store-already-open (error) 23 () 24 (:documentation 25 "Signaled when an attempt is made to open a store with another 26 store being open")) 27 28 (define-condition invalid-store-random-state (error) 29 () 30 (:documentation 31 "Signaled when the on-disk store random state cannot be read, 32 typically because it has been written with another Lisp")) 33 34 (define-condition unsupported-lambda-list-option (error) 35 ((option :initarg :option :reader option)) 36 (:documentation 37 "Signaled when DEFTRANSACTION is used with an unsupported option in 38 its lambda list")) 39 40 (define-condition default-arguments-unsupported (error) 41 ((tx-name :initarg :tx-name :reader tx-name) 42 (argument :initarg :argument :reader argument)) 43 (:report (lambda (c stream) 44 (format stream "argument ~A defaulted in DEFTRANSACTION ~S" 45 (argument c) (tx-name c)))) 46 (:documentation 47 "Signaled when an argument in a DEFTRANSACTION definition has a 48 default declaration")) 49 50 (define-condition undefined-transaction (error) 51 ((tx-name :initarg :tx-name :reader tx-name)) 52 (:report (lambda (c stream) 53 (format stream "undefined transaction ~A in transaction log, please ensure that all the necessary code is loaded." 54 (tx-name c)))) 55 (:documentation 56 "Signaled when a named transaction is loaded from the transaction 57 log and no matching function definition could be found")) 58 59 (define-condition invalid-transaction-nesting (error) 60 () 61 (:documentation 62 "Signaled when WITH-TRANSACTION forms are nested.")) 63 64 (define-condition anonymous-transaction-in-named-transaction (error) 65 () 66 (:documentation 67 "Signaled when an anonymous transaction is started from within a named transaction.")) 68 69 (define-condition no-subsystems (error) 70 () 71 (:documentation 72 "Signaled when an attempt is made to snapshot a store without subsystems")) 18 "Thrown when a transaction is executed on a store that is not opened")) 73 19 74 20 ;;; store … … 129 75 (when (and (boundp '*store*) 130 76 *store*) 131 (error 'store-already-open))77 (error "A store is already opened.")) 132 78 (close-store () 133 79 :report "Close the opened store." … … 208 154 (error (e) 209 155 (declare (ignore e)) 210 (error 'invalid-store-random-state))))156 (error "Invalid store random state")))) 211 157 (initialize-store-random-state () 212 158 :report "Initialize the random state of the store. Use … … 300 246 (if (in-transaction-p) 301 247 *current-transaction* 302 (error 'not-in-transaction)))248 (error "store-current-transaction called outside of a transaction"))) 303 249 304 250 ;;; All transactions are executed by an 'executor', which is the store … … 317 263 (defmethod execute-transaction :before (executor transaction) 318 264 (unless (store-open-p) 319 (error 'store-not-open)))265 (error (make-condition 'store-not-open)))) 320 266 321 267 (defmethod execute-transaction ((executor transaction) transaction) … … 372 318 (&rest (setf args (cdr args))) ; skip argument, too 373 319 (&key (setf in-keywords-p t)) 374 (otherwise (error 'unsupported-lambda-list-option :optionarg))))320 (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) 375 321 (t 376 322 (when in-keywords-p … … 390 336 (dolist (arg args) 391 337 (when (listp arg) 392 (error 'default-arguments-unsupported :tx-name name :argument (car arg))))338 (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) 393 339 (let ((tx-name (intern (format nil "TX-~A" name) 394 340 (symbol-package name)))) … … 463 409 (let ((*current-transaction* transaction)) 464 410 (apply (or (symbol-function (transaction-function-symbol transaction)) 465 (error 'undefined-transaction466 :tx-name(transaction-function-symbol transaction)))411 (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded." 412 (transaction-function-symbol transaction))) 467 413 (transaction-args transaction))))) 468 414 … … 491 437 `(with-store-guard () 492 438 (when (in-transaction-p) 493 (error 'invalid-transaction-nesting))439 (error "can't open nested with-transaction-log blocks")) 494 440 (with-store-state (:transaction) 495 441 (prog1 … … 527 473 ;;; with-transaction macro. 528 474 529 ;;; An anonymous transaction has a label which is stored in the530 ;;; t ransaction log in order to make the source code location where475 ;;; An anonymous transaction has an optional label which is stored in 476 ;;; the transaction log in order to make the source code location where 531 477 ;;; the actual transaction code lives identifieable. 532 478 533 479 (defclass anonymous-transaction (transaction) 534 ((label :initarg :label 535 :accessor anonymous-transaction-label 536 :initform (error "missing label in anonymous transaction definition")) 537 (log-buffer :initarg :log-buffer 538 :accessor anonymous-transaction-log-buffer 539 :initform (flex:make-in-memory-output-stream)))) 480 ((label :initarg :label :accessor anonymous-transaction-label) 481 (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) 482 (:default-initargs :transactions nil :label nil)) 540 483 541 484 (defmethod print-object ((transaction anonymous-transaction) stream) 542 485 (print-unreadable-object (transaction stream :type t) 543 (format stream "~A ~A (~A)"486 (format stream "~A ~A ~A" 544 487 (format-date-time (transaction-timestamp transaction)) 545 488 (anonymous-transaction-label transaction) 546 ( class-name (class-of (anonymous-transaction-log-buffer transaction))))))489 (anonymous-transaction-transactions transaction)))) 547 490 548 491 (defmethod in-anonymous-transaction-p () … … 550 493 551 494 (defmethod encode-object ((transaction anonymous-transaction) stream) 552 (%write-tag #\N stream) 553 (%encode-string (anonymous-transaction-label transaction) stream) 554 (let ((subtxns (flex:get-output-stream-sequence (anonymous-transaction-log-buffer transaction)))) 555 (%encode-integer (length subtxns) stream) 556 (write-sequence subtxns stream))) 495 (cond 496 ((anonymous-transaction-label transaction) 497 (%write-tag #\N stream) 498 (%encode-string (anonymous-transaction-label transaction) stream)) 499 (t 500 (%write-tag #\G stream))) 501 (%encode-list (reverse (anonymous-transaction-transactions transaction)) stream)) 502 503 (defmethod decode-object ((tag (eql #\G)) stream) 504 (make-instance 'anonymous-transaction 505 :transactions (%decode-list stream))) 557 506 558 507 (defvar *txn-log-stream* nil … … 562 511 563 512 (defmethod decode-object ((tag (eql #\N)) stream) 564 (let* ((label (%decode-string stream)) 565 (length (%decode-integer stream)) 566 (buffer (make-array length :element-type '(unsigned-byte 8)))) 567 (read-sequence buffer stream) 568 (make-instance 'anonymous-transaction 569 :label label 570 :log-buffer (flex:make-in-memory-input-stream buffer)))) 513 ;; When decoding an anonymous transaction from the transaction log, 514 ;; we only read its name. The subtransaction are not read here, but 515 ;; rather in EXECUTE-UNLOGGED below. The reason for this is that we 516 ;; need to execute the subtransactions while reading them, as we'd 517 ;; otherwise not be able to properly deserialize references to 518 ;; objects that have been created within this anonymous transaction. 519 520 ;; Thus, while restoring, the TRANSACTIONS slot of the anonymous 521 ;; transaction object is not used. 522 (make-instance 'anonymous-transaction 523 :label (%decode-string stream))) 571 524 572 525 (defmacro with-transaction ((&optional label) &body body) … … 574 527 `(progn 575 528 (when (in-transaction-p) 576 (error 'anonymous-transaction-in-named-transaction))529 (error "tried to start anonymous transaction while in a transaction")) 577 530 (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) 578 531 (with-transaction-log (,txn) … … 585 538 (assert (eq :restore (store-state *store*)) () 586 539 "Unexpected store state ~A for EXECUTE-UNLOGGED on an anonymous transaction" (store-state *store*)) 587 (let ((stream (anonymous-transaction-log-buffer transaction))) 588 (handler-case 589 (loop 590 (execute-unlogged (decode stream))) 591 (end-of-file ())))) 592 593 (defmethod execute-transaction :before ((executor anonymous-transaction) transaction) 594 (encode transaction (anonymous-transaction-log-buffer executor))) 540 (let ((subtxns (%decode-integer *txn-log-stream*))) 541 (dotimes (i subtxns) 542 (execute-unlogged (decode *txn-log-stream*))) 543 (when (plusp subtxns) 544 ;; In order to maintain the previous on-disk format, we read the last cdr of the list 545 (assert (eq nil (decode *txn-log-stream*)))))) 546 547 (defmethod execute-transaction :after ((executor anonymous-transaction) transaction) 548 (push transaction (anonymous-transaction-transactions executor))) 595 549 596 550 ;;; Subsystems … … 618 572 (defmethod snapshot-store ((store store)) 619 573 (unless (store-open-p) 620 (error 'store-not-open))574 (error (make-condition 'store-not-open))) 621 575 (when (null (store-subsystems store)) 622 (error 'no-subsystems))576 (error "Cannot snapshot store without subsystems...")) 623 577 (ensure-store-current-directory store) 624 578 (with-store-state (:read-only store)
