Changeset 3682
- Timestamp:
- 07/29/08 22:25: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
r3038 r3682 46 46 (close-store))) 47 47 48 (defvar *tests* (make-hash-table)) 49 48 50 (defmacro define-datastore-test (name &rest body) 49 `(make-instance 'datastore-test-class 50 :unit :datastore 51 :name ,name 52 :body (lambda () 53 ,@body))) 51 `(setf (gethash ,name *tests*) 52 (make-instance 'datastore-test-class 53 :unit :datastore 54 :name ,name 55 :body (lambda () 56 ,@body)))) 54 57 55 (define-datastore-test "Datastore setup"58 (define-datastore-test :store-setup 56 59 (test-assert *test-datastore*)) 57 60 58 (define-datastore-test "Create object"61 (define-datastore-test :create-object 59 62 (let ((obj (make-object 'store-object))) 60 63 (test-assert obj) 61 64 (test-equal (list obj) (all-store-objects)))) 62 65 63 (define-datastore-test "Create multiple objects"66 (define-datastore-test :create-multiple-objects 64 67 (let ((o1 (make-object 'store-object)) 65 68 (o2 (make-object 'store-object))) … … 69 72 (test-assert (subsetp (list o1 o2) (all-store-objects))))) 70 73 71 (define-datastore-test "Delete multiple objects"74 (define-datastore-test :delete-multiple-objects 72 75 (let ((o1 (make-object 'store-object)) 73 76 (o2 (make-object 'store-object))) … … 81 84 (test-equal (all-store-objects) nil))) 82 85 83 (define-datastore-test "Restore"86 (define-datastore-test :restore 84 87 (make-object 'store-object) 85 88 (restore) 86 89 (test-equal (length (all-store-objects)) 1)) 87 90 88 (define-datastore-test "Snapshot and Restore"91 (define-datastore-test :snapshot-and-restore 89 92 (make-object 'store-object) 90 93 (snapshot) … … 92 95 (test-equal (length (all-store-objects)) 1)) 93 96 94 (define-datastore-test "Restore multiple objects"97 (define-datastore-test :restore-multiple-objects 95 98 (dotimes (i 10) (make-object 'store-object)) 96 99 (restore) 97 100 (test-equal (length (all-store-objects)) 10)) 98 101 99 (define-datastore-test "Snapshot and Restore multiple objects"102 (define-datastore-test :snapshot-restore-multiple-objects 100 103 (dotimes (i 10) (make-object 'store-object)) 101 104 (snapshot) … … 105 108 (defconstant +stress-size+ 10000) 106 109 107 (define-datastore-test "Stress test object creation"110 (define-datastore-test :stress-test 108 111 (format t "Creating ~a objects~%" +stress-size+) 109 112 (time (bknr.datastore::without-sync () … … 122 125 ()) 123 126 124 (define-datastore-test "Serialize circular dependency in anonymous txn"127 (define-datastore-test :serialize-circular-in-anon-txn 125 128 (let ((parent (make-object 'parent))) 126 129 (with-transaction (:circular) … … 129 132 (test-equal (find-class 'child) 130 133 (class-of (parent-child (first (class-instances 'parent)))))) 134 135 (define-datastore-test :delete-object-in-anon-txn 136 (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
r3680 r3682 97 97 (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) 98 98 (when (in-anonymous-transaction-p) 99 ( push(make-instance 'transaction100 :timestamp (get-universal-time)101 102 103 (anonymous-transaction-transactions*current-transaction*))))99 (encode (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-log-buffer *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 ( push(make-instance 'transaction199 200 201 202 203 204 205 206 207 208 (anonymous-transaction-transactions*current-transaction*)))198 (encode (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-log-buffer *current-transaction*))) 209 209 (call-next-method))) 210 210 … … 662 662 663 663 (defun delete-object (object) 664 (if (in-transaction-p) 664 (if (and (in-transaction-p) 665 (not (in-anonymous-transaction-p))) 665 666 (destroy-object object) 666 667 (execute (make-instance 'transaction :function-symbol 'tx-delete-object trunk/bknr/datastore/src/data/txn.lisp
r3450 r3682 11 11 () 12 12 (:documentation 13 "Thrown when an operation on persistent slots is executed outside a transaction context")) 13 "Signaled when an operation on persistent slots is executed outside 14 a transaction context")) 14 15 15 16 (define-condition store-not-open (error) 16 17 () 17 18 (:documentation 18 "Thrown when a transaction is executed on a store that is not opened")) 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")) 19 73 20 74 ;;; store … … 75 129 (when (and (boundp '*store*) 76 130 *store*) 77 (error "A store is already opened."))131 (error 'store-already-open)) 78 132 (close-store () 79 133 :report "Close the opened store." … … 154 208 (error (e) 155 209 (declare (ignore e)) 156 (error "Invalid store random state"))))210 (error 'invalid-store-random-state)))) 157 211 (initialize-store-random-state () 158 212 :report "Initialize the random state of the store. Use … … 246 300 (if (in-transaction-p) 247 301 *current-transaction* 248 (error "store-current-transaction called outside of a transaction")))302 (error 'not-in-transaction))) 249 303 250 304 ;;; All transactions are executed by an 'executor', which is the store … … 263 317 (defmethod execute-transaction :before (executor transaction) 264 318 (unless (store-open-p) 265 (error (make-condition 'store-not-open))))319 (error 'store-not-open))) 266 320 267 321 (defmethod execute-transaction ((executor transaction) transaction) … … 318 372 (&rest (setf args (cdr args))) ; skip argument, too 319 373 (&key (setf in-keywords-p t)) 320 (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION"arg))))374 (otherwise (error 'unsupported-lambda-list-option :option arg)))) 321 375 (t 322 376 (when in-keywords-p … … 336 390 (dolist (arg args) 337 391 (when (listp arg) 338 (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name)))392 (error 'default-arguments-unsupported :tx-name name :argument (car arg)))) 339 393 (let ((tx-name (intern (format nil "TX-~A" name) 340 394 (symbol-package name)))) … … 409 463 (let ((*current-transaction* transaction)) 410 464 (apply (or (symbol-function (transaction-function-symbol transaction)) 411 (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded."412 (transaction-function-symbol transaction)))465 (error 'undefined-transaction 466 :tx-name (transaction-function-symbol transaction))) 413 467 (transaction-args transaction))))) 414 468 … … 437 491 `(with-store-guard () 438 492 (when (in-transaction-p) 439 (error "can't open nested with-transaction-log blocks"))493 (error 'invalid-transaction-nesting)) 440 494 (with-store-state (:transaction) 441 495 (prog1 … … 473 527 ;;; with-transaction macro. 474 528 475 ;;; An anonymous transaction has a n optional label which is stored in476 ;;; t he transaction log in order to make the source code location where529 ;;; An anonymous transaction has a label which is stored in the 530 ;;; transaction log in order to make the source code location where 477 531 ;;; the actual transaction code lives identifieable. 478 532 479 533 (defclass anonymous-transaction (transaction) 480 ((label :initarg :label :accessor anonymous-transaction-label) 481 (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) 482 (:default-initargs :transactions nil :label nil)) 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)))) 483 540 484 541 (defmethod print-object ((transaction anonymous-transaction) stream) 485 542 (print-unreadable-object (transaction stream :type t) 486 (format stream "~A ~A ~A"543 (format stream "~A ~A (~A)" 487 544 (format-date-time (transaction-timestamp transaction)) 488 545 (anonymous-transaction-label transaction) 489 ( anonymous-transaction-transactions transaction))))546 (class-name (class-of (anonymous-transaction-log-buffer transaction)))))) 490 547 491 548 (defmethod in-anonymous-transaction-p () … … 493 550 494 551 (defmethod encode-object ((transaction anonymous-transaction) 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))) 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))) 506 557 507 558 (defvar *txn-log-stream* nil … … 511 562 512 563 (defmethod decode-object ((tag (eql #\N)) stream) 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))) 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)))) 524 571 525 572 (defmacro with-transaction ((&optional label) &body body) … … 527 574 `(progn 528 575 (when (in-transaction-p) 529 (error "tried to start anonymous transaction while in a transaction"))576 (error 'anonymous-transaction-in-named-transaction)) 530 577 (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) 531 578 (with-transaction-log (,txn) … … 538 585 (assert (eq :restore (store-state *store*)) () 539 586 "Unexpected store state ~A for EXECUTE-UNLOGGED on an anonymous transaction" (store-state *store*)) 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))) 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))) 549 595 550 596 ;;; Subsystems … … 572 618 (defmethod snapshot-store ((store store)) 573 619 (unless (store-open-p) 574 (error (make-condition 'store-not-open)))620 (error 'store-not-open)) 575 621 (when (null (store-subsystems store)) 576 (error "Cannot snapshot store without subsystems..."))622 (error 'no-subsystems)) 577 623 (ensure-store-current-directory store) 578 624 (with-store-state (:read-only store)
