(defun update-auto-increments-keys (class obj database)
" handle pulling any autoincrement values into the object
- if normalized and we now that all the "
+ Also handles normalized key chaining"
(let ((pk-slots (keyslots-for-class class))
(table (view-table class))
new-pk-value)
- (labels ((do-update (slot)
- (when (and (null (easy-slot-value obj slot))
- (auto-increment-column-p slot database))
- (update-slot-from-db-value
- obj slot
- (or new-pk-value
- (setf new-pk-value
- (database-last-auto-increment-id
- database table slot))))))
+ (labels ((do-update (slot &aux (val (easy-slot-value obj slot)))
+ (if val
+ (setf new-pk-value val)
+ (update-slot-from-db-value
+ obj slot
+ (or new-pk-value
+ (setf new-pk-value
+ (database-last-auto-increment-id
+ database table slot))))))
+ ;; NB: This interacts very strangely with autoincrement keys
+ ;; (see changelog 2014-01-30)
(chain-primary-keys (in-class)
"This seems kindof wrong, but this is mostly how it was working, so
its here to keep the normalized code path working"
(insert-records :into table-sql
:av-pairs avps
:database database)
+ ;; also handles normalized-class key chaining
(update-auto-increments-keys view-class obj database)
;; we dont set view database here, because there could be
;; N of these for each call to update-record-from-* because
(specifically clsql-helper:dirty-db-slots-mixin which only updates slots
that have changed )
"
- (declare (ignore to-database-p))
(setf class (to-class class))
(let* (rtns)
(labels ((storable-slots (class)
(loop for sd in (slots-for-possibly-normalized-class class)
- when (key-or-base-slot-p sd)
+ when (and (key-or-base-slot-p sd)
+ ;; we dont want to insert/update auto-increments
+ ;; but we do read them
+ (not (and to-database-p (auto-increment-column-p sd))))
collect sd))
(get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
(let ((slots (storable-slots class)))
(char (if args
(format nil "CHAR(~D)" (first args))
"CHAR(1)"))
- ((varchar string)
+ ((varchar string symbol keyword)
(if args
(format nil "VARCHAR(~A)" (car args))
(format nil "VARCHAR(~D)" *default-string-length*)))
db-type type args database)
(format nil "VARCHAR(~D)" *default-string-length*))))
-(defmethod database-output-sql-as-type (type val database db-type)
- (declare (ignore type database db-type))
- val)
+(defun print-readable-symbol (in &aux (*package* (find-package :keyword))
+ (*print-readably* t))
+ (prin1-to-string in))
-(defmethod database-output-sql-as-type ((type symbol) val database db-type)
+(defmethod database-output-sql-as-type
+ (type val database db-type
+ &aux
+ (*print-circle* t) (*print-array* t)
+ (*print-length* nil) (*print-base* #10r10))
(declare (ignore database))
- (case type ;; booleans handle null differently
- ((boolean generalized-boolean)
+ (cond
+ ((null type) val)
+ ((member type '(boolean generalized-boolean))
+ ;; booleans handle null differently
(case db-type
;; done here so it can be done once
((:mssql :mysql) (if val 1 0))
(otherwise (if val "t" "f"))))
- (otherwise
- ;; in all other cases if we have nil give everyone else a shot at it,
- ;; which by default returns nil
- (if (null val)
- (call-next-method)
- (case type
- (symbol
- (format nil "~A::~A"
- (package-name (symbol-package val))
- (symbol-name val)))
- (keyword (symbol-name val))
- (string val)
- (char (etypecase val
- (character (write-to-string val))
- (string val)))
- (float (format nil "~F" val))
- ((list vector array)
- (let* ((*print-circle* t)
- (*print-array* t)
- (value (prin1-to-string val)))
- value))
- (otherwise (call-next-method)))))))
-
-(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?
+ ((null val)
+ (when (next-method-p)
+ (call-next-method)))
+ (t
+ (case type
+ ((or symbol keyword)
+ (print-readable-symbol val))
+ (string val)
+ (char (etypecase val
+ (character (write-to-string val))
+ (string val)))
+ (float (format nil "~F" val))
+ ((list vector array)
+ (prin1-to-string val))
+ (otherwise
+ (if (next-method-p)
+ (call-next-method)
+ val))))))
+
+
+(defmethod read-sql-value :around
+ (val type database db-type
+ ;; never eval while reading values, always read base 10
+ &aux *read-eval* (*read-base* #10r10))
+ (declare (ignore db-type))
(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 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
+ ;; null value or type
+ ((or (equalp "nil" val) (eql 'null val)) nil)
+
+ ;; no specified type or already the right type
+ ((or (null type)
+ (ignore-errors (typep val type)))
+ val)
+
+ ;; actually convert
+ (t
+ (let ((res (handler-bind
+ ;; all errors should be converted to sql-value-conversion-error
+ ((error (lambda (c)
+ (when *debugger-hook*
+ (invoke-debugger c))
+ (unless (typep c 'sql-value-conversion-error)
+ (error-converting-value val type database)))))
+ (call-next-method))))
+ ;; if we didnt get the right type after converting, we should probably
+ ;; error right away
+ (maybe-error-converting-value
+ res val type database)))))
+
+(defmethod read-sql-value (val type database db-type)
+ ;; errors, nulls and preconverted types are already handled in around
+ (typecase type
+ (symbol
+ (case type
+ ((string varchar) val)
+ (char (string (schar val 0)))
+ ((or keyword symbol)
+ (read-from-string val))
+ ((smallint mediumint bigint integer universal-time)
+ (parse-integer 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)))
+ ;; maybe wrong type of float
+ (float val))
+ (if (eql type 'double-float) 1.0d0 1.0s0)))
+ (number (read-from-string 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))))
+ (t (typecase 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)))))
+ (t (error-converting-value val type database))))))
;; ------------------------------------------------------------
;; Logic for 'faulting in' :join slots
projects / clsql.git / blobdiff