From: drewc <drewc@tech.coop>
Date: Sat, 27 Sep 2008 20:39:58 +0000 (-0700)
Subject: Add update to rofl
X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/08c1859263a7ae438f00ddde48e9419d8467dd8f

Add update to rofl

darcs-hash:20080927203958-39164-622f2ef885496f29af6ac04968e291f40b05f2f5.gz
---

diff --git a/src/packages.lisp b/src/packages.lisp
index 4a080d6..431c011 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -10,6 +10,7 @@
 
 ;; ROFL stuff here temporarily
    #:standard-db-access-class
+   #:standard-db-access-object
    #:make-object-from-plist
    #:described-db-access-class
    #:select-only
diff --git a/src/rofl.lisp b/src/rofl.lisp
index 20e338f..a085c65 100644
--- a/src/rofl.lisp
+++ b/src/rofl.lisp
@@ -41,6 +41,10 @@
 (defun insert-into (table &rest values-plist)
   (postmodern:execute 
    (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist))))
+
+(defun update (table &rest query)
+  (postmodern:execute 
+   (postmodern:sql-compile `(:update ,table ,@query))))
     
 
 (defclass db-access-slot-definition ()
@@ -196,13 +200,40 @@ inheritance and does not create any tables for it."))
 		(find-foreign-relations class object slotd)))
       (call-next-method)))
 
+(defun set-fkey-from-slotd (value object slotd)
+  (when (slot-boundp value (dao-id-column-name (class-of value)))
+    (setf (slot-value object (slot-definition-column-name slotd))
+	  (slot-value value (dao-id-column-name (class-of value))))))
+
+(defmethod (setf slot-value-using-class) :after 
+    (value (class standard-db-access-class) object slotd)
+  (when (and value 
+	     (typep value 'standard-db-access-object)
+	     (slot-definition-foreign-type slotd)
+	     (primary-key-boundp value))
+
+    (set-fkey-from-slotd value object slotd)))
+
+(defun find-foreign-objects (db-object)
+    (let* ((class (class-of db-object)) 
+	 (foreign-objects ))
+      (mapcar (lambda (x)
+		(and (slot-value-using-class class db-object x)  
+		     (slot-value-using-class class db-object  x)))
+	      (remove-if-not #'lol::slot-definition-foreign-type 
+			     (lol::class-slots class)))))
+
 
  (defun dao-id-column-name (class)
   (slot-definition-column-name
    (or (class-id-slot-definition class)
        (error "No ID slot (primary key) for ~A" class))))
 
+(defun db-access-object-p (thing)
+  (typep thing 'standard-db-access-object))
+
 (defun primary-key-boundp (object)
+  (check-type object standard-db-access-object) 
   (slot-boundp object (dao-id-column-name (class-of object))))
 
 (defclass described-db-access-class (described-class standard-db-access-class)
@@ -324,22 +355,66 @@ inheritance and does not create any tables for it."))
 
 (defun insert-object (object)
   (let ((class (class-of object))
-	insert-query)
+	insert-query
+	delayed)
     (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd)))
-	     (push (slot-definition-column-name slotd) insert-query)
-	     (push  val insert-query)))
+	     (push (lambda ()  (push (slot-definition-column-name slotd) insert-query)
+			   (push  val insert-query)) 
+		   delayed)))
     (loop :for slotd in (class-slots class) 
 	  :do (cond ((slot-boundp-using-class class object slotd)
-		     (unless (or (slot-definition-foreign-relation slotd)
-				 (slot-definition-foreign-type  slotd))
-		       (ins slotd)))
+		     (cond ((or (slot-definition-foreign-relation slotd)
+				)
+			    )
+			   ((slot-definition-foreign-type slotd)
+			    (set-fkey-from-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 #'insert-into (class-table-name class) (nreverse insert-query))))
   object)
 
+
+(defun update-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-fkey-from-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 `(:= ,(dao-id-column-name class)
+								     ,(slot-value object (dao-id-column-name class))
+								     ))))))
+  object)
+
 (defun select-using-object (object &key (combinator :and))
   (let ((class (class-of object))
 	select-query)
@@ -402,6 +477,7 @@ or return nil if it does not exist."
 		      (setf (slot-value-using-class class dao slotd)
 			    (find-dao foreign-type value))
 		      (let ((obj (make-instance foreign-type)))
+			(break "here")
 			(setf (slot-value-using-class 
 			       (class-of obj)
 			       obj