bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/object
by BKNR Commits 22 Sep '08

22 Sep '08

Revision: 3940 Author: hans URL: http://bknr.net/trac/changeset/3940 Store next object id to use in snapshot file. This removes the previous buggy behaviour that the store would re-use an object IDs of objects deleted right before the snapshot has been written. U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 18:31:17 UTC (rev 3939) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 18:33:13 UTC (rev 3940) @@ -54,15 +54,19 @@ (defvar *tests* (make-hash-table)) (defun do-run-test (thunk) - (let ((bknr.datastore::*store-verbose* nil) - initial-objects) + "Run the test in THUNK, then verify that the store contains the +`same' objects after a restore and after snapshot and a restore." + (let ((bknr.datastore::*store-verbose* nil) initial-objects) (funcall thunk) - (setf initial-objects (object-classes-and-ids)) - (restore) - (test-equal initial-objects (object-classes-and-ids)) - (snapshot) - (restore) - (test-equal initial-objects (object-classes-and-ids)))) + (let ((next-object-id (bknr.datastore::next-object-id (bknr.datastore::store-object-subsystem)))) + (setf initial-objects (object-classes-and-ids)) + (restore) + (test-equal initial-objects (object-classes-and-ids)) + (test-equal next-object-id (bknr.datastore::next-object-id (bknr.datastore::store-object-subsystem))) + (snapshot) + (restore) + (test-equal initial-objects (object-classes-and-ids)) + (test-equal next-object-id (bknr.datastore::next-object-id (bknr.datastore::store-object-subsystem)))))) (defmacro defdstest (name args &body body) (when args @@ -150,6 +154,13 @@ (time (map-store-objects #'delete-object)) (test-equal (all-store-objects) nil))) +(defdstest holes-test () + (dotimes (i +stress-size+) + (let ((delete (zerop (random 2)))) + (with-transaction (:foo) + (funcall (if delete #'delete-object #'identity) + (make-instance 'store-object)))))) + (defdstest make-instance-in-anon-txn () (with-transaction () (make-instance 'store-object)) @@ -228,14 +239,7 @@ (restore) (test-assert (< object-id (store-object-id (make-instance 'store-object)))))) -#+(or) (defdstest delete-object-and-check-object-id-of-next-3 () -;; This test currently fails: The store has no explicit knowledge of -;; the object ID that it created. Instead, the next free object ID is -;; determined during restore by looking at the IDs of the objects -;; being restored. If the last object that has been created is -;; deleted right before the snapshot is written, the next object after -;; a restore will receive the same ID. (let (object-id) (with-transaction (:make) (let ((object (make-instance 'store-object))) Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 18:31:17 UTC (rev 3939) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 18:33:13 UTC (rev 3940) @@ -498,7 +498,8 @@ (when class (let ((object (allocate-instance class))) (setf (slot-value object 'id) object-id - (next-object-id (store-object-subsystem)) (1+ object-id)) + (next-object-id (store-object-subsystem)) (max (1+ object-id) + (next-object-id (store-object-subsystem)))) (dolist (index (class-slot-indices class 'id)) (index-add index object))))))) @@ -590,6 +591,10 @@ id slot-name (type-of container) (if container (store-object-id container) "unknown object")))))) +(defun encode-current-object-id (stream) + (%write-tag #\I stream) + (%encode-integer (next-object-id (store-object-subsystem)) stream)) + (defmethod snapshot-subsystem ((store store) (subsystem store-object-subsystem)) (let ((snapshot (store-subsystem-snapshot-pathname store subsystem))) (with-open-file (s snapshot @@ -600,6 +605,7 @@ (let ((class-layouts (make-hash-table))) (with-transaction (:prepare-for-snapshot) (map-store-objects #'prepare-for-snapshot)) + (encode-current-object-id s) (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object) (encode-create-object class-layouts object s)))) (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object) @@ -644,10 +650,11 @@ (report-progress "~A of ~A objects initialized.~%" read-slots created-objects) (force-output)) (let ((char (%read-tag s nil nil))) - (unless (member char '(#\O #\L #\S nil)) + (unless (member char '(#\I #\L #\O #\S nil)) (error "unknown char ~A at offset ~A~%" char (file-position s))) (ecase char ((nil) (return)) + (#\I (setf (next-object-id (store-object-subsystem)) (%decode-integer s))) (#\L (snapshot-read-layout s class-layouts)) (#\O (snapshot-read-object s class-layouts) (incf created-objects)) (#\S (snapshot-read-slots s class-layouts) (incf read-slots))))))

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/user.lisp
by BKNR Commits 22 Sep '08

22 Sep '08

Revision: 3939 Author: hans URL: http://bknr.net/trac/changeset/3939 Oops, we certainly did not want to have defined a primary method for inititialize-instance on user objects. U branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/user.lisp Modified: branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/user.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/user.lisp 2008-09-22 18:23:36 UTC (rev 3938) +++ branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/user.lisp 2008-09-22 18:31:17 UTC (rev 3939) @@ -60,7 +60,7 @@ (user-login object) "unbound")))) -(defmethod initialize-instance ((user user) &key) +(defmethod initialize-instance :after ((user user) &key) (let* ((plaintext-password (slot-value user 'password)) (password (when plaintext-password (crypt-md5 plaintext-password (make-salt))))) (setf (slot-value user 'password) password)))

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/projects/bos/
by BKNR Commits 22 Sep '08

22 Sep '08

