[Make `{insert,update,delete}-object' generic functions
clinton@unknownlamer.org**20110212022436
 Ignore-this: c0849fde11256b5f907723c7872b0aa4
 * Permit adding behavior around operations
 * Use `ensure-transaction' to enforce consistency of operations
 * Clear `%persistent/modifications' after UPDATEing object in database
 * Remove some dead code
] {
hunk ./src/db-access-object-sql.lisp 5
+(defgeneric insert-object (object))
+(defgeneric update-object (object))
+(defgeneric delete-object (object))
+
hunk ./src/db-access-object-sql.lisp 16
-	      (funcall query-fn (class-table-name class) fields)))))
+	      (funcall query-fn (class-table-name class)
+		       fields)))))
hunk ./src/db-access-object-sql.lisp 154
-(defun insert-object (object)
-  (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)
+(defmethod insert-object ((object standard-db-access-object))
+  (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))
hunk ./src/db-access-object-sql.lisp 195
-(defun delete-object (object)
+(defmethod delete-object ((object standard-db-access-object))
hunk ./src/db-access-object-sql.lisp 197
-
hunk ./src/db-access-object-sql.lisp 200
-
-(defun update-object (object)
+(defmethod update-object ((object standard-db-access-object))
hunk ./src/db-access-object-sql.lisp 204
-  (update-foreign-objects object)
-  (when (slot-value object '%persistent/modifications)
-    (let* ((class (class-of object))
-	   (update-query 
-	    (loop 
-	       :for (slot &rest old-value) 
-	       :in (remove-duplicates (slot-value object '%persistent/modifications) 
-				      :key #'car)
-	       :nconc (list (slot-definition-column-name (find slot (class-slots class) :key #'slot-definition-name))
-			    (if (slot-boundp object slot)
-				(let ((val (slot-value object slot)))
-				  (if (db-access-object-p val)
-				      (object-id val)
-				      val)) 
-				:NULL)))))
-      (apply #'update (class-table-name class) 
-	     :set (nconc  update-query
-			  (list  :where `(:= ,(class-id-column-name class)
-					     ,(slot-value object (class-id-column-name class))))))))
-  object)
-
-;;; fixme: old code?
-(defun update-from-object (object)
-  (let ((class (class-of object))
-	update-query
-	delayed)
-    (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd)))
-	     
-	     (push (lambda ()  (push (slot-definition-column-name slotd) update-query)
-			   (push  val update-query)) 
-		   delayed)))
-    (loop :for slotd in (class-slots class) 
-	  :do 
-		(cond ((slot-boundp-using-class class object slotd)
-		     (cond ((or (slot-definition-foreign-relation slotd)
-				)
-			    )
-			   ((slot-definition-foreign-type slotd)
-			    (set-foreign-keys-from-foreign-type-slotd
-			     (slot-value-using-class class object slotd) 
-			     object slotd
-)
-			    )
-			   (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 )))))
-    (map nil #'funcall delayed)
-    (apply #'update (class-table-name class) 
-	   :set (nconc  (nreverse update-query)
-			(list  :where `(:= ,(class-id-column-name class)
-					   ,(slot-value object (class-id-column-name class))))))
-  object))
+  (ensure-transaction ()
+    (update-foreign-objects object)
+    (when (slot-value object '%persistent/modifications)
+      (let* ((class (class-of object))
+	     (update-query 
+	      (loop 
+		 :for (slot &rest old-value) 
+		 :in (remove-duplicates (slot-value object '%persistent/modifications) 
+					:key #'car)
+		 :nconc (list (slot-definition-column-name (find slot (class-slots class) :key #'slot-definition-name))
+			      (if (slot-boundp object slot)
+				  (let ((val (slot-value object slot)))
+				    (if (db-access-object-p val)
+					(object-id val)
+					val)) 
+				  :NULL)))))
+	(apply #'update (class-table-name class) 
+	       :set (nconc  update-query
+			    (list  :where `(:= ,(class-id-column-name class)
+					       ,(slot-value object (class-id-column-name class))))))))
+    (setf (slot-value object '%persistent/modifications) '())
+    object))
hunk ./src/rofl.lisp 55
-    (with-transaction ()      
+    (ensure-transaction ()      
hunk ./src/transaction.lisp 8
-(defun call-with-transaction (fun transaction)
-  (let ((*current-transaction* transaction))
-    (funcall fun transaction)))
-
}