X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=092bcd3e031a63fc11968ac686fde2275568af81;hp=4197ea23b7efaa70cafbc9317a9c302b41c3d715;hb=775a7dfa8c524a06c8f9021a8390d58ecbcacf9c;hpb=f103c1a5416d2f22820d66020e4f9c18c766d894 diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 4197ea2..092bcd3 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -391,7 +391,9 @@ (let* ((classes-and-slots (view-classes-and-storable-slots instance)) (vd (choose-database-for-instance instance database))) (labels ((do-update (class-and-slots) - (let* ((select-list (make-select-list class-and-slots :do-joins-p nil)) + (let* ((select-list (make-select-list class-and-slots + :do-joins-p nil + :database database)) (view-table (sql-table select-list)) (view-qual (key-qualifier-for-instance instance :database vd @@ -576,119 +578,70 @@ value)) (otherwise (call-next-method))))))) -(defmethod read-sql-value (val type database db-type) +(defmethod read-sql-value (val type database db-type + &aux *read-eval*) (declare (ignore database db-type)) + ;; TODO: All the read-from-strings in here do not check that + ;; what we read was of the correct type, should this change? + + ;; TODO: Should this case `(typep val type)=>t` be an around + ;; method that short ciruits? (cond ((null type) val) ;;we have no desired type, just give the value ((typep val type) val) ;;check that it hasn't already been converted. ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it? (T (error "Unable to read-sql-value ~a as type ~a" val type)))) -(defmethod read-sql-value (val (type (eql 'string)) database db-type) - (declare (ignore database db-type)) - val) - -(defmethod read-sql-value (val (type (eql 'varchar)) database db-type) - (declare (ignore database db-type)) - val) - -(defmethod read-sql-value (val (type (eql 'char)) database db-type) - (declare (ignore database db-type)) - (schar val 0)) - -(defmethod read-sql-value (val (type (eql 'keyword)) database db-type) - (declare (ignore database db-type)) - (when (< 0 (length val)) - (intern (symbol-name-default-case val) - (find-package '#:keyword)))) - -(defmethod read-sql-value (val (type (eql 'symbol)) database db-type) - (declare (ignore database db-type)) - (when (< 0 (length val)) - (unless (string= val (symbol-name-default-case "NIL")) - (read-from-string val)))) - -(defmethod read-sql-value (val (type (eql 'integer)) database db-type) - (declare (ignore database db-type)) - (etypecase val - (string - (unless (string-equal "NIL" val) - (parse-integer val))) - (number val))) - -(defmethod read-sql-value (val (type (eql 'smallint)) database db-type) - (declare (ignore database db-type)) - (etypecase val - (string - (unless (string-equal "NIL" val) - (parse-integer val))) - (number val))) - -(defmethod read-sql-value (val (type (eql 'bigint)) database db-type) - (declare (ignore database db-type)) - (etypecase val - (string - (unless (string-equal "NIL" val) - (parse-integer val))) - (number val))) - -(defmethod read-sql-value (val (type (eql 'float)) database db-type) - (declare (ignore database db-type)) - ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) - (etypecase val - (string (float (read-from-string val))) - (float val))) - -(defmethod read-sql-value (val (type (eql 'double-float)) database db-type) - (declare (ignore database db-type)) - ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...) - (etypecase val - (string (float - (let ((*read-default-float-format* 'double-float)) - (read-from-string val)) - 1.0d0)) - (double-float val) - (float (coerce val 'double-float)))) - -(defmethod read-sql-value (val (type (eql 'boolean)) database db-type) - (declare (ignore database db-type)) - (equal "t" val)) - -(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type) - (declare (ignore database db-type)) - (equal "t" val)) - -(defmethod read-sql-value (val (type (eql 'number)) database db-type) - (declare (ignore database db-type)) - (etypecase val - (string - (unless (string-equal "NIL" val) - (read-from-string val))) - (number val))) - -(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type) - (declare (ignore database db-type)) - (unless (eq 'NULL val) - (etypecase val - (string - (parse-integer val)) - (number val)))) - -(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type) - (declare (ignore database db-type)) - (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) - (equal "NIL" val)) - (parse-timestring val))) +(defmethod read-sql-value (val (type symbol) database db-type + ;; never eval while reading values + &aux *read-eval*) + ;; TODO: All the read-from-strings in here do not check that + ;; what we read was of the correct type, should this change? + (unless (or (equalp "nil" val) (eql 'null val)) + (case type + ((string varchar) val) + (char (etypecase val + (string (schar val 0)) + (character val))) + (keyword + (when (< 0 (length val)) + (intern (symbol-name-default-case val) :keyword))) + (symbol + (when (< 0 (length val)) + (intern (symbol-name-default-case val)))) + ((smallint mediumint bigint integer universal-time) + (etypecase val + (string (parse-integer val)) + (number val))) + ((double-float float) + ;; ensure that whatever we got is coerced to a float of the correct + ;; type (eg: 1=>1.0d0) + (float + (etypecase val + (string (let ((*read-default-float-format* + (ecase type + (float 'single-float) + (double-float 'double-float)))) + (read-from-string val))) + (float val)) + (if (eql type 'double-float) 1.0d0 1.0s0))) + (number + (etypecase val + (string (read-from-string val)) + (number val))) + ((boolean generalized-boolean) + (if (member val '(nil t)) + val + (etypecase val + (string + (when (member val '("1" "t" "true" "y") :test #'string-equal) + t)) + (number (not (zerop val)))))) + ((wall-time duration) + (parse-timestring val)) + (date + (parse-datestring val)) + (t (call-next-method))))) ;; ------------------------------------------------------------ ;; Logic for 'faulting in' :join slots @@ -1035,7 +988,13 @@ (defmethod sql-table ((o select-list)) (sql-expression :table (view-table o))) -(defun make-select-list (class-and-slots &key (do-joins-p nil)) +(defmethod filter-select-list ((c clsql-sys::standard-db-object) + (sl clsql-sys::select-list) + database) + sl) + +(defun make-select-list (class-and-slots &key (do-joins-p nil) + (database *default-database*)) "Make a select-list for the current class (or class-and-slots) object." (let* ((class-and-slots (etypecase class-and-slots @@ -1055,18 +1014,21 @@ finally (return (values slots sqls))) (unless slots (error "No slots of type :base in view-class ~A" (class-name class))) - (make-instance - 'select-list - :view-class class - :select-list sqls - :slot-list slots - :join-slots join-slots - ;; only do a single layer of join objects - :joins (when do-joins-p - (loop for js in join-slots - collect (make-select-list - (join-slot-class js) - :do-joins-p nil))))))) + (let ((sl (make-instance + 'select-list + :view-class class + :select-list sqls + :slot-list slots + :join-slots join-slots + ;; only do a single layer of join objects + :joins (when do-joins-p + (loop for js in join-slots + collect (make-select-list + (join-slot-class js) + :do-joins-p nil + :database database)))))) + (filter-select-list (make-instance class) sl database) + sl)))) (defun full-select-list ( select-lists ) "Returns a list of sql-ref of things to select for the given classes @@ -1148,7 +1110,7 @@ appending (loop for slot in (immediate-join-slots class) collect (join-slot-qualifier class slot)))) (select-lists (loop for class in sclasses - collect (make-select-list class :do-joins-p t))) + collect (make-select-list class :do-joins-p t :database database))) (full-select-list (full-select-list select-lists)) (where (clsql-ands (append (listify where) (listify join-where)))) #|