- (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))
- (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 (slot-value instance 'view-database) nil))
- (signal-no-database-error vd))))
+ (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 (or this-class (class-of obj)))
+ (pk-slot (car (keyslots-for-class view-class)))
+ (view-class-table (view-table view-class))
+ (pclass (car (class-direct-superclasses view-class))))
+ (when (normalizedp view-class)
+ (setf pk (update-records-from-instance obj :database database
+ :this-class pclass))
+ (when pk-slot
+ (setf (slot-value obj (slot-definition-name pk-slot)) pk)))
+ (let* ((slots (remove-if-not #'slot-storedp
+ (if (normalizedp view-class)
+ (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."))
+ ((and (normalizedp view-class)
+ (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
+ obj :database database
+ :this-class view-class)
+ :database database)
+ (when pk-slot
+ (setf pk (or pk
+ (slot-value obj (slot-definition-name pk-slot))))))
+ (t
+ (insert-records :into (sql-expression :table view-class-table)
+ :av-pairs record-values
+ :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) &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 database))))