(mapc #'update-slot slotdeflist values)
obj))
+(defmethod choose-database-for-instance ((obj standard-db-object) 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 *default-database*))
- (let* ((database (or (view-database obj) database))
+ database)
+ (let* ((database (choose-database-for-instance 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))
(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 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)))))
(listify order-by)))
(join-where nil))
-
;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables)
(dolist (ob order-by-slots)
;; one selected table. This is required so FIND-ALL won't duplicate
;; the field
(when (and order-by (= 1 (length target-args)))
- (let ((table-name (view-table (find-class (car 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)
+ 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)))
(cond
projects / clsql.git / blobdiff