asserting that instance cache contains objects from the current transaction only
Tue Nov 3 07:30:14 PST 2009 tomi.borbely@gmail.com
* asserting that instance cache contains objects from the current transaction only
diff -rN -u old-cl-perec/dimensional/association-end-set.lisp new-cl-perec/dimensional/association-end-set.lisp
--- old-cl-perec/dimensional/association-end-set.lisp 2014-07-24 23:47:19.000000000 -0700
+++ new-cl-perec/dimensional/association-end-set.lisp 2014-07-24 23:47:19.000000000 -0700
@@ -26,13 +26,15 @@
nil)
(def method insert-item ((set persistent-association-end-set-container-d) item)
- (bind ((instance (instance-of set))
- (slot (slot-of set))
- (dimensions (dimensions-of slot))
- (coordinates (collect-coordinates-from-variables dimensions))
- (d-value (make-single-d-value dimensions coordinates item)))
- (insert-into-association-end-set-d instance slot item :coordinates coordinates)
- (update-cache (class-of instance) instance slot :insert d-value)))
+ (bind ((instance (instance-of set)))
+ (assert-instance-access instance (persistent-p instance))
+ (assert-instance-access item (persistent-p item))
+ (bind ((slot (slot-of set))
+ (dimensions (dimensions-of slot))
+ (coordinates (collect-coordinates-from-variables dimensions))
+ (d-value (make-single-d-value dimensions coordinates item)))
+ (insert-into-association-end-set-d instance slot item :coordinates coordinates)
+ (update-cache (class-of instance) instance slot :insert d-value))))
(def method check-delete-item ((set persistent-association-end-set-container-d) item)
nil)
@@ -43,30 +45,34 @@
(dimensions (dimensions-of slot))
(coordinates (collect-coordinates-from-variables dimensions))
(d-value (make-single-d-value dimensions coordinates item)))
+ (assert-instance-access instance (persistent-p instance))
(delete-from-association-end-set-d instance slot item :coordinates coordinates)
(update-cache (class-of instance) instance slot :delete d-value)))
(def method find-item ((set persistent-association-end-set-container-d) (item persistent-object))
;; TODO optimize
- (bind ((instance (instance-of set))
- (dimensions (dimensions-of (slot-of set)))
- (d-value (bind ((*lazy-slot-value-collections* #f))
- (restore-slot (class-of instance) instance (slot-of set)
- :coordinates (collect-coordinates-from-variables dimensions)))))
- (iter (for (coordinates set) :in-d-value d-value)
- (collect-d-value (find item set :test #'p-eq) :dimensions dimensions :coordinates coordinates))))
+ (bind ((instance (instance-of set)))
+ (assert-instance-access instance (persistent-p instance))
+ (bind ((dimensions (dimensions-of (slot-of set)))
+ (d-value (bind ((*lazy-slot-value-collections* #f))
+ (restore-slot (class-of instance) instance (slot-of set)
+ :coordinates (collect-coordinates-from-variables dimensions)))))
+ (iter (for (coordinates set) :in-d-value d-value)
+ (collect-d-value (find item set :test #'p-eq) :dimensions dimensions :coordinates coordinates)))))
(def method ensure-item ((set persistent-association-end-set-container-d) (item persistent-object))
;; TODO optimize
- (bind ((instance (instance-of set))
- (association-end (slot-of set))
- (dimensions (dimensions-of association-end))
- (d-value (bind ((*lazy-slot-value-collections* #f))
- (restore-slot (class-of instance) instance association-end
- :coordinates (collect-coordinates-from-variables dimensions)))))
- (iter (for (coordinates set) :in-d-value d-value)
- (unless (find item set :test #'p-eq)
- (insert-into-association-end-set-d instance association-end item :coordinates coordinates)))))
+ (bind ((instance (instance-of set)))
+ (assert-instance-access instance (persistent-p instance))
+ (assert-instance-access item (persistent-p item))
+ (bind ((association-end (slot-of set))
+ (dimensions (dimensions-of association-end))
+ (d-value (bind ((*lazy-slot-value-collections* #f))
+ (restore-slot (class-of instance) instance association-end
+ :coordinates (collect-coordinates-from-variables dimensions)))))
+ (iter (for (coordinates set) :in-d-value d-value)
+ (unless (find item set :test #'p-eq)
+ (insert-into-association-end-set-d instance association-end item :coordinates coordinates))))))
(def method size ((set persistent-association-end-set-container-d))
(not-yet-implemented))
diff -rN -u old-cl-perec/dimensional/slot-value.lisp new-cl-perec/dimensional/slot-value.lisp
--- old-cl-perec/dimensional/slot-value.lisp 2014-07-24 23:47:19.000000000 -0700
+++ new-cl-perec/dimensional/slot-value.lisp 2014-07-24 23:47:19.000000000 -0700
@@ -37,7 +37,27 @@
(t
(collect (if (whole-domain-marker-p coordinate)
coordinate
- (ensure-list coordinate)))))))
+ (mapcar
+ ;; make sure that coordinates are in the current transaction
+ ;; because they might be stored in the cache
+ [if (persistent-object-p !1) (load-instance !1) !1]
+ (ensure-list coordinate))))))))
+
+(def (function io) assert-d-value-instance-access (d-value)
+ (declare (ignorable d-value))
+ (debug-only
+ (iter (with dimensions = (dimensions-of d-value))
+ (for (coordinates value) :in-d-value d-value)
+ (iter (for dimension :in dimensions)
+ (for coordinate :in coordinates)
+ (when (and (not (typep dimensions 'ordering-dimension))
+ (listp coordinate))
+ (mapc (lambda (coordinate-value)
+ (when (persistent-object-p coordinate-value)
+ (assert-instance-access coordinate-value (persistent-p coordinate-value))))
+ coordinate)))
+ (when (persistent-object-p value)
+ (assert-instance-access value (persistent-p value))))))
(def (function io) slot-boundp-or-value-using-class-d (class instance slot coordinates)
(assert-instance-slot-correspondence)
@@ -61,15 +81,20 @@
(def (function io) (setf slot-boundp-or-value-using-class-d) (new-value class instance slot)
(assert-instance-slot-correspondence)
(bind ((persistent (persistent-p instance))
- (new-value (if (not (d-value-p new-value))
- (make-single-d-value (dimensions-of slot)
- (collect-coordinates-from-variables (dimensions-of slot))
- new-value)
- new-value)))
+ (new-d-value (cond
+ ((d-value-p new-value)
+ (assert-d-value-instance-access new-value)
+ new-value)
+ (t
+ (when (persistent-object-p new-value)
+ (assert-instance-access new-value (persistent-p new-value)))
+ (make-single-d-value (dimensions-of slot)
+ (collect-coordinates-from-variables (dimensions-of slot))
+ new-value)))))
(assert-instance-access instance persistent)
(when persistent
- (store-slot class instance slot new-value))
- (update-cache class instance slot :set new-value))
+ (store-slot class instance slot new-d-value))
+ (update-cache class instance slot :set new-d-value))
new-value)
(defmethod slot-value-using-class ((class persistent-class)
diff -rN -u old-cl-perec/persistence/slot-value.lisp new-cl-perec/persistence/slot-value.lisp
--- old-cl-perec/persistence/slot-value.lisp 2014-07-24 23:47:19.000000000 -0700
+++ new-cl-perec/persistence/slot-value.lisp 2014-07-24 23:47:19.000000000 -0700
@@ -289,6 +289,8 @@
(bind ((persistent (persistent-p instance))
(cache (cache-p slot)))
(assert-instance-access instance persistent)
+ (when (persistent-object-p new-value)
+ (assert-instance-access new-value (persistent-p new-value)))
;; always store the slot into the database
(when persistent
(bind (((:values slot-value-cached cached-value)
diff -rN -u old-cl-perec/test/dimensional/complex.lisp new-cl-perec/test/dimensional/complex.lisp
--- old-cl-perec/test/dimensional/complex.lisp 2014-07-24 23:47:19.000000000 -0700
+++ new-cl-perec/test/dimensional/complex.lisp 2014-07-24 23:47:19.000000000 -0700
@@ -828,19 +828,19 @@
,@(when (and instance-variable-name slot-name)
(bind ((coordinates (prc::collect-coordinates-from-variables dimensions)))
`((with-transaction
- (with-revived-instance ,instance-variable-name
- (with-coordinates*
- ,(format-dimensions dimensions)
- ,(format-coordinates dimensions coordinates)
- (bind ((persistent-value
- (if (slot-boundp ,instance-variable-name ',slot-name)
- (slot-value ,instance-variable-name ',slot-name)
- +unbound-slot-marker+))
- (test-value
- (slot-value* ,instance-variable-name ',slot-name)))
- (assert-persistent-and-test-values
- ,instance-variable-name ',slot-name
- persistent-value test-value)))))))))))))
+ (with-revived-instance ,instance-variable-name
+ (with-coordinates*
+ ,(format-dimensions dimensions)
+ ,(format-coordinates dimensions coordinates)
+ (bind ((persistent-value
+ (if (slot-boundp ,instance-variable-name ',slot-name)
+ (slot-value ,instance-variable-name ',slot-name)
+ +unbound-slot-marker+))
+ (test-value
+ (slot-value* ,instance-variable-name ',slot-name)))
+ (assert-persistent-and-test-values
+ ,instance-variable-name ',slot-name
+ persistent-value test-value)))))))))))))
:report-function (lambda (stream)
(format stream "Print a specific test case for this error"))))
(handler-bind
@@ -850,11 +850,12 @@
(iter (with random-coordinates = (generate-random-coordinate-sets dimensions timestamp-count))
(repeat transaction-count)
(with-transaction
- (format t "Starting new transaction~%")
- (incf *transaction-counter*)
- (iter (repeat operation-count)
- (with-random-coordinates dimensions (:for-writing-p #t :choices random-coordinates)
- (do-random-operation instances :slot-names slot-names))))
+ (bind ((instances (mapcar #'load-instance instances)))
+ (format t "Starting new transaction~%")
+ (incf *transaction-counter*)
+ (iter (repeat operation-count)
+ (with-random-coordinates dimensions (:for-writing-p #t :choices random-coordinates)
+ (do-random-operation instances :slot-names slot-names)))))
(finally
(setf *history-entries* (nreverse *history-entries*))
(when full-test
diff -rN -u old-cl-perec/test/persistence/type.lisp new-cl-perec/test/persistence/type.lisp
--- old-cl-perec/test/persistence/type.lisp 2014-07-24 23:47:19.000000000 -0700
+++ new-cl-perec/test/persistence/type.lisp 2014-07-24 23:47:19.000000000 -0700
@@ -65,6 +65,8 @@
(defpclass* type-test ()
((,name :type ,type))))))
(flet ((make-object ()
+ (when (prc::persistent-object-p ,value)
+ (revive-instance ,value))
(delete-records (rdbms::sql-table-alias :name (rdbms-name-for 'type-test)))
(setf object
(apply #'make-instance
diff -rN -u old-cl-perec/test/query/type.lisp new-cl-perec/test/query/type.lisp
--- old-cl-perec/test/query/type.lisp 2014-07-24 23:47:19.000000000 -0700
+++ new-cl-perec/test/query/type.lisp 2014-07-24 23:47:19.000000000 -0700
@@ -56,6 +56,8 @@
(from (o query-type-test))
(where (not (slot-boundp o ',',name)))))))))))
(with-transaction
+ (when (prc::persistent-object-p ,value)
+ (revive-instance ,value))
(make-object)
(test-object))))))))
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.