X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=58622ae9304baff6f596074eb98e8e83187144ba;hp=aebadfa27b31346c0e1294f190cd7b669eb991c0;hb=26533896461bb09509b5df14c767afe85dce324d;hpb=c3e3e19b61caa55bae90f76f957591259fa3b5f1

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index aebadfa..58622ae 100644
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -130,7 +130,7 @@
 	(dbtype (specified-type slotdef)))
     (typecase dbwriter
       (string (format nil dbwriter val))
-      ((or symbol function) (apply dbwriter (list val)))
+      ((and (or symbol function) (not null)) (apply dbwriter (list val)))
       (t
        (database-output-sql-as-type
 	(typecase dbtype
@@ -381,6 +381,10 @@
   (declare (ignore args database db-type))
   "TIMESTAMP")
 
+(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
+  (declare (ignore args database db-type))
+  "DATE")
+
 (defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
   (declare (ignore database args db-type))
   "VARCHAR")
@@ -584,6 +588,11 @@
   (unless (eq 'NULL val)
     (parse-timestring val)))
 
+(defmethod read-sql-value (val (type (eql 'date)) database db-type)
+  (declare (ignore database db-type))
+  (unless (eq 'NULL val)
+    (parse-datestring val)))
+
 (defmethod read-sql-value (val (type (eql 'duration)) database db-type)
   (declare (ignore database db-type))
   (unless (or (eq 'NULL val)
@@ -618,21 +627,23 @@
 
 (defun fault-join-target-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
-	 (ts (gethash :target-slot dbi))
-	 (jc (gethash :join-class dbi))
-	 (ts-view-table (view-table (find-class ts)))
+	 (ts (gethash :target-slot dbi)) 
+	 (jc  (gethash :join-class dbi))
 	 (jc-view-table (view-table (find-class jc)))
-	 (tdbi (view-class-slot-db-info 
-		(find ts (class-slots (find-class jc))
-		      :key #'slot-definition-name)))
+	 (tdbi (view-class-slot-db-info
+		(find ts (class-slots (find-class jc)) 
+		      :key #'slot-definition-name))) 
 	 (retrieval (gethash :retrieval tdbi))
+	 (tsc (gethash :join-class tdbi))
+	 (ts-view-table (view-table (find-class tsc)))
 	 (jq (join-qualifier class object slot-def))
 	 (key (slot-value object (gethash :home-key dbi))))
+  
     (when jq
       (ecase retrieval
 	(:immediate
 	 (let ((res
-		(find-all (list ts) 
+		(find-all (list tsc) 
 			  :inner-join (sql-expression :table jc-view-table)
 			  :on (sql-operation 
 			       '==
@@ -658,7 +669,7 @@
 	    ;; just fill in minimal slots
 	    (mapcar
 	     #'(lambda (k)
-		 (let ((instance (make-instance ts :view-database (view-database object)))
+		 (let ((instance (make-instance tsc :view-database (view-database object)))
 		       (jcc (make-instance jc :view-database (view-database object)))
 		       (fk (car k)))
 		   (setf (slot-value instance (gethash :home-key tdbi)) fk)
@@ -733,24 +744,30 @@ maximum of MAX-LEN instances updated in each query."
 	    (let* ((keys (if max-len
 			     (subseq object-keys i (min (+ i query-len) n-object-keys))
 			   object-keys))
-		   (results (find-all (list (gethash :join-class dbi))
-				      :where (make-instance 'sql-relational-exp
-					       :operator 'in
-					       :sub-expressions (list (sql-expression :attribute foreign-key)
-								      keys))
-				      :result-types :auto
-				      :flatp t)))
+		   (results (unless (gethash :target-slot dbi)
+				(find-all (list (gethash :join-class dbi))
+			      :where (make-instance 'sql-relational-exp
+						    :operator 'in
+						    :sub-expressions (list (sql-expression :attribute foreign-key)
+									   keys))
+			      :result-types :auto
+			      :flatp t)) ))
 
 	      (dolist (object objects)
 		(when (or force-p (not (slot-boundp object slotdef-name)))
-		  (let ((res (remove-if-not #'(lambda (obj)
-						(equal obj (slot-value
-							    object
-							    home-key)))
-					    results
-					    :key #'(lambda (res)
-						     (slot-value res
-								 foreign-key)))))
+		  (let ((res (if results
+				 (remove-if-not #'(lambda (obj)
+						    (equal obj (slot-value
+								object
+								home-key)))
+						results
+						:key #'(lambda (res)
+							 (slot-value res
+								     foreign-key)))
+				 
+				 (progn
+				   (when (gethash :target-slot dbi)
+				     (fault-join-target-slot class object slotdef))))))
 		    (when res
 		      (setf (slot-value object slotdef-name)
 			    (if (gethash :set dbi) res (car res)))))))))))))