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 a5b080f01f15f1007c5be49b0513df84b113dbf9..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
@@ -211,9 +211,8 @@
            (error "Unable to update records"))))
   (values))
 
-(defmethod update-records-from-instance ((obj standard-db-object)
-                                         &key (database *default-database*))
-  (let ((database (or (view-database obj) database)))
+(defmethod update-records-from-instance ((obj standard-db-object) &key database)
+  (let ((database (or database (view-database obj) *default-database*)))
     (labels ((slot-storedp (slot)
               (and (member (view-class-slot-db-kind slot) '(:base :key))
                    (slot-boundp obj (slot-definition-name slot))))
@@ -262,8 +261,9 @@
          (sels (generate-selection-list view-class))
          (res (apply #'select (append (mapcar #'cdr sels)
                                       (list :from  view-table
-                                            :where view-qual)
-                                     (list :result-types nil)))))
+                                            :where view-qual
+                                           :result-types nil
+                                           :database vd)))))
     (when res
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
@@ -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 
                               '==
@@ -643,7 +654,8 @@
                                :attribute (gethash :home-key tdbi) 
                                :table jc-view-table))
                          :where jq
-                         :result-types :auto)))
+                         :result-types :auto
+                         :database (view-database object))))
           (mapcar #'(lambda (i)
                       (let* ((instance (car i))
                              (jcc (make-instance jc :view-database (view-database instance))))
@@ -657,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)
@@ -732,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)))))))))))))