(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
the public api"
(update-record-from-slots obj slot :database database))
-(defun view-classes-and-storable-slots (class)
+(defmethod view-classes-and-storable-slots (class &key to-database-p)
"Get a list of all the tables we need to update and the slots on them
for non normalized classes we return the class and all its storable slots
for normalized classes we return a list of direct slots and the class they
came from for each normalized view class
+
+ to-database-p is provided so that we can read / write different data
+ to the database in different circumstances
+ (specifically clsql-helper:dirty-db-slots-mixin which only updates slots
+ that have changed )
"
(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)))
view-database slot on the object is nil then the object is assumed to be
new and is inserted"
(let ((database (choose-database-for-instance obj database))
- (classes-and-slots (view-classes-and-storable-slots obj)))
+ (classes-and-slots (view-classes-and-storable-slots obj :to-database-p t)))
(loop for class-and-slots in classes-and-slots
do (%update-instance-helper class-and-slots obj database))
(setf (slot-value obj 'view-database) database)
Can we just call build-objects?, update-objects-joins?
"
- (let* ((classes-and-slots (view-classes-and-storable-slots instance))
+ (let* ((classes-and-slots (view-classes-and-storable-slots
+ instance :to-database-p nil))
(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
(error "No view-table for class ~A" classname))
(sql-expression :table (view-table class))))
-
-(defmethod database-get-type-specifier (type args database db-type)
- (declare (ignore type args database db-type))
- (format nil "VARCHAR(~D)" *default-string-length*))
-
-(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "INT(~A)" (car args))
- "INT"))
-
(deftype tinyint ()
"An 8-bit integer, this width may vary by SQL implementation."
'integer)
-(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type)
- (declare (ignore args database db-type))
- "INT")
-
(deftype smallint ()
"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)
-(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
- (declare (ignore args database db-type))
- "BIGINT")
-
(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
- database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "VARCHAR(~A)" (car args))
- (format nil "VARCHAR(~D)" *default-string-length*)))
-
-(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "CHAR(~A)" (car args))
- (format nil "VARCHAR(~D)" *default-string-length*)))
-
(deftype universal-time ()
"A positive integer as returned by GET-UNIVERSAL-TIME."
'(integer 1 *))
-(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
- (declare (ignore args database db-type))
- "BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
- (declare (ignore args database db-type))
- "TIMESTAMP")
-
-(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
- (declare (ignore args database db-type))
- "DATE")
-
-(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
- (declare (ignore database args db-type))
- "VARCHAR")
-
-(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
- (declare (ignore database args db-type))
- "INT8")
+(deftype generalized-boolean ()
+ "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
+ t)
#+ignore
(deftype char (&optional len)
"A lisp type for the SQL CHAR type."
`(string ,len))
-(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "FLOAT(~A)" (car args))
- "FLOAT"))
-
-(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "FLOAT(~A)" (car args))
- "FLOAT"))
-
-(deftype generalized-boolean ()
- "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
- t)
-
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
+(defmethod database-get-type-specifier ((type string) args database (db-type t))
+ "Pass through the literal type as defined in the type string"
(declare (ignore args database db-type))
- "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type)
- (declare (ignore args database db-type))
- "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
- (declare (ignore database db-type))
- (cond
- ((and (consp args) (= (length args) 2))
- (format nil "NUMBER(~D,~D)" (first args) (second args)))
- ((and (consp args) (= (length args) 1))
- (format nil "NUMBER(~D)" (first args)))
+ type)
+
+
+(defmethod database-get-type-specifier ((type symbol) args database db-type)
+ (case type
+ (char (if args
+ (format nil "CHAR(~D)" (first args))
+ "CHAR(1)"))
+ ((varchar string symbol keyword)
+ (if args
+ (format nil "VARCHAR(~A)" (car args))
+ (format nil "VARCHAR(~D)" *default-string-length*)))
+ ((longchar text) "text")
+ (integer (if args
+ (format nil "INT(~A)" (car args))
+ "INT"))
+ ((tinyint smallint mediumint) "INT")
+ ((long-float float)
+ (if args
+ (format nil "FLOAT(~A)" (car args))
+ "FLOAT"))
+ ((bigint universal-time) "BIGINT")
+ (number
+ (cond
+ ((and (consp args) (= (length args) 2))
+ (format nil "NUMBER(~D,~D)" (first args) (second args)))
+ ((and (consp args) (= (length args) 1))
+ (format nil "NUMBER(~D)" (first args)))
+ (t
+ "NUMBER")))
+ (wall-time "TIMESTAMP")
+ (date "DATE")
+ (duration "VARCHAR")
+ (money "INT8")
+ ((boolean generalized-boolean) "BOOL")
+ (t (warn "Could not determine a valid ~A type specifier for ~A ~A ~A, defaulting to VARCHAR "
+ db-type type args database)
+ (format nil "VARCHAR(~D)" *default-string-length*))))
+
+(defun print-readable-symbol (in &aux (*package* (find-package :keyword))
+ (*print-readably* t))
+ (prin1-to-string in))
+
+(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))
+ (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"))))
+ ((null val)
+ (when (next-method-p)
+ (call-next-method)))
(t
- "NUMBER")))
-
-(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
- (declare (ignore database db-type))
- (if args
- (format nil "CHAR(~D)" (first args))
- "CHAR(1)"))
-
-
-(defmethod database-output-sql-as-type (type val database db-type)
- (declare (ignore type database db-type))
- val)
-
-(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (let ((escaped (prin1-to-string val)))
- (substitute-char-string
- escaped #\Null " "))))
-
-(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
- (declare (ignore database db-type))
- (if val
- (concatenate 'string
- (package-name (symbol-package val))
- "::"
- (symbol-name val))
- ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
- (declare (ignore database db-type))
- (if val
- (symbol-name val)
- ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
- (declare (ignore database db-type))
- (progv '(*print-circle* *print-array*) '(t t)
- (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
- (declare (ignore database db-type))
- (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type)
- (declare (ignore database db-type))
- (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
- (declare (ignore database db-type))
- val)
-
-(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))
- (if (eq (type-of val) 'null)
- nil
- (let ((*read-default-float-format* (type-of val)))
- (format nil "~F" val))))
+ (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 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)
- (declare (ignore database 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 (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)))
+ ;; 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))
+ (t (error-converting-value val type database))))))
;; ------------------------------------------------------------
;; Logic for 'faulting in' :join slots
(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
;; find the first class with slots for us to select (this should be)
;; the first of its classes / parent-classes with slots
(first (reverse (view-classes-and-storable-slots
- (to-class class-and-slots)))))))
+ (to-class class-and-slots)
+ :to-database-p nil))))))
(class (view-class class-and-slots))
(join-slots (when do-joins-p (immediate-join-slots class))))
(multiple-value-bind (slots sqls)
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
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))))
#|
projects / clsql.git / blobdiff