-;;;; Should we not return the whole result, instead of only
-;;;; the one slot-value? We get all the values from the db
-;;;; anyway, so?
-(defun fault-join-normalized-slot (class object slot-def)
- (labels ((getsc (this-class)
- (let ((sc (car (class-direct-superclasses this-class))))
- (if (key-slots sc)
- sc
- (getsc sc)))))
- (let* ((sc (getsc class))
- (hk (slot-definition-name (car (key-slots class))))
- (fk (slot-definition-name (car (key-slots sc)))))
- (let ((jq (sql-operation '==
- (typecase fk
- (symbol
- (sql-expression
- :attribute
- (database-identifier
- (slotdef-for-slot-with-class fk sc) nil)
- :table (view-table sc)))
- (t fk))
- (typecase hk
- (symbol
- (slot-value object hk))
- (t hk)))))
-
- ;; Caching nil in next select, because in normalized mode
- ;; records can be changed through other instances (children,
- ;; parents) so changes possibly won't be noticed
- (let ((res (car (select (class-name sc) :where jq
- :flatp t :result-types nil
- :caching nil
- :database (choose-database-for-instance object))))
- (slot-name (slot-definition-name slot-def)))
-
- ;; If current class is normalized and wanted slot is not
- ;; a direct member, recurse up
- (if (and (normalizedp class)
- (not (member slot-name
- (mapcar #'(lambda (esd) (slot-definition-name esd))
- (ordered-class-direct-slots class))))
- (not (slot-boundp res slot-name)))
- (fault-join-normalized-slot sc res slot-def)
- (slot-value res slot-name)))))) )
+(defun update-fault-join-normalized-slot (class object slot-def)
+ (if (and (normalizedp class) (key-slot-p slot-def))
+ (setf (easy-slot-value object slot-def)
+ (normalized-key-value object))
+ (update-slot-from-record object slot-def)))