(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)
(mapc #'update-slot slotdeflist values)
obj))
-(defmethod update-record-from-slot ((obj standard-db-object) slot &key
- (database *default-database*))
- (let* ((database (or (view-database obj) database))
- (vct (view-table (class-of obj)))
- (sd (slotdef-for-slot-with-class slot (class-of obj))))
- (check-slot-type sd (slot-value obj slot))
- (let* ((att (view-class-slot-column sd))
- (val (db-value-from-slot sd (slot-value obj slot) database)))
- (cond ((and vct sd (view-database obj))
- (update-records (sql-expression :table vct)
- :attributes (list (sql-expression :attribute att))
- :values (list val)
- :where (key-qualifier-for-instance
- obj :database database)
- :database database))
- ((and vct sd (not (view-database obj)))
- (insert-records :into (sql-expression :table vct)
- :attributes (list (sql-expression :attribute att))
- :values (list val)
- :database database)
- (setf (slot-value obj 'view-database) database))
- (t
- (error "Unable to update record.")))))
- (values))
-
-(defmethod update-record-from-slots ((obj standard-db-object) slots &key
- (database *default-database*))
- (let* ((database (or (view-database obj) database))
- (vct (view-table (class-of obj)))
- (sds (slotdefs-for-slots-with-class slots (class-of obj)))
+(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)))
+
+(defmethod update-record-from-slot ((obj standard-db-object) slot
+ &key database)
+ (update-record-from-slots obj (list slot) :database database))
+
+(defmethod update-record-from-slots ((obj standard-db-object) slots
+ &key database)
+ (let* ((database (choose-database-for-instance obj database))
+ (vct (view-table (class-of obj)))
+ (view-class (class-of obj))
(avps (mapcar #'(lambda (s)
- (let ((val (slot-value
- obj (slot-definition-name s))))
- (check-slot-type s val)
+ (let* ((slot (etypecase s
+ (symbol (slotdef-for-slot-with-class s view-class))
+ (view-class-effective-slot-definition s)))
+ (val (slot-value
+ obj (slot-definition-name slot))))
+ (check-slot-type slot val)
(list (sql-expression
- :attribute (view-class-slot-column s))
- (db-value-from-slot s val database))))
- sds)))
+ :attribute (view-class-slot-column slot))
+ (db-value-from-slot slot val database))))
+ slots)))
(cond ((and avps (view-database obj))
(update-records (sql-expression :table vct)
:av-pairs avps
:database database)
(setf (slot-value obj 'view-database) database))
(t
- (error "Unable to update records"))))
+ (error "Unable to update record."))))
(values))
(defmethod update-records-from-instance ((obj standard-db-object) &key database)
- (let ((database (or database (view-database obj) *default-database*)))
- (labels ((slot-storedp (slot)
- (and (member (view-class-slot-db-kind slot) '(:base :key))
- (slot-boundp obj (slot-definition-name slot))))
- (slot-value-list (slot)
- (let ((value (slot-value obj (slot-definition-name slot))))
- (check-slot-type slot value)
- (list (sql-expression :attribute (view-class-slot-column slot))
- (db-value-from-slot slot value database)))))
- (let* ((view-class (class-of obj))
- (view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp
- (ordered-class-slots view-class)))
- (record-values (mapcar #'slot-value-list slots)))
- (unless record-values
- (error "No settable slots."))
- (if (view-database obj)
- (update-records (sql-expression :table view-class-table)
- :av-pairs record-values
- :where (key-qualifier-for-instance
- obj :database database)
- :database database)
- (progn
- (insert-records :into (sql-expression :table view-class-table)
- :av-pairs record-values
- :database database)
- (setf (slot-value obj 'view-database) database))))))
- (values))
-
-(defmethod delete-instance-records ((instance standard-db-object))
+ (labels ((slot-storedp (slot)
+ (and (member (view-class-slot-db-kind slot) '(:base :key))
+ (slot-boundp obj (slot-definition-name slot)))))
+ (let* ((view-class (class-of obj))
+ (slots (remove-if-not #'slot-storedp
+ (ordered-class-slots view-class))))
+ (update-record-from-slots obj slots :database database )))
+ )
+
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
(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)
- (setf (slot-value instance 'view-database) nil)
- (values))
- (signal-no-database-error vd))))
+ (database (choose-database-for-instance instance 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))))
(defmethod update-instance-from-records ((instance standard-db-object)
- &key (database *default-database*))
+ &key database)
(let* ((view-class (find-class (class-name (class-of instance))))
(view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
- (view-qual (key-qualifier-for-instance instance :database vd))
+ (database (choose-database-for-instance instance database))
+ (view-qual (key-qualifier-for-instance instance :database database))
(sels (generate-selection-list view-class))
(res (apply #'select (append (mapcar #'cdr sels)
(list :from view-table
:where view-qual
- :result-types nil
- :database vd)))))
+ :result-types nil
+ :database database)))))
(when res
(get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
(defmethod update-slot-from-record ((instance standard-db-object)
- slot &key (database *default-database*))
+ slot &key database)
(let* ((view-class (find-class (class-name (class-of instance))))
(view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
- (view-qual (key-qualifier-for-instance instance :database vd))
+ (database (choose-database-for-instance instance database))
+ (view-qual (key-qualifier-for-instance instance :database database))
(slot-def (slotdef-for-slot-with-class slot view-class))
(att-ref (generate-attribute-reference view-class slot-def))
(res (select att-ref :from view-table :where view-qual
- :result-types nil)))
+ :result-types nil)))
(when res
(get-slot-values-from-view instance (list slot-def) (car res)))))
: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 object))))
(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))
(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)
+ do (typecase (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)))
+ (handler-case
+ (unless (slot-value (nth i order-by-list) 'qualifier)
+ (setf (slot-value (nth i order-by-list) 'qualifier) table-name))
+ (simple-error ())))
(cons
- (unless (slot-value (car (nth i order-by-list)) 'qualifier)
- (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))
+ (handler-case
+ (unless (slot-value (car (nth i order-by-list)) 'qualifier)
+ (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))
+ (simple-error ())))
(clsql-sys:sql-function-exp)))
(setf (getf qualifier-args :order-by) order-by-list)))
projects / clsql.git / blobdiff