Revision: 3938 Author: hans URL: http://bknr.net/trac/changeset/3938 Application fixes for BOS to make it work with the recent store updates. U branches/anon-transaction-fixes-2/projects/bos/m2/allocation.lisp U branches/anon-transaction-fixes-2/projects/bos/m2/poi.lisp U branches/anon-transaction-fixes-2/projects/bos/web/daily.lisp Modified: branches/anon-transaction-fixes-2/projects/bos/m2/allocation.lisp =================================================================== --- branches/anon-transaction-fixes-2/projects/bos/m2/allocation.lisp 2008-09-22 15:51:49 UTC (rev 3937) +++ branches/anon-transaction-fixes-2/projects/bos/m2/allocation.lisp 2008-09-22 18:23:36 UTC (rev 3938) @@ -127,7 +127,6 @@ :top top :width width :height height - :y top :active-p nil :vertices vertices))) result))) Modified: branches/anon-transaction-fixes-2/projects/bos/m2/poi.lisp =================================================================== --- branches/anon-transaction-fixes-2/projects/bos/m2/poi.lisp 2008-09-22 15:51:49 UTC (rev 3937) +++ branches/anon-transaction-fixes-2/projects/bos/m2/poi.lisp 2008-09-22 18:23:36 UTC (rev 3938) @@ -50,7 +50,7 @@ (assert (if (or title subtitle description) language t) nil "language needs to be specified, if any of title, subtitle or description is given") - (apply #'make-instance class-name rest)) + (apply #'make-instance class-name (remove-keys '(:initargs) rest))) (defmethod initialize-instance :after ((poi-medium poi-medium) &key poi) (when poi Modified: branches/anon-transaction-fixes-2/projects/bos/web/daily.lisp =================================================================== --- branches/anon-transaction-fixes-2/projects/bos/web/daily.lisp 2008-09-22 15:51:49 UTC (rev 3937) +++ branches/anon-transaction-fixes-2/projects/bos/web/daily.lisp 2008-09-22 18:23:36 UTC (rev 3938) @@ -3,7 +3,6 @@ (defun daily-cleanup () (format t "; performing daily cleanup run~%") (bos.m2::delete-expired-contracts) - (bknr.stats::make-yesterdays-stats :delete-events t) (format t "; snapshotting datastore~%") (snapshot) (format t "; running check (consistent-p)~%")

1 0

[bknr-cvs] hans changed trunk/thirdparty/emacs/js2.el
by BKNR Commits 22 Sep '08

22 Sep '08

Revision: 3937 Author: hans URL: http://bknr.net/trac/changeset/3937 copy js2 to trunk A trunk/thirdparty/emacs/js2.el Change set too large, please see URL above

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/object
by BKNR Commits 22 Sep '08

22 Sep '08

Revision: 3936 Author: hans URL: http://bknr.net/trac/changeset/3936 Stop using allocate-instance method for ID allocation again. SBCL allocates an instance of every class as an optimization for object creation, and this prototype object was then made part of the class extent. Instead, the ID is now allocated in initialize-instance. Lock ID allocation against concurrent access. U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 08:06:08 UTC (rev 3935) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-22 10:40:42 UTC (rev 3936) @@ -144,8 +144,8 @@ (defdstest stress-test-2 () (bknr.datastore::without-sync () (format t "Creating ~A objects~%" +stress-size+) - (dotimes (i +stress-size+) - (make-instance 'store-object)) + (time (dotimes (i +stress-size+) + (make-instance 'store-object))) (format t "Deleting ~A objects~%" (length (all-store-objects))) (time (map-store-objects #'delete-object)) (test-equal (all-store-objects) nil))) @@ -169,10 +169,11 @@ (defun object-classes-and-ids () "Return a list of conses with the car being a class name and the cdr being the object id for all persistent objects in the store" - (mapcar (lambda (object) - (cons (class-name (class-of object)) - (store-object-id object))) - (all-store-objects))) + (sort (mapcar (lambda (object) + (cons (class-name (class-of object)) + (store-object-id object))) + (all-store-objects)) + #'< :key #'cdr)) (defdstest make-referenced-object-in-anon-tx () (with-transaction (:make) Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 08:06:08 UTC (rev 3935) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-22 10:40:42 UTC (rev 3936) @@ -163,7 +163,9 @@ (remove-if #'transient-slot-p (class-slots class))) (defclass store-object () - ((id :initarg :id :reader store-object-id + ((id :initarg :id + :reader store-object-id + :type integer :index-type unique-index :index-initargs (:test #'eql) :index-reader store-object-with-id :index-values all-store-objects @@ -220,6 +222,7 @@ (aclmop::finalize-inheritance (find-class 'store-object)) (defmethod initialize-instance :around ((object store-object) &rest initargs &key) + (setf (slot-value object 'id) (allocate-next-object-id)) (cond ((not (in-transaction-p)) (with-store-guard () @@ -242,14 +245,14 @@ (t (call-next-method)))) -(defmethod allocate-instance :around ((class persistent-class) &key) - (let* ((object (call-next-method)) - (subsystem (store-object-subsystem)) - (id (next-object-id subsystem))) - (setf (slot-value object 'id) id) - (incf (next-object-id subsystem)) - object)) +(defvar *allocate-object-id-lock* (bt:make-lock "Persistent Object ID Creation")) +(defun allocate-next-object-id () + (mp-with-lock-held (*allocate-object-id-lock*) + (let ((id (next-object-id (store-object-subsystem)))) + (incf (next-object-id (store-object-subsystem))) + id))) + (defun initialize-transient-slots (object) (dolist (slotd (class-slots (class-of object))) (when (and (typep slotd 'persistent-effective-slot-definition) @@ -493,15 +496,9 @@ ;; If the class is NIL, it was not found in the currently ;; running Lisp image and objects of this class will be ignored. (when class - ;; We set the next object ID to allocate in the store to the - ;; object ID read from the snapshot file. ALLOCATE-INSTANCE - ;; will assign this object ID to the object and increment the - ;; counter. This way, we correctly deserialze store snapshots - ;; which have holes in their ID space (because objects have - ;; been deleted). - (setf (next-object-id (store-object-subsystem)) object-id) (let ((object (allocate-instance class))) - (assert (= object-id (slot-value object 'id))) + (setf (slot-value object 'id) object-id + (next-object-id (store-object-subsystem)) (1+ object-id)) (dolist (index (class-slot-indices class 'id)) (index-add index object)))))))

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/tutorial.lisp
by BKNR Commits 22 Sep '08

22 Sep '08

