(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
(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)
(not (null (view-class-slot-autoincrement-sequence pk-slot))))
(setf (slot-value obj (slot-definition-name pk-slot))
(database-last-auto-increment-id database
- table
+ view-class-table
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))))))
+ (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
- (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)))
- (update-slot-from-record obj (slot-definition-name slot))))
+ (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))
(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