(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))
-(defmethod 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
((list vector array)
(let* ((*print-circle* t)
(*print-array* t)
+ (*print-length* nil)
(value (prin1-to-string val)))
value))
(otherwise (call-next-method)))))))
(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