+;; this works, but is inefficient requiring (+ 1 n-rows)
+;; SQL queries
+#+ignore
+(defun fault-join-target-slot (class object slot-def)
+ (let* ((res (fault-join-slot-raw class object slot-def))
+ (dbi (view-class-slot-db-info slot-def))
+ (target-name (gethash :target-slot dbi))
+ (target-class (find-class target-name)))
+ (when res
+ (mapcar (lambda (obj)
+ (list
+ (car
+ (fault-join-slot-raw
+ target-class
+ obj
+ (find target-name (class-slots (class-of obj))
+ :key #'slot-definition-name)))
+ obj))
+ res)
+ #+ignore ;; this doesn't work when attempting to call slot-value
+ (mapcar (lambda (obj)
+ (cons obj (slot-value obj ts))) res))))
+
+(defun fault-join-target-slot (class object slot-def)
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (ts (gethash :target-slot dbi))
+ (jc (gethash :join-class dbi))
+ (ts-view-table (view-table (find-class ts)))
+ (jc-view-table (view-table (find-class jc)))
+ (tdbi (view-class-slot-db-info
+ (find ts (class-slots (find-class jc))
+ :key #'slot-definition-name)))
+ (retrieval (gethash :retrieval tdbi))
+ (jq (join-qualifier class object slot-def))
+ (key (slot-value object (gethash :home-key dbi))))
+ (when jq
+ (ecase retrieval
+ (:immediate
+ (let ((res
+ (find-all (list ts)
+ :inner-join (sql-expression :table jc-view-table)
+ :on (sql-operation
+ '==
+ (sql-expression
+ :attribute (gethash :foreign-key tdbi)
+ :table ts-view-table)
+ (sql-expression
+ :attribute (gethash :home-key tdbi)
+ :table jc-view-table))
+ :where jq
+ :result-types :auto)))
+ (mapcar #'(lambda (i)
+ (let* ((instance (car i))
+ (jcc (make-instance jc :view-database (view-database instance))))
+ (setf (slot-value jcc (gethash :foreign-key dbi))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ (slot-value instance (gethash :foreign-key tdbi)))
+ (list instance jcc)))
+ res)))
+ (:deferred
+ ;; just fill in minimal slots
+ (mapcar
+ #'(lambda (k)
+ (let ((instance (make-instance ts :view-database (view-database object)))
+ (jcc (make-instance jc :view-database (view-database object)))
+ (fk (car k)))
+ (setf (slot-value instance (gethash :home-key tdbi)) fk)
+ (setf (slot-value jcc (gethash :foreign-key dbi))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ fk)
+ (list instance jcc)))
+ (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
+ :from (sql-expression :table jc-view-table)
+ :where jq)))))))
+
+
+;;; Remote Joins
+
+(defvar *default-update-objects-max-len* nil
+ "The default maximum number of objects supplying data for a
+ query when updating remote joins.")
+
+(defun update-object-joins (objects &key (slots t) (force-p t)
+ class-name (max-len *default-update-objects-max-len*))
+ "Updates the remote join slots, that is those slots defined without
+:retrieval :immediate."
+ (assert (or (null max-len) (plusp max-len)))
+ (when objects
+ (unless class-name
+ (setq class-name (class-name (class-of (first objects)))))
+ (let* ((class (find-class class-name))
+ (class-slots (ordered-class-slots class))
+ (slotdefs
+ (if (eq t slots)
+ (generate-retrieval-joins-list class :deferred)
+ (remove-if #'null
+ (mapcar #'(lambda (name)
+ (let ((slotdef (find name class-slots :key #'slot-definition-name)))
+ (unless slotdef
+ (warn "Unable to find slot named ~S in class ~S." name class))
+ slotdef))
+ slots)))))
+ (dolist (slotdef slotdefs)
+ (let* ((dbi (view-class-slot-db-info slotdef))
+ (slotdef-name (slot-definition-name slotdef))
+ (foreign-key (gethash :foreign-key dbi))
+ (home-key (gethash :home-key dbi))
+ (object-keys
+ (remove-duplicates
+ (if force-p
+ (mapcar #'(lambda (o) (slot-value o home-key)) objects)
+ (remove-if #'null
+ (mapcar
+ #'(lambda (o) (if (slot-boundp o slotdef-name)
+ nil
+ (slot-value o home-key)))
+ objects)))))
+ (n-object-keys (length object-keys))
+ (query-len (or max-len n-object-keys)))
+
+ (do ((i 0 (+ i query-len)))
+ ((>= i n-object-keys))
+ (let* ((keys (if max-len
+ (subseq object-keys i (min (+ i query-len) n-object-keys))
+ object-keys))
+ (results (find-all (list (gethash :join-class dbi))
+ :where (make-instance 'sql-relational-exp
+ :operator 'in
+ :sub-expressions (list (sql-expression :attribute foreign-key)
+ keys))
+ :result-types :auto
+ :flatp t)))
+ (dolist (object objects)
+ (when (or force-p (not (slot-boundp object slotdef-name)))
+ (let ((res (find (slot-value object home-key) results
+ :key #'(lambda (res) (slot-value res foreign-key))
+ :test #'equal)))
+ (when res
+ (setf (slot-value object slotdef-name) res)))))))))))
+ (values))
+