Revision: 3935 Author: hans URL: http://bknr.net/trac/changeset/3935 Fix indentation U branches/anon-transaction-fixes-2/bknr/datastore/src/data/tutorial.lisp Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/tutorial.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/tutorial.lisp 2008-09-21 21:26:39 UTC (rev 3934) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/tutorial.lisp 2008-09-22 08:06:08 UTC (rev 3935) @@ -131,17 +131,17 @@ (close-store) (make-instance 'tutorial-store :directory "/tmp/tutorial-store/" :subsystems nil) - ; Warning: restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Warning: restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> (tutorial-store-counter *store*) - ; => 0 +; => 0 (incf-counter) - ; => 1 +; => 1 (incf-counter) - ; => 2 +; => 2 (decf-counter) - ; => 1 +; => 1 ;;; The three transactions have been logged to the transaction log in ;;; "/tmp/tutorial-store/", as we can see: @@ -149,13 +149,13 @@ (with-open-file (s "/tmp/tutorial-store/current/transaction-log" :direction :input) (file-length s)) - ; => 126 +; => 126 (incf-counter) - ; => 2 +; => 2 (with-open-file (s "/tmp/tutorial-store/current/transaction-log" :direction :input) (file-length s)) - ; => 168 +; => 168 ;;; The transaction log is kept in a directory called "current", which ;;; is where the currently active version of the snapshots and log @@ -166,29 +166,29 @@ ;;; the persistent data (the counter value). (snapshot) - ; => Error in function (METHOD SNAPSHOT-STORE NIL (STORE)): - ; => Cannot snapshot store without subsystems... - ; => [Condition of type SIMPLE-ERROR] +; => Error in function (METHOD SNAPSHOT-STORE NIL (STORE)): +; => Cannot snapshot store without subsystems... +; => [Condition of type SIMPLE-ERROR] ;;; We can close the store by using the function `CLOSE-STORE'. *store* - ; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> (close-store) - ; => NIL +; => NIL (boundp '*store*) - ; => NIL +; => NIL ;;; The store can then be recreated, and the transaction log will be ;;; read and executed upon restore. (make-instance 'tutorial-store :directory "/tmp/tutorial-store/" :subsystems nil) - ; Warning: restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; Warning: loading transaction log - ; /tmp/tutorial-store/current/transaction-log - ; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Warning: restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Warning: loading transaction log +; /tmp/tutorial-store/current/transaction-log +; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> (tutorial-store-counter *store*) - ; => 2 +; => 2 ;;; The store can also be restored in a later LISP session. Make sure ;;; that all the code necessary to the execution of the transaction @@ -205,26 +205,26 @@ ;;; `UNTIL' argument of `RESTORE-STORE'. (setf *store-debug* t) - ; => T +; => T (restore-store *store*) - ; restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; loading transaction log /tmp/tutorial-store/current/transaction-log - ; executing transaction #<TRANSACTION 21.04.2008 07:08:22 TX-INCF-COUNTER > at timestamp 3417743302 - ; executing transaction #<TRANSACTION 21.04.2008 07:08:25 TX-INCF-COUNTER > at timestamp 3417743305 - ; executing transaction #<TRANSACTION 21.04.2008 07:08:26 TX-DECF-COUNTER > at timestamp 3417743306 - ; executing transaction #<TRANSACTION 21.04.2008 07:08:34 TX-INCF-COUNTER > at timestamp 3417743314 - ; => NIL +; restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; loading transaction log /tmp/tutorial-store/current/transaction-log +; executing transaction #<TRANSACTION 21.04.2008 07:08:22 TX-INCF-COUNTER > at timestamp 3417743302 +; executing transaction #<TRANSACTION 21.04.2008 07:08:25 TX-INCF-COUNTER > at timestamp 3417743305 +; executing transaction #<TRANSACTION 21.04.2008 07:08:26 TX-DECF-COUNTER > at timestamp 3417743306 +; executing transaction #<TRANSACTION 21.04.2008 07:08:34 TX-INCF-COUNTER > at timestamp 3417743314 +; => NIL (tutorial-store-counter *store*) - ; => 2 - ; !! Update the timestamp below to correspond to the fist transaction executed above !! +; => 2 +; !! Update the timestamp below to correspond to the fist transaction executed above !! (restore-store *store* :until 3417743302) ... - ; restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; loading transaction log /tmp/tutorial-store/current/transaction-log - ; executing transaction #<TRANSACTION 21.04.2008 07:08:22 TX-INCF-COUNTER > at timestamp 3417743302 - ; creating log file backup: /tmp/tutorial-store/current/transaction-log.backup - ; truncating transaction log at position 42. +; restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; loading transaction log /tmp/tutorial-store/current/transaction-log +; executing transaction #<TRANSACTION 21.04.2008 07:08:22 TX-INCF-COUNTER > at timestamp 3417743302 +; creating log file backup: /tmp/tutorial-store/current/transaction-log.backup +; truncating transaction log at position 42. (tutorial-store-counter *store*) - ; => 1 +; => 1 ;;;## Adding a subsystem @@ -287,22 +287,22 @@ ;;; `COUNTER-SUBSYSTEM'. (close-store) - ; => NIL +; => NIL (make-instance 'tutorial-store :directory "/tmp/tutorial-store/" :subsystems (list (make-instance 'counter-subsystem))) - ; Warning: restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; Warning: Could not find store counter value, setting to 0. - ; Warning: loading transaction log - ; /tmp/tutorial-store/current/transaction-log - ; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Warning: restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Warning: Could not find store counter value, setting to 0. +; Warning: loading transaction log +; /tmp/tutorial-store/current/transaction-log +; => #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> (snapshot) - ; Snapshotting subsystem #<COUNTER-SUBSYSTEM #xE65F866> of #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; Successfully snapshotted #<COUNTER-SUBSYSTEM #xE65F866> of #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; => NIL +; Snapshotting subsystem #<COUNTER-SUBSYSTEM #xE65F866> of #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Successfully snapshotted #<COUNTER-SUBSYSTEM #xE65F866> of #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; => NIL (restore) - ; restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; Restoring the subsystem #<COUNTER-SUBSYSTEM #xE65F866> of #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> - ; => NUL +; restoring #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; Restoring the subsystem #<COUNTER-SUBSYSTEM #xE65F866> of #<TUTORIAL-STORE DIR: "/tmp/tutorial-store/"> +; => NUL ;;;# An object store example @@ -340,11 +340,11 @@ :subsystems (list (make-instance 'store-object-subsystem))) - ; Warning: restoring #<MP-STORE DIR: "/tmp/object-store/"> - ; restoring #<MP-STORE DIR: "/tmp/object-store/"> - ; Restoring the subsystem #<STORE-OBJECT-SUBSYSTEM #xE63F866> of #<MP-STORE DIR: "/tmp/object-store/"> +; Warning: restoring #<MP-STORE DIR: "/tmp/object-store/"> +; restoring #<MP-STORE DIR: "/tmp/object-store/"> +; Restoring the subsystem #<STORE-OBJECT-SUBSYSTEM #xE63F866> of #<MP-STORE DIR: "/tmp/object-store/"> (all-store-objects) - ; => NIL +; => NIL ;;; We can now create a few store objects (which is not very ;;; interesting in itself). Store objects have to be created inside a @@ -354,28 +354,28 @@ ;;; separate transaction. (make-instance 'store-object) - ; => #<STORE-OBJECT ID: 0> +; => #<STORE-OBJECT ID: 0> (make-instance 'store-object) - ; => #<STORE-OBJECT ID: 1> +; => #<STORE-OBJECT ID: 1> (all-store-objects) - ; => (#<STORE-OBJECT ID: 0> #<STORE-OBJECT ID: 1>) +; => (#<STORE-OBJECT ID: 0> #<STORE-OBJECT ID: 1>) (all-store-classes) - ; => (STORE-OBJECT) +; => (STORE-OBJECT) ;;; Object deletion also has to be done through the transaction ;;; `DELETE-OBJECT', which will log the deletion of the object in the ;;; transaction log, and remove the object from all its indices. (make-instance 'store-object) - ; executing transaction #<TRANSACTION 21.04.2008 08:02:10 MAKE-INSTANCE STORE-OBJECT ID 2> at timestamp 3417746530 - ; => #<STORE-OBJECT ID: 12> +; executing transaction #<TRANSACTION 21.04.2008 08:02:10 MAKE-INSTANCE STORE-OBJECT ID 2> at timestamp 3417746530 +; => #<STORE-OBJECT ID: 12> (store-object-with-id 2) - ; => #<STORE-OBJECT ID: 2> +; => #<STORE-OBJECT ID: 2> (delete-object (store-object-with-id 2)) - ; executing transaction #<TRANSACTION 21.04.2008 08:52:14 TX-DELETE-OBJECT 2> at timestamp 3417749534 - ; => T +; executing transaction #<TRANSACTION 21.04.2008 08:52:14 TX-DELETE-OBJECT 2> at timestamp 3417749534 +; => T (store-object-with-id 2) - ; => NIL +; => NIL ;;;## Defining persistent classes @@ -412,25 +412,25 @@ ;;; We can now create a few instance of `TUTORIAL-OBJECT': (make-instance 'tutorial-object :a 2) - ; => #<TUTORIAL-OBJECT ID: 3> +; => #<TUTORIAL-OBJECT ID: 3> (make-instance 'tutorial-object :a 2) - ; => #<TUTORIAL-OBJECT ID: 4> +; => #<TUTORIAL-OBJECT ID: 4> (make-instance 'tutorial-object :a 2) - ; => #<TUTORIAL-OBJECT ID: 5> +; => #<TUTORIAL-OBJECT ID: 5> (store-object-with-id 5) - ; => #<TUTORIAL-OBJECT ID: 5> +; => #<TUTORIAL-OBJECT ID: 5> (all-store-classes) - ; => (STORE-OBJECT TUTORIAL-OBJECT) +; => (STORE-OBJECT TUTORIAL-OBJECT) (store-objects-with-class 'tutorial-object) - ; => (#<TUTORIAL-OBJECT ID: 3> #<TUTORIAL-OBJECT ID: 4> - ; #<TUTORIAL-OBJECT ID: 5>) +; => (#<TUTORIAL-OBJECT ID: 3> #<TUTORIAL-OBJECT ID: 4> +; #<TUTORIAL-OBJECT ID: 5>) (store-objects-with-class 'store-object) - ; => (#<STORE-OBJECT ID: 0> #<STORE-OBJECT ID: 1> - ; #<FOO ID: 2> #<TUTORIAL-OBJECT ID: 3> - ; #<TUTORIAL-OBJECT ID: 4> #<TUTORIAL-OBJECT ID: 5>) +; => (#<STORE-OBJECT ID: 0> #<STORE-OBJECT ID: 1> +; #<FOO ID: 2> #<TUTORIAL-OBJECT ID: 3> +; #<TUTORIAL-OBJECT ID: 4> #<TUTORIAL-OBJECT ID: 5>) ;;; In order to change the slot values of persistent object, the ;;; application needs to be in a transaction context. This can be @@ -442,16 +442,16 @@ ((b :update))) (make-instance 'tutorial-object2 :b 3) - ; executing transaction #<TRANSACTION 21.04.2008 08:03:27 MAKE-INSTANCE TUTORIAL-OBJECT2 ID 6 B 3> at timestamp 3417746607 - ; => #<TUTORIAL-OBJECT2 ID: 6> +; executing transaction #<TRANSACTION 21.04.2008 08:03:27 MAKE-INSTANCE TUTORIAL-OBJECT2 ID 6 B 3> at timestamp 3417746607 +; => #<TUTORIAL-OBJECT2 ID: 6> (setf (slot-value (store-object-with-id 6) 'b) 4) - ; => Error - ; Attempt to set persistent slot B of #<TUTORIAL-OBJECT2 ID: 6> outside of a transaction +; => Error +; Attempt to set persistent slot B of #<TUTORIAL-OBJECT2 ID: 6> outside of a transaction (with-transaction () (setf (slot-value (store-object-with-id 6) 'b) 4)) - ; => 4 +; => 4 (tutorial-object2-b (store-object-with-id 6)) - ; => 4 +; => 4 ;;;## Object creation and deletion protocol @@ -479,17 +479,17 @@ ;;; We can modify the slot `A' outside a transaction: (make-instance 'protocol-object :a 1 :b 2) - ; executing transaction #<TRANSACTION 21.04.2008 08:10:49 MAKE-INSTANCE PROTOCOL-OBJECT ID 7 A 1 B 2> at timestamp 3417747049 - ; => #<PROTOCOL-OBJECT ID: 7> +; executing transaction #<TRANSACTION 21.04.2008 08:10:49 MAKE-INSTANCE PROTOCOL-OBJECT ID 7 A 1 B 2> at timestamp 3417747049 +; => #<PROTOCOL-OBJECT ID: 7> (setf (protocol-object-a (store-object-with-id 7)) 2) - ; => 2 +; => 2 ;;; However, we cannot modify the slot `B', as it is persistent and ;;; has to be changed inside a transaction. (setf (protocol-object-b (store-object-with-id 7)) 4) - ; => Error - ; Attempt to set persistent slot B of #<PROTOCOL-OBJECT ID: 7> outside of a transaction +; => Error +; Attempt to set persistent slot B of #<PROTOCOL-OBJECT ID: 7> outside of a transaction ;;; An object can be removed from the datastore using the transaction ;;; `DELETE-OBJECT', which calls the method `DESTROY-OBJECT' on the @@ -502,19 +502,19 @@ ;;; We can snapshot the persistent state of all created objects by ;;; using `SNAPSHOT'. (snapshot) - ; Snapshotting subsystem #<STORE-OBJECT-SUBSYSTEM #xE54991E> of #<MP-STORE DIR: "/tmp/object-store/"> - ; Successfully snapshotted #<STORE-OBJECT-SUBSYSTEM #xE54991E> of #<MP-STORE DIR: "/tmp/object-store/"> +; Snapshotting subsystem #<STORE-OBJECT-SUBSYSTEM #xE54991E> of #<MP-STORE DIR: "/tmp/object-store/"> +; Successfully snapshotted #<STORE-OBJECT-SUBSYSTEM #xE54991E> of #<MP-STORE DIR: "/tmp/object-store/"> ;;; This will create a backup directory containing the old transaction ;;; log, and the creation of a snapshot file in the "current" ;;; directory. (directory "/tmp/object-store/**/*.*") - ; => (#P"/tmp/object-store/20080421T061210/random-state" - ; #P"/tmp/object-store/20080421T061210/transaction-log" - ; #P"/tmp/object-store/current/random-state" - ; #P"/tmp/object-store/current/store-object-subsystem-snapshot" - ; #P"/tmp/object-store/current/transaction-log") +; => (#P"/tmp/object-store/20080421T061210/random-state" +; #P"/tmp/object-store/20080421T061210/transaction-log" +; #P"/tmp/object-store/current/random-state" +; #P"/tmp/object-store/current/store-object-subsystem-snapshot" +; #P"/tmp/object-store/current/transaction-log") ;;; The snapshot file contains all persistent objects present at ;;; snapshotting time, and the value of their persistent @@ -538,15 +538,15 @@ :index-keys all-gorilla-moods))) (make-instance 'gorilla :name "lucy" :mood :aggressive) - ; => #<GORILLA ID: 8> +; => #<GORILLA ID: 8> (make-instance 'gorilla :name "john" :mood :playful) - ; => #<GORILLA ID: 9> +; => #<GORILLA ID: 9> (make-instance 'gorilla :name "peter" :mood :playful) - ; => #<GORILLA ID: 10> +; => #<GORILLA ID: 10> (gorilla-with-name "lucy") - ; => #<GORILLA ID: 8> +; => #<GORILLA ID: 8> (gorillas-with-mood :playful) - ; => (#<GORILLA ID: 10> #<GORILLA ID: 9>) +; => (#<GORILLA ID: 10> #<GORILLA ID: 9>) ;;;## Adding blobs @@ -606,7 +606,7 @@ (make-blob-from-file "/tmp/bla.jpg" 'photo :name "foobar" :type :jpg) - ; => #<PHOTO ID: 11, TYPE: jpg> +; => #<PHOTO ID: 11, TYPE: jpg> ;;; We can work with the photo object in the same way as when we work ;;; with a normal object. However, we can access the binary data using @@ -615,7 +615,7 @@ ;;; object. (blob-pathname (store-object-with-id 11)) - ; => #P"/tmp/object-store/blob-root/11" +; => #P"/tmp/object-store/blob-root/11" ;;; The method `BLOB-TO-FILE' and `BLOB-TO-STREAM' write the binary ;;; data of the object to the specified file or stream (the stream has @@ -642,37 +642,37 @@ ((a :update :relaxed-object-reference t))) (make-instance 'relaxed-object) - ; => #<RELAXED-OBJECT ID: 12> +; => #<RELAXED-OBJECT ID: 12> (make-instance 'relaxed-object) - ; => #<RELAXED-OBJECT ID: 13> +; => #<RELAXED-OBJECT ID: 13> (with-transaction () (setf (slot-value (store-object-with-id 12) 'a) (store-object-with-id 13))) - ; => #<RELAXED-OBJECT ID: 13> +; => #<RELAXED-OBJECT ID: 13> (delete-object (store-object-with-id 13)) - ; => T +; => T (snapshot) - ; Warning: Backup of the datastore in /tmp/object-store/20080421T064811/. - ; While executing: (:INTERNAL (SNAPSHOT-STORE (STORE))), in process worker(1750). - ; Snapshotting subsystem #<STORE-OBJECT-SUBSYSTEM #xE6069EE> of #<MP-STORE DIR: "/tmp/object-store/"> - ; Warning: Encoding reference to destroyed object with ID 13 from slot A of object RELAXED-OBJECT with ID 12. - ; While executing: #<STANDARD-METHOD ENCODE-OBJECT (STORE-OBJECT T)>, in process worker(1750). - ; Successfully snapshotted #<STORE-OBJECT-SUBSYSTEM #xE6069EE> of #<MP-STORE DIR: "/tmp/object-store/"> - ; Snapshotting subsystem #<BLOB-SUBSYSTEM #xE6069CE> of #<MP-STORE DIR: "/tmp/object-store/"> - ; Successfully snapshotted #<BLOB-SUBSYSTEM #xE6069CE> of #<MP-STORE DIR: "/tmp/object-store/"> - ; => NIL +; Warning: Backup of the datastore in /tmp/object-store/20080421T064811/. +; While executing: (:INTERNAL (SNAPSHOT-STORE (STORE))), in process worker(1750). +; Snapshotting subsystem #<STORE-OBJECT-SUBSYSTEM #xE6069EE> of #<MP-STORE DIR: "/tmp/object-store/"> +; Warning: Encoding reference to destroyed object with ID 13 from slot A of object RELAXED-OBJECT with ID 12. +; While executing: #<STANDARD-METHOD ENCODE-OBJECT (STORE-OBJECT T)>, in process worker(1750). +; Successfully snapshotted #<STORE-OBJECT-SUBSYSTEM #xE6069EE> of #<MP-STORE DIR: "/tmp/object-store/"> +; Snapshotting subsystem #<BLOB-SUBSYSTEM #xE6069CE> of #<MP-STORE DIR: "/tmp/object-store/"> +; Successfully snapshotted #<BLOB-SUBSYSTEM #xE6069CE> of #<MP-STORE DIR: "/tmp/object-store/"> +; => NIL (restore) - ; restoring #<MP-STORE DIR: "/tmp/object-store/"> - ; Restoring the subsystem #<STORE-OBJECT-SUBSYSTEM #xE6069EE> of #<MP-STORE DIR: "/tmp/object-store/"> - ; loading snapshot file /tmp/object-store/current/store-object-subsystem-snapshot - ; Warning: internal inconsistency during restore: can't find store object 13 in loaded store - ; While executing: %DECODE-STORE-OBJECT, in process worker(1754). - ; Warning: Reference to inexistent object with id 13 from unnamed container, returning NIL. - ; While executing: %DECODE-STORE-OBJECT, in process worker(1754). - ; Restoring the subsystem #<BLOB-SUBSYSTEM #xE6069CE> of #<MP-STORE DIR: "/tmp/object-store/"> - ; loading transaction log /tmp/object-store/current/transaction-log - ; executing transaction #<ANONYMOUS-TRANSACTION 21.04.2008 08:48:48 PREPARE-FOR-SNAPSHOT NIL> at timestamp 3417749328 +; restoring #<MP-STORE DIR: "/tmp/object-store/"> +; Restoring the subsystem #<STORE-OBJECT-SUBSYSTEM #xE6069EE> of #<MP-STORE DIR: "/tmp/object-store/"> +; loading snapshot file /tmp/object-store/current/store-object-subsystem-snapshot +; Warning: internal inconsistency during restore: can't find store object 13 in loaded store +; While executing: %DECODE-STORE-OBJECT, in process worker(1754). +; Warning: Reference to inexistent object with id 13 from unnamed container, returning NIL. +; While executing: %DECODE-STORE-OBJECT, in process worker(1754). +; Restoring the subsystem #<BLOB-SUBSYSTEM #xE6069CE> of #<MP-STORE DIR: "/tmp/object-store/"> +; loading transaction log /tmp/object-store/current/transaction-log +; executing transaction #<ANONYMOUS-TRANSACTION 21.04.2008 08:48:48 PREPARE-FOR-SNAPSHOT NIL> at timestamp 3417749328 (relaxed-object-a (store-object-with-id 12)) - ; => NIL +; => NIL ;;;# Store internals

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/
by BKNR Commits 21 Sep '08

