X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=58622ae9304baff6f596074eb98e8e83187144ba;hp=b1a5d6adc117ef8481b06a697d6dd8ee4fb89cbe;hb=26533896461bb09509b5df14c767afe85dce324d;hpb=961735a91f4baf6acfb1eef0590087a070997296 diff --git a/sql/oodml.lisp b/sql/oodml.lisp index b1a5d6a..58622ae 100644 --- 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) @@ -668,7 +680,8 @@ (list instance jcc))) (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table) :from (sql-expression :table jc-view-table) - :where jq))))))) + :where jq + :database (view-database object)))))))) ;;; Remote Joins @@ -731,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)))))))))))))