X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=77617e7932a23f0cf0fc9daf9d3247e2d0168c31;hp=624cadf059a1871fe4dc37c043a79aae6f75a71c;hb=2961f4f122593e9d4875e88e6af159de28c8dd47;hpb=d0695ffb828519fade3aa5166236812e6144975b diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 624cadf..77617e7 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -342,8 +342,9 @@ (declare (ignore args database db-type)) "BIGINT") -(deftype varchar () +(deftype varchar (&optional size) "A variable length string for the SQL varchar type." + (declare (ignore size)) 'string) (defmethod database-get-type-specifier ((type (eql 'varchar)) args @@ -473,13 +474,17 @@ (declare (ignore database db-type)) val) -(defmethod database-output-sql-as-type ((type (eql 'char)) - val database db-type) +(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type) (declare (ignore database db-type)) (etypecase val (character (write-to-string val)) (string val))) +(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type) + (declare (ignore database db-type)) + (let ((*read-default-float-format* (type-of val))) + (format nil "~F" val))) + (defmethod read-sql-value (val type database db-type) (declare (ignore type database db-type)) (read-from-string val)) @@ -807,10 +812,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) @@ -847,15 +871,15 @@ maximum of MAX-LEN instances updated in each query." View Classes VIEW-CLASSES are passed as arguments to SELECT." (declare (ignore all set-operation group-by having offset limit inner-join on) (optimize (debug 3) (speed 1))) - (labels ((ref-equal (ref1 ref2) - (equal (sql ref1) - (sql ref2))) - (table-sql-expr (table) - (sql-expression :table (view-table table))) - (tables-equal (table-a table-b) - (when (and table-a table-b) - (string= (string (slot-value table-a 'name)) - (string (slot-value table-b 'name)))))) + (flet ((ref-equal (ref1 ref2) + (string= (sql-output ref1 database) + (sql-output ref2 database))) + (table-sql-expr (table) + (sql-expression :table (view-table table))) + (tables-equal (table-a table-b) + (when (and table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name)))))) (remf args :from) (remf args :where) (remf args :flatp) @@ -877,17 +901,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))) @@ -906,25 +935,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 @@ -946,6 +984,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 @@ -1004,7 +1046,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*))