21 Sep '08

Revision: 3934 Author: hans URL: http://bknr.net/trac/changeset/3934 Protocol updates U branches/anon-transaction-fixes-2/bknr/datastore/src/data/blob.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/package.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/tests.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/tutorial.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/xml-object.lisp U branches/anon-transaction-fixes-2/bknr/modules/bug/bug-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/comics/comics.lisp U branches/anon-transaction-fixes-2/bknr/modules/feed/edit-feed-handler.lisp U branches/anon-transaction-fixes-2/bknr/modules/feed/feed.lisp U branches/anon-transaction-fixes-2/bknr/modules/imagemap/imagemap.lisp U branches/anon-transaction-fixes-2/bknr/modules/mail/import-yahoo-group.lisp U branches/anon-transaction-fixes-2/bknr/modules/mail/mail.lisp U branches/anon-transaction-fixes-2/bknr/modules/mail/mailinglist-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/mail/mailinglist.lisp U branches/anon-transaction-fixes-2/bknr/modules/mail/register-handler.lisp U branches/anon-transaction-fixes-2/bknr/modules/mail/registration.lisp U branches/anon-transaction-fixes-2/bknr/modules/quizz/edit-quizz-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/stats/stats.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/article-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/article.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/billboard-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/billboard.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/blog-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/paste-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/text/wiki-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/track/track.lisp U branches/anon-transaction-fixes-2/bknr/modules/url/cached-url-handlers.lisp U branches/anon-transaction-fixes-2/bknr/modules/url/edit-url-handlers.lisp U branches/anon-transaction-fixes-2/bknr/web/src/images/image.lisp U branches/anon-transaction-fixes-2/bknr/web/src/rss/rss.lisp U branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/cron.lisp U branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/event.lisp U branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/sysparam.lisp U branches/anon-transaction-fixes-2/bknr/web/src/sysclasses/user.lisp U branches/anon-transaction-fixes-2/bknr/web/src/web/host.lisp U branches/anon-transaction-fixes-2/projects/bknr-website/src/init.lisp U branches/anon-transaction-fixes-2/projects/bos/m2/allocation.lisp U branches/anon-transaction-fixes-2/projects/bos/m2/m2.lisp U branches/anon-transaction-fixes-2/projects/bos/m2/map.lisp U branches/anon-transaction-fixes-2/projects/bos/m2/news.lisp U branches/anon-transaction-fixes-2/projects/bos/m2/poi.lisp U branches/anon-transaction-fixes-2/projects/bos/web/kml-handlers.lisp U branches/anon-transaction-fixes-2/projects/bos/web/languages-handler.lisp U branches/anon-transaction-fixes-2/projects/bos/web/poi-handlers.lisp U branches/anon-transaction-fixes-2/projects/bos/web/sat-tree.lisp U branches/anon-transaction-fixes-2/projects/hello-web/src/news.lisp U branches/anon-transaction-fixes-2/projects/lisp-ecoop/src/handlers.lisp U branches/anon-transaction-fixes-2/projects/lisp-ecoop/src/participant.lisp U branches/anon-transaction-fixes-2/projects/lisp-ecoop/src/tags.lisp U branches/anon-transaction-fixes-2/projects/quickhoney/website/static/javascript.js U branches/anon-transaction-fixes-2/projects/scrabble/src/game.lisp U branches/anon-transaction-fixes-2/projects/scrabble/src/rules.lisp U branches/anon-transaction-fixes-2/projects/scrabble/src/start-webserver.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/eboy/src/dynasite-tags.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/eboy/src/item-handlers.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/gpn/gpn-user.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/gpn/gpn-web.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/gpn/zeitplan-handlers.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/raw-data/mcp/bluetooth.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/raw-data/mcp/isdn-operator.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/raw-data/mcp/sensors.lisp U branches/anon-transaction-fixes-2/projects/unmaintained/saugnapf/src/saugnapf.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/bknr/datastore/src/data/object
by BKNR Commits 21 Sep '08

