X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=aebadfa27b31346c0e1294f190cd7b669eb991c0;hp=10bd5cf31beb46beaff278150fe44f0e9f25de66;hb=67a677df17f4af2cbf6e57294605f2454c392e00;hpb=024b440ffa34c524702a648eb962d2ee6e62dee9 diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 10bd5cf..aebadfa 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))) + ((or symbol function) (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))))) @@ -327,13 +328,21 @@ "INT") (deftype smallint () - "An integer smaller than a 32-bit integer, this width may vary by SQL implementation." + "An integer smaller than a 32-bit integer. this width may vary by SQL implementation." 'integer) (defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type) (declare (ignore args database db-type)) "INT") +(deftype mediumint () + "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation." + 'integer) + +(defmethod database-get-type-specifier ((type (eql 'mediumint)) args database db-type) + (declare (ignore args database db-type)) + "INT") + (deftype bigint () "An integer larger than a 32-bit integer, this width may vary by SQL implementation." 'integer) @@ -634,7 +643,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)))) @@ -659,7 +669,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 @@ -729,21 +740,29 @@ maximum of MAX-LEN instances updated in each query." 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 (remove-if-not #'(lambda (obj) + (equal obj (slot-value + object + home-key))) + results + :key #'(lambda (res) + (slot-value res + foreign-key))))) (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)) @@ -812,10 +831,29 @@ maximum of MAX-LEN instances updated in each query." (join-vals (subseq vals (list-length selects))) (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) jclasses))) - ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals) + + ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%" + ;;joins db-vals join-vals selects immediate-selects) + ;; use refresh keyword here (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals)) - (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals)) + (mapc #'(lambda (jo) + ;; find all immediate-select slots and join-vals for this object + (let* ((slots (class-slots (class-of jo))) + (pos-list (remove-if #'null + (mapcar + #'(lambda (s) + (position s immediate-selects + :key #'car + :test #'eq)) + slots)))) + (get-slot-values-from-view jo + (mapcar #'car + (mapcar #'(lambda (pos) + (nth pos immediate-selects)) + pos-list)) + (mapcar #'(lambda (pos) (nth pos join-vals)) + pos-list)))) joins) (mapc #'(lambda (jc) @@ -882,17 +920,22 @@ maximum of MAX-LEN instances updated in each query." (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) (sel-tables (collect-table-refs where)) (tables (remove-if #'null - (remove-duplicates (append (mapcar #'table-sql-expr sclasses) - (mapcar #'(lambda (jcs) - (mapcan #'(lambda (jc) - (when jc (table-sql-expr jc))) - jcs)) - immediate-join-classes) - sel-tables) - :test #'tables-equal))) + (remove-duplicates + (append (mapcar #'table-sql-expr sclasses) + (mapcan #'(lambda (jc-list) + (mapcar + #'(lambda (jc) (when jc (table-sql-expr jc))) + jc-list)) + immediate-join-classes) + sel-tables) + :test #'tables-equal))) (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) - (listify order-by)))) - + (listify order-by))) + (join-where nil)) + + + ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables) + (dolist (ob order-by-slots) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) @@ -911,25 +954,34 @@ maximum of MAX-LEN instances updated in each query." (mapcar #'(lambda (jclass jslot) (let ((dbi (view-class-slot-db-info jslot))) - (setq where - (append - (list (sql-operation '== - (sql-expression - :attribute (gethash :foreign-key dbi) - :table (view-table jclass)) - (sql-expression - :attribute (gethash :home-key dbi) - :table (view-table vclass)))) - (when where (listify where)))))) + (setq join-where + (append + (list (sql-operation '== + (sql-expression + :attribute (gethash :foreign-key dbi) + :table (view-table jclass)) + (sql-expression + :attribute (gethash :home-key dbi) + :table (view-table vclass)))) + (when join-where (listify join-where)))))) jclasses jslots))) sclasses immediate-join-classes immediate-join-slots) + (when where + (setq where (listify where))) + (cond + ((and where join-where) + (setq where (list (apply #'sql-and where join-where)))) + ((and (null where) (> (length join-where) 1)) + (setq where (list (apply #'sql-and join-where))))) + (let* ((rows (apply #'select (append (mapcar #'cdr fullsels) (cons :from (list (append (when from (listify from)) (listify tables)))) (list :result-types result-types) - (when where (list :where where)) + (when where + (list :where where)) args))) (instances-to-add (- (length rows) (length instances))) (perhaps-extended-instances @@ -951,6 +1003,10 @@ maximum of MAX-LEN instances updated in each query." (defmethod instance-refreshed ((instance standard-db-object))) +(defvar *default-caching* t + "Controls whether SELECT caches objects by default. The CommonSQL +specification states caching is on by default.") + (defun select (&rest select-all-args) "Executes a query on DATABASE, which has a default value of *DEFAULT-DATABASE*, specified by the SQL expressions supplied @@ -1009,7 +1065,7 @@ as elements of a list." (cond ((select-objects target-args) - (let ((caching (getf qualifier-args :caching t)) + (let ((caching (getf qualifier-args :caching *default-caching*)) (result-types (getf qualifier-args :result-types :auto)) (refresh (getf qualifier-args :refresh nil)) (database (or (getf qualifier-args :database) *default-database*)) @@ -1103,7 +1159,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)