[Fix object corruption when `{insert,update}-object' fail
clinton@unknownlamer.org**20110623200211
 Ignore-this: 4d83d686a7b9388e304f1cc96f6c611e
 * In both cases delay clearing/setting `%persistent/modifications'
   until after the transaction completes
 * When inserting an object with an unset PRIMARY KEY delay setting the
   primary key slot until after the insert transaction completes
] {
hunk ./src/db-access-object-sql.lisp 163
-  (ensure-transaction ()
-    (let ((class (class-of object))
-	  insert-query)
-      (flet 
-	  ((ins (slotd &optional 
-		       (val (slot-value-using-class class object slotd)))
-	     (push (slot-definition-column-name slotd) insert-query)
-	     (push  val insert-query)))
-	(loop :for slotd in (class-db-slots class) 
-	   :do (cond 
-		 ((slot-boundp-using-class class object slotd)
-		  (cond 
-		    ((slot-definition-foreign-type slotd)
-		     (ins slotd 
-			  (let ((value 
-				 (slot-value-using-class class object slotd)))
-			    (when value (slot-value value (class-id-column-name (class-of value)))))))
-		    ((slot-definition-foreign-relation slotd)
-		     ;; ignore
-		     )
-		    (t 
-		     (ins slotd))))
-		 ((slot-definition-primary-key-p slotd)
-		  (setf (slot-value-using-class class object slotd) 
-			(get-default-value (class-table-name class)
-					   (slot-definition-column-name slotd)))
-		  (ins slotd))))
-	(let ((query (loop 
-			:for (key val) 
-			:on (nreverse insert-query) 
-			:by #'cddr
-			:collect key into keys
-			:unless (find key (butlast keys))
-			:nconc (list key val) into list
-			:finally (return list))))
-	  (apply #'insert-into (class-table-name class) query))))
-    (update-foreign-objects object)
-    (mark-instance-as-persistent object)
-    object))
+  (let (set-primary-key-value!)
+    (ensure-transaction ()
+      (let ((class (class-of object))
+	    insert-query)
+	(flet
+	    ((ins (slotd &optional 
+			 (val (slot-value-using-class class object slotd)))
+		  (push (slot-definition-column-name slotd) insert-query)
+		  (push  val insert-query)))
+	  (loop :for slotd in (class-db-slots class) 
+	     :do (cond 
+		   ((slot-boundp-using-class class object slotd)
+		    (cond 
+		      ((slot-definition-foreign-type slotd)
+		       (ins slotd 
+			    (let ((value 
+				   (slot-value-using-class class object slotd)))
+			      (when value (slot-value value (class-id-column-name (class-of value)))))))
+		      ((slot-definition-foreign-relation slotd)
+		       ;; ignore
+		       )
+		      (t 
+		       (ins slotd))))
+		   ((slot-definition-primary-key-p slotd)
+		    (let ((default (get-default-value (class-table-name class)
+						      (slot-definition-column-name slotd)))
+			  (slotd slotd)) ; rebind for lambda
+		      (ins slotd default)
+		      ;; Delay setting primary key value until after
+		      ;; the transaction has committed to make a
+		      ;; failed `insert-object' more or less
+		      ;; idempotent
+		      (setf set-primary-key-value!
+			    (lambda () (setf (slot-value-using-class class object slotd)
+					default)))))))
+	  (let ((query (loop 
+			  :for (key val) 
+			  :on (nreverse insert-query) 
+			  :by #'cddr
+			  :collect key into keys
+			  :unless (find key (butlast keys))
+			  :nconc (list key val) into list
+			  :finally (return list))))
+	    (apply #'insert-into (class-table-name class) query))))
+      (update-foreign-objects object))
+    ;; AFTER committing transaction clear %f/m and mark as persistent
+    (clear-foreign-modifications object)
+    (when set-primary-key-value!
+      (funcall set-primary-key-value!))
+    (mark-instance-as-persistent object))
+  object)
hunk ./src/db-access-object-sql.lisp 243
-					       ,(slot-value object (class-id-column-name class))))))))
-    (setf (slot-value object '%persistent/modifications) '())
-    object))
+					       ,(slot-value object (class-id-column-name class)))))))))
+  ;; AFTER committing the transaction clear %f/m and %p/m
+  (clear-foreign-modifications object)
+  (setf (slot-value object '%persistent/modifications) '())
+  object)
hunk ./src/foreign-relation-slots.lisp 212
-    ;; Clear foreign modifications
-    (setf (slot-value dao '%foreign-modifications) (list))
-    (foreign-relations-makunbound dao)))
+    ;; DO NOT clear foreign modification yet -- there is a chance the
+    ;; update/insert transaction will abort!
+    ))
+
+(defun clear-foreign-modifications (dao)
+  (setf (slot-value dao '%foreign-modifications) (list))
+  (foreign-relations-makunbound dao))
}