21 Sep '08

Revision: 3933 Author: hans URL: http://bknr.net/trac/changeset/3933 Serialize make-instance transaction before calling initialize-instance in order to make sure that the object exists early enough during restore. Stress test with two threads. Change defdstest macro so that after each test has run, it is verified that the "same" set of objects exists when restoring from the tx log and a snapshot. U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp U branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-21 12:51:48 UTC (rev 3932) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object-tests.lisp 2008-09-21 16:51:58 UTC (rev 3933) @@ -52,6 +52,17 @@ (delete-directory directory)))) (defvar *tests* (make-hash-table)) + +(defun do-run-test (thunk) + (let ((bknr.datastore::*store-verbose* nil) + initial-objects) + (funcall thunk) + (setf initial-objects (object-classes-and-ids)) + (restore) + (test-equal initial-objects (object-classes-and-ids)) + (snapshot) + (restore) + (test-equal initial-objects (object-classes-and-ids)))) (defmacro defdstest (name args &body body) (when args @@ -60,9 +71,7 @@ (make-instance 'datastore-test-class :unit :datastore :name ',name - :body (lambda () - (let ((bknr.datastore::*store-verbose* nil)) - ,@body))))) + :body (lambda () (do-run-test (lambda () ,@body)))))) (defdstest store-setup () (test-assert *store*)) @@ -121,16 +130,26 @@ (defconstant +stress-size+ 10000) (defdstest stress-test () - (format t "Creating ~a objects~%" +stress-size+) + (format t "Creating ~A objects in two threads~%" +stress-size+) (time (bknr.datastore::without-sync () - (dotimes (i +stress-size+) - (make-instance 'store-object)))) - (test-equal (length (all-store-objects)) +stress-size+) - (format t "Delete ~A objects~%" +stress-size+) - (time (bknr.datastore::without-sync () - (map-store-objects #'delete-object))) - (test-equal (all-store-objects) nil)) + (labels ((stress () + (dotimes (i +stress-size+) + (make-instance 'store-object)))) + (let ((threads (list (bt:make-thread #'stress) + (bt:make-thread #'stress)))) + (loop while (some #'bt:thread-alive-p threads) + do (sleep 1)))))) + (test-equal (length (all-store-objects)) (* 2 +stress-size+))) +(defdstest stress-test-2 () + (bknr.datastore::without-sync () + (format t "Creating ~A objects~%" +stress-size+) + (dotimes (i +stress-size+) + (make-instance 'store-object)) + (format t "Deleting ~A objects~%" (length (all-store-objects))) + (time (map-store-objects #'delete-object)) + (test-equal (all-store-objects) nil))) + (defdstest make-instance-in-anon-txn () (with-transaction () (make-instance 'store-object)) @@ -142,11 +161,23 @@ (test-assert (make-instance 'store-object)))) (define-persistent-class parent () - ((child :update :initform nil))) + ((child :update :initform nil :initarg nil))) (define-persistent-class child () ()) +(defun object-classes-and-ids () + "Return a list of conses with the car being a class name and the cdr + being the object id for all persistent objects in the store" + (mapcar (lambda (object) + (cons (class-name (class-of object)) + (store-object-id object))) + (all-store-objects))) + +(defdstest make-referenced-object-in-anon-tx () + (with-transaction (:make) + (make-instance 'parent :child (make-instance 'child)))) + (defdstest serialize-circular-in-anon-txn () (let ((parent (make-instance 'parent))) (with-transaction (:circular) @@ -227,7 +258,19 @@ (test-equal 0 (class-with-transient-slot-slot (find-store-object object-id))) (snapshot) (restore) - (test-equal 0 (class-with-transient-slot-slot (find-store-object object-id))))) + (test-equal 0 (class-with-transient-slot-slot (find-store-object object-id))))) +(define-persistent-class persistent-mixin () + ((mixin-slot :update + :initform 2))) + +(define-persistent-class inherit-multiple (persistent-mixin parent) + ()) + +(defdstest multiple-inheritance-test () + (let* ((o1 (make-instance 'inherit-multiple :child (make-instance 'child))) + (o2 (make-instance 'inherit-multiple :child o1))) + (test-equal o1 (parent-child o2)))) + (defun run-datastore-test (name) - (unit-test:run-test (gethash name *tests*))) \ No newline at end of file + (unit-test:run-test (gethash name *tests*))) Modified: branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp =================================================================== --- branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-21 12:51:48 UTC (rev 3932) +++ branches/anon-transaction-fixes-2/bknr/datastore/src/data/object.lisp 2008-09-21 16:51:58 UTC (rev 3933) @@ -39,7 +39,7 @@ (defun store-object-subsystem () (let ((subsystem (find-if (alexandria:rcurry #'typep 'store-object-subsystem) - (store-subsystems *store*)))) + (store-subsystems *store*)))) (unless subsystem (error 'object-subsystem-not-found-in-store :store *store*)) subsystem)) @@ -47,17 +47,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (finalize-inheritance (defclass persistent-class (indexed-class) - ((transient-slot-initargs :initform nil - :accessor persistent-class-transient-slot-initargs))))) + ()))) -(defmethod determine-transient-slot-initargs ((class persistent-class)) - (with-slots (transient-slot-initargs) class - (setf transient-slot-initargs nil) - (dolist (slotd (class-slots class)) - (when (and (transient-slot-p slotd) - (slot-definition-initargs slotd)) - (pushnew (car (slot-definition-initargs slotd)) transient-slot-initargs))))) - (defmethod validate-superclass ((sub persistent-class) (super indexed-class)) t) @@ -68,22 +59,16 @@ (when (plusp instance-count) (unless *suppress-schema-warnings* (report-progress "~&; updating ~A instances of ~A for class changes~%" - instance-count class)) + instance-count class)) (mapc #'reinitialize-instance (class-instances class))))) -(defmethod instance :after ((class persistent-class) &rest args) - (declare (ignore args)) - (determine-transient-slot-initargs class)) - -(defmethod reinitialize-instance :after ((class persistent-class) &rest args) - (declare (ignore args)) - (determine-transient-slot-initargs class) +(defmethod reinitialize-instance :after ((class persistent-class) &key) (when (and (boundp '*store*) *store*) (update-instances-for-changed-class (class-name class)) (unless *suppress-schema-warnings* (report-progress "~&; class ~A has been changed. To ensure correct schema ~ evolution, please snapshot your datastore.~%" - (class-name class))))) + (class-name class))))) (defclass persistent-direct-slot-definition (index-direct-slot-definition) ((relaxed-object-reference :initarg :relaxed-object-reference @@ -194,7 +179,7 @@ :slots (id)))) (defun class-instances (class) - (find-class class) ; make sure that the class exists + (find-class class) ; make sure that the class exists (store-objects-with-class class)) (deftransaction store-object-touch (object) @@ -237,21 +222,23 @@ (defmethod initialize-instance :around ((object store-object) &rest initargs &key) (cond ((not (in-transaction-p)) - (let ((transaction (make-instance 'transaction - :function-symbol 'make-instance - :timestamp (get-universal-time) - :args (cons (class-name (class-of object)) initargs)))) - (with-statistics-log (*transaction-statistics* (transaction-function-symbol transaction)) - (with-transaction-log (transaction) - (call-next-method))))) + (with-store-guard () + (let ((transaction (make-instance 'transaction + :function-symbol 'make-instance + :timestamp (get-universal-time) + :args (cons (class-name (class-of object)) + (append (list :id (slot-value object 'id)) + initargs))))) + (with-statistics-log (*transaction-statistics* (transaction-function-symbol transaction)) + (with-transaction-log (transaction) + (call-next-method)))))) ((in-anonymous-transaction-p) - (prog1 - (call-next-method) - (encode (make-instance 'transaction - :function-symbol 'make-instance - :timestamp (transaction-timestamp *current-transaction*) - :args (cons (class-name (class-of object)) initargs)) - (anonymous-transaction-log-buffer *current-transaction*)))) + (encode (make-instance 'transaction + :function-symbol 'make-instance + :timestamp (transaction-timestamp *current-transaction*) + :args (cons (class-name (class-of object)) initargs)) + (anonymous-transaction-log-buffer *current-transaction*)) + (call-next-method)) (t (call-next-method)))) @@ -272,12 +259,12 @@ (funcall (slot-definition-initfunction slotd)))))) (defmethod initialize-instance :after ((object store-object) &key) - ;; This is called only when initially creating the (persistent) - ;; instance, not during restore. During restore, the - ;; INITIALIZE-TRANSIENT-INSTANCE function is called for all - ;; persistent objects after the snapshot has been read, but before - ;; running the transaction log. - (initialize-transient-instance object)) + ;; This is called only when initially creating the (persistent) + ;; instance, not during restore. During restore, the + ;; INITIALIZE-TRANSIENT-INSTANCE function is called for all + ;; persistent objects after the snapshot has been read, but before + ;; running the transaction log. + (initialize-transient-instance object)) (defmethod print-object ((object store-object) stream) (print-unreadable-object (object stream :type t) @@ -345,22 +332,6 @@ ,@(unless metaclass '((:metaclass persistent-class))) ,@class-options)))) -#+nil -(define-persistent-class foo () - ((a :read))) -#+nil -(let ((foo (make-object 'foo :a 2))) - (foo-a foo)) - -;;; test fuer multiple inheritance -#+nil -(progn - (define-persistent-class bar () - ((b :read))) - (define-persistent-class blorg (foo bar) - ((c :read))) - (make-object 'blorg :a 2 :b 3 :c 4)) - ;;; binary snapshot (defvar *current-object-slot* nil) @@ -580,6 +551,12 @@ (let ((*current-object-slot* nil)) (%decode-store-object stream))) +(define-condition invalid-reference (warning) + ((id :initarg :id)) + (:report (lambda (e stream) + (format stream "internal inconsistency during restore - store object with ID ~A could not be found" + (slot-value e 'id))))) + (defun %decode-store-object (stream) ;; This is actually called in two contexts, when a slot-value is to ;; be filled with a reference to a store object and when a list of @@ -595,8 +572,7 @@ ;; lists in slots). (let* ((id (%decode-integer stream)) (object (or (store-object-with-id id) - (warn "internal inconsistency during restore: can't find store object ~A in loaded store" - id))) + (warn 'invalid-reference :id id))) (container (first *current-object-slot*)) (slot-name (second *current-object-slot*))) (cond (object object) @@ -689,13 +665,6 @@ (clear-class-indices class-name))) class-layouts)))))))) -(defun make-object (class-name &rest initargs) - "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS." - (if (in-transaction-p) - (apply #'make-instance class-name initargs) - (with-store-guard () - (apply #'make-instance class-name initargs)))) - (defun tx-delete-object (id) (destroy-object (store-object-with-id id)))

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/thirdparty/emacs/js2.el
by BKNR Commits 21 Sep '08

21 Sep '08

Revision: 3932 Author: hans URL: http://bknr.net/trac/changeset/3932 add js2-mode version 2008016a A branches/anon-transaction-fixes-2/thirdparty/emacs/js2.el Change set too large, please see URL above

1 0

[bknr-cvs] hans changed branches/anon-transaction-fixes-2/
by BKNR Commits 21 Sep '08

21 Sep '08

Revision: 3931 Author: hans URL: http://bknr.net/trac/changeset/3931 Initialized merge tracking via "svnmerge" with revisions "1-3928" from svn+ssh://bknr.net/svn/trunk _U branches/anon-transaction-fixes-2/ Property changes on: branches/anon-transaction-fixes-2 ___________________________________________________________________ Name: svnmerge-integrated + /trunk:1-3928

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs