X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=58622ae9304baff6f596074eb98e8e83187144ba;hp=142e51631d1f246eb19f8abb1a449d24ec0bd247;hb=26533896461bb09509b5df14c767afe85dce324d;hpb=4953933acb0e3349254ddfe6b1af6cc903cb5ce3 diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 142e516..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)))) @@ -248,6 +247,7 @@ (if vd (let ((qualifier (key-qualifier-for-instance instance :database vd))) (delete-records :from vt :where qualifier :database vd) + (setf (record-caches vd) nil) (setf (slot-value instance 'view-database) nil) (values)) (signal-no-database-error vd)))) @@ -261,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))))) @@ -380,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") @@ -583,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) @@ -617,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 '== @@ -642,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)))) @@ -656,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) @@ -667,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 @@ -730,28 +744,42 @@ 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 (find (slot-value object home-key) results - :key #'(lambda (res) (slot-value res foreign-key)) - :test #'equal))) + (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) res))))))))))) + (setf (slot-value object slotdef-name) + (if (gethash :set dbi) res (car res))))))))))))) (values)) - + (defun fault-join-slot-raw (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (gethash :join-class dbi))) (let ((jq (join-qualifier class object slot-def))) (when jq - (select jc :where jq :flatp t :result-types nil))))) + (select jc :where jq :flatp t :result-types nil + :database (view-database object)))))) (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) @@ -1148,7 +1176,8 @@ as elements of a list." (unless (record-caches database) (setf (record-caches database) (make-hash-table :test 'equal - #+allegro :values #+allegro :weak + #+allegro :values #+allegro :weak + #+clisp :weak #+clisp :value #+lispworks :weak-kind #+lispworks :value))) (setf (gethash (compute-records-cache-key targets qualifiers) (record-caches database)) results)