X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=e6a9457a9dacf8fa2d00b814b37ba9fed7aedc96;hb=b2ff4969e20cce173d403de7542d5bf0e46938d7;hp=8fa98903a85450c436d20258b91cdb4c81345c68;hpb=e34a3ace07250c5c55b3f6598459ef7b6d292bdb;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index 8fa9890..e6a9457 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -317,10 +317,10 @@ superclass of the newly-defined View Class." (basetype (if (listp slot-type) (car slot-type) slot-type))) (when (and slot-type val) (unless (typep val basetype) - (error 'clsql-type-error - :slotname (slot-definition-name slotdef) - :typespec slot-type - :value val))))) + (error 'sql-user-error + :message + (format nil "Invalid value ~A in slot ~A, not of type ~A." + val (slot-definition-name slotdef) slot-type)))))) ;; ;; Called by find-all @@ -423,7 +423,7 @@ superclass of the newly-defined View Class." (let ((qualifier (key-qualifier-for-instance instance :database vd))) (delete-records :from vt :where qualifier :database vd) (setf (slot-value instance 'view-database) nil)) - (error 'clsql-no-database-error :database nil)))) + (signal-no-database-error vd)))) (defmethod update-instance-from-records ((instance standard-db-object) &key (database *default-database*)) @@ -690,7 +690,11 @@ superclass of the newly-defined View Class." (defmethod read-sql-value (val (type (eql 'float)) database) (declare (ignore database)) ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) - (float (read-from-string val))) + (etypecase val + (string + (float (read-from-string val))) + (float + val))) (defmethod read-sql-value (val (type (eql 'boolean)) database) (case (database-underlying-type database) @@ -804,6 +808,13 @@ superclass of the newly-defined View Class." :from (sql-expression :table jc-view-table) :where jq))))))) + +;;; Remote Joins + +(defvar *default-update-objects-max-len* nil + "The default maximum number of objects supplying data for a + query when updating remote joins.") + (defun update-object-joins (objects &key (slots t) (force-p t) class-name (max-len *default-update-objects-max-len*)) "Updates the remote join slots, that is those slots defined without @@ -852,6 +863,7 @@ superclass of the newly-defined View Class." :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))) @@ -1013,13 +1025,16 @@ superclass of the newly-defined View Class." jcs)) immediate-join-classes) sel-tables) - :test #'tables-equal)))) - (dolist (ob (listify order-by)) + :test #'tables-equal))) + (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) + (listify order-by)))) + + (dolist (ob order-by-slots) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + order-by-slots))))) (dolist (ob (listify distinct)) (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) @@ -1111,27 +1126,54 @@ ENABLE-SQL-READER-SYNTAX." target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) + (unless (or *default-database* (getf qualifier-args :database)) + (signal-no-database-error nil)) + (cond ((select-objects target-args) (let ((caching (getf qualifier-args :caching t)) + (result-types (getf qualifier-args :result-types :auto)) (refresh (getf qualifier-args :refresh nil)) - (database (or (getf qualifier-args :database) *default-database*))) + (database (or (getf qualifier-args :database) *default-database*)) + (order-by (getf qualifier-args :order-by))) (remf qualifier-args :caching) (remf qualifier-args :refresh) + (remf qualifier-args :result-types) + + + ;; Add explicity table name to order-by if not specified and only + ;; one selected table. This is required so FIND-ALL won't duplicate + ;; the field + (when (and order-by (= 1 (length target-args))) + (let ((table-name (view-table (find-class (car target-args)))) + (order-by-list (copy-seq (listify order-by)))) + + (loop for i from 0 below (length order-by-list) + do (etypecase (nth i order-by-list) + (sql-ident-attribute + (unless (slot-value (nth i order-by-list) 'qualifier) + (setf (slot-value (nth i order-by-list) 'qualifier) table-name))) + (cons + (unless (slot-value (car (nth i order-by-list)) 'qualifier) + (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))))) + (setf (getf qualifier-args :order-by) order-by-list))) + (cond ((null caching) - (apply #'find-all target-args qualifier-args)) + (apply #'find-all target-args + (append qualifier-args (list :result-types result-types)))) (t (let ((cached (records-cache-results target-args qualifier-args database))) (cond ((and cached (not refresh)) cached) ((and cached refresh) - (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached))))) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto))))) (setf (records-cache-results target-args qualifier-args database) results) results)) (t - (let ((results (apply #'find-all target-args qualifier-args))) + (let ((results (apply #'find-all target-args (append qualifier-args + '(:result-types :auto))))) (setf (records-cache-results target-args qualifier-args database) results) results)))))))) (t @@ -1170,6 +1212,7 @@ ENABLE-SQL-READER-SYNTAX." (when value (push (list arg (typecase value + (cons (cons (sql (car value)) (cdr value))) (%sql-expression (sql value)) (t value))) results))))))