r10839: 15 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net>

[clsql.git] / sql / oodml.lisp

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index e2a487e2412c773a1d7db76f9e4a41d2639a946e..58622ae9304baff6f596074eb98e8e83187144ba 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -103,7 +103,7 @@
           ((typep slot-reader 'string)
            (setf (slot-value instance slot-name)
                  (format nil slot-reader value)))
-          ((typep slot-reader 'function)
+          ((typep slot-reader '(or symbol function))
            (setf (slot-value instance slot-name)
                  (apply slot-reader (list value))))
           (t
@@ -120,7 +120,7 @@
            nil)
           ((typep slot-reader 'string)
            (format nil slot-reader value))
-          ((typep slot-reader 'function)
+          ((typep slot-reader '(or symbol function))
            (apply slot-reader (list value)))
           (t
            (error "Slot reader is of an unusual type.")))))
@@ -130,7 +130,7 @@
        (dbtype (specified-type slotdef)))
     (typecase dbwriter
       (string (format nil dbwriter val))
-      (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)))))))))))))