(push (cons slotdef res) sels))))))
sels))
+(defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
+ "Determine which database connection to use for a standard-db-object.
+ Errs if none is available."
+ (or (find-if #'(lambda (db)
+ (and db (is-database-open db)))
+ (list (view-database obj)
+ database
+ *default-database*))
+ (signal-no-database-error nil)))
+
+
;; Called by 'get-slot-values-from-view'
;;
(cond ((and value (null slot-reader))
(setf (slot-value instance slot-name)
(read-sql-value value (delistify slot-type)
- (view-database instance)
+ (choose-database-for-instance instance)
(database-underlying-type
- (view-database instance)))))
+ (choose-database-for-instance instance)))))
((null value)
(update-slot-with-null instance slot-name slotdef))
((typep slot-reader 'string)
(defmethod update-record-from-slot ((obj standard-db-object) slot &key
(database *default-database*))
- (let* ((database (or (view-database obj) database))
+ (let* ((database (choose-database-for-instance obj database))
(view-class (class-of obj)))
(when (normalizedp view-class)
;; If it's normalized, find the class that actually contains
(update-record-from-slot obj slot :database database))
(return-from update-record-from-slots (values)))
- (let* ((database (or (view-database obj) database))
+ (let* ((database (choose-database-for-instance obj database))
(vct (view-table (class-of obj)))
(sds (slotdefs-for-slots-with-class slots (class-of obj)))
(avps (mapcar #'(lambda (s)
(db-value-from-slot s val database))))
sds)))
(cond ((and avps (view-database obj))
- (update-records (sql-expression :table vct)
- :av-pairs avps
- :where (key-qualifier-for-instance
- obj :database database)
- :database database))
+ (let ((where (key-qualifier-for-instance
+ obj :database database)))
+ (unless where
+ (error "update-record-from-slots: could not generate a where clause for ~a" obj))
+ (update-records (sql-expression :table vct)
+ :av-pairs avps
+ :where where
+ :database database)))
((and avps (not (view-database obj)))
(insert-records :into (sql-expression :table vct)
:av-pairs avps
(defmethod update-records-from-instance ((obj standard-db-object)
&key database this-class)
- (let ((database (or database (view-database obj) *default-database*))
+ (let ((database (choose-database-for-instance obj database))
(pk nil))
(labels ((slot-storedp (slot)
(and (member (view-class-slot-db-kind slot) '(:base :key))
(ordered-class-direct-slots view-class)
(ordered-class-slots view-class))))
(record-values (mapcar #'slot-value-list slots)))
+
(cond ((and (not (normalizedp view-class))
(not record-values))
(error "No settable slots."))
(not record-values))
nil)
((view-database obj)
+ ;; if this slot is set, the database object was returned from a select
+ ;; and has already been in the database, so we must need an update
(update-records (sql-expression :table view-class-table)
:av-pairs record-values
:where (key-qualifier-for-instance
(setf pk (or pk
(slot-value obj (slot-definition-name pk-slot))))))
(t
- (insert-records :into (sql-expression :table view-class-table)
+ (insert-records :into (sql-expression :table view-class-table)
:av-pairs record-values
:database database)
- (when pk-slot
- (if (or (and (listp (view-class-slot-db-constraints pk-slot))
- (member :auto-increment (view-class-slot-db-constraints pk-slot)))
- (eql (view-class-slot-db-constraints pk-slot) :auto-increment))
- (setf pk (or pk
- (car (query "SELECT LAST_INSERT_ID();"
- :flatp t :field-names nil
- :database database))))
- (setf pk (or pk
- (slot-value obj (slot-definition-name pk-slot))))))
- (when (eql this-class nil)
- (setf (slot-value obj 'view-database) database)))))))
+
+ (when (and pk-slot (not pk))
+ (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot)))
+ (not (null (view-class-slot-autoincrement-sequence pk-slot))))
+ (setf (slot-value obj (slot-definition-name pk-slot))
+ (database-last-auto-increment-id database
+ view-class-table
+ pk-slot)))))
+ (when pk-slot
+ (setf pk (or pk
+ (slot-value
+ obj (slot-definition-name pk-slot)))))
+ (when (eql this-class nil)
+ (setf (slot-value obj 'view-database) database)))))))
+ ;; handle slots with defaults
+ (let* ((view-class (or this-class (class-of obj)))
+ (slots (if (normalizedp view-class)
+ (ordered-class-direct-slots view-class)
+ (ordered-class-slots view-class))))
+ (dolist (slot slots)
+ (when (and (slot-exists-p slot 'db-constraints)
+ (listp (view-class-slot-db-constraints slot))
+ (member :default (view-class-slot-db-constraints slot)))
+ (unless (and (slot-boundp obj (slot-definition-name slot))
+ (slot-value obj (slot-definition-name slot)))
+ (update-slot-from-record obj (slot-definition-name slot))))))
+
pk))
-(defmethod delete-instance-records ((instance standard-db-object))
- (let ((vt (sql-expression :table (view-table (class-of instance))))
- (vd (view-database instance)))
- (if vd
- (let ((qualifier (key-qualifier-for-instance instance :database vd)))
- (delete-records :from vt :where qualifier :database vd)
- (setf (record-caches vd) nil)
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
+ (let ((database (choose-database-for-instance instance database))
+ (vt (sql-expression :table (view-table (class-of instance)))))
+ (if database
+ (let ((qualifier (key-qualifier-for-instance instance :database database)))
+ (delete-records :from vt :where qualifier :database database)
+ (setf (record-caches database) nil)
(setf (slot-value instance 'view-database) nil)
(values))
- (signal-no-database-error vd))))
+ (signal-no-database-error database))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*)
(setf pres (update-instance-from-records instance :database database
:this-class pclass)))
(let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
+ (vd (choose-database-for-instance instance database))
(view-qual (key-qualifier-for-instance instance :database vd
:this-class view-class))
(sels (generate-selection-list view-class))
:result-types nil
:database vd))))
(when res
+ (setf (slot-value instance 'view-database) vd)
(get-slot-values-from-view instance (mapcar #'car sels) (car res))))
(pres)
(t nil)))))
(ordered-class-direct-slots this-class)))
this-class))))
(let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
+ (vd (choose-database-for-instance instance database))
(view-qual (key-qualifier-for-instance instance :database vd
:this-class view-class))
(att-ref (generate-attribute-reference view-class slot-def))
(res (select att-ref :from view-table :where view-qual
:result-types nil)))
(when res
+ (setf (slot-value instance 'view-database) vd)
(get-slot-values-from-view instance (list slot-def) (car res))))))
(defmethod update-slot-with-null ((object standard-db-object)
(format nil "~F" val))))
(defmethod read-sql-value (val type database db-type)
- (declare (ignore type database db-type))
- (read-from-string val))
+ (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))
(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)))
+ (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))
:table jc-view-table))
:where jq
:result-types :auto
- :database (view-database object))))
+ :database (choose-database-for-instance object))))
(mapcar #'(lambda (i)
(let* ((instance (car i))
- (jcc (make-instance jc :view-database (view-database instance))))
+ (jcc (make-instance jc :view-database (choose-database-for-instance instance))))
(setf (slot-value jcc (gethash :foreign-key dbi))
key)
(setf (slot-value jcc (gethash :home-key tdbi))
;; just fill in minimal slots
(mapcar
#'(lambda (k)
- (let ((instance (make-instance tsc :view-database (view-database object)))
- (jcc (make-instance jc :view-database (view-database object)))
+ (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
+ (jcc (make-instance jc :view-database (choose-database-for-instance object)))
(fk (car k)))
(setf (slot-value instance (gethash :home-key tdbi)) fk)
(setf (slot-value jcc (gethash :foreign-key dbi))
(select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
:from (sql-expression :table jc-view-table)
:where jq
- :database (view-database object))))))))
+ :database (choose-database-for-instance object))))))))
;;; Remote Joins
(let ((jq (join-qualifier class object slot-def)))
(when jq
(select jc :where jq :flatp t :result-types nil
- :database (view-database object))))))
+ :database (choose-database-for-instance object))))))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(let ((res (car (select (class-name sc) :where jq
:flatp t :result-types nil
:caching nil
- :database (view-database object))))
+ :database (choose-database-for-instance object))))
(slot-name (slot-definition-name slot-def)))
;; If current class is normalized and wanted slot is not
(car objects)
objects))))
+(defmethod select-table-sql-expr ((table T))
+ "Turns an object representing a table into the :from part of the sql expression that will be executed "
+ (sql-expression :table (view-table table)))
+
+
(defun find-all (view-classes
&rest args
&key all set-operation distinct from where group-by having
(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))
(sel-tables (collect-table-refs where))
(tables (remove-if #'null
(remove-duplicates
- (append (mapcar #'table-sql-expr sclasses)
+ (append (mapcar #'select-table-sql-expr sclasses)
(mapcan #'(lambda (jc-list)
(mapcar
- #'(lambda (jc) (when jc (table-sql-expr jc)))
+ #'(lambda (jc) (when jc (select-table-sql-expr jc)))
jc-list))
immediate-join-classes)
sel-tables)
(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)))))
+ (labels ((set-table-if-needed (val)
+ (typecase val
+ (sql-ident-attribute
+ (handler-case
+ (unless (slot-value val 'qualifier)
+ (setf (slot-value val 'qualifier) table-name))
+ (simple-error ()
+ ;; TODO: Check for a specific error we expect
+ )))
+ (cons (set-table-if-needed (car val))))))
+ (loop for i from 0 below (length order-by-list)
+ for id = (nth i order-by-list)
+ do (set-table-if-needed id)))
(setf (getf qualifier-args :order-by) order-by-list)))
(cond
projects / clsql.git / blobdiff