refactored read-sql-value to centralize this logic and reduce
[clsql.git] / sql / oodml.lisp
index 09de90a0c2793943263ee93a2aa987d5263556cd..1599f17e6fcf00b38cf15089811d23410e9c8fc9 100644 (file)
     (sql-expression :attribute (database-identifier slotdef database)
                     :table (database-identifier vclass database))))
 
-(defun generate-retrieval-joins-list (class retrieval-method)
-  "Returns list of immediate join slots for a class."
+(defun get-join-slots (class &optional retrieval-method)
+  "Returns list of join slots for a class.
+
+   if a retrieval method is specified only return slots of that type
+   if the retrieval method is T, nil or :all return all join slots"
+  (assert (member retrieval-method '(nil t :all :immediate :deferred)))
   (setf class (to-class class))
-  (loop for slot in (ordered-class-slots class)
-        when (eql (join-slot-retrieval-method slot) retrieval-method)
-        collect slot))
+  (let ((all? (member retrieval-method '(nil t :all))))
+    (loop for slot in (ordered-class-slots class)
+          when (and (join-slot-p slot)
+                    (or all? (eql (join-slot-retrieval-method slot) retrieval-method)))
+          collect slot)))
 
 (defun immediate-join-slots (class)
-  (generate-retrieval-joins-list class :immediate))
+  (get-join-slots class :immediate))
 
 (defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
   "Determine which database connection to use for a standard-db-object.
    the public api"
   (update-record-from-slots obj slot :database database))
 
-(defun view-classes-and-storable-slots (class)
+(defmethod view-classes-and-storable-slots (class)
   "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
   "Makes sure that if a class has unfilled slots that claim to have a default,
    that we retrieve those defaults from the database
 
-   TODO: use update slots-from-record instead to batch this!"
+   TODO: use update-slots-from-record (doesnt exist) instead to batch this!"
   (loop for class-and-slots in (listify classes-and-slots)
         do (loop for slot in (slot-defs class-and-slots)
                  do (when (and (slot-has-default-p slot)
             (error "No view-table for class ~A"  classname))
           (sql-expression :table (view-table class))))
 
-
-(defmethod database-get-type-specifier (type args database db-type)
-  (declare (ignore type args database db-type))
-  (format nil "VARCHAR(~D)" *default-string-length*))
-
-(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "INT(~A)" (car args))
-      "INT"))
-
 (deftype tinyint ()
   "An 8-bit integer, this width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type)
-  (declare (ignore args database db-type))
-  "INT")
-
 (deftype smallint ()
   "An integer smaller than a 32-bit integer. this width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type)
-  (declare (ignore args database db-type))
-  "INT")
-
 (deftype mediumint ()
   "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'mediumint)) args database db-type)
-  (declare (ignore args database db-type))
-  "INT")
-
 (deftype bigint ()
   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
   'integer)
 
-(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
-  (declare (ignore args database db-type))
-  "BIGINT")
-
 (deftype varchar (&optional size)
   "A variable length string for the SQL varchar type."
   (declare (ignore size))
   'string)
 
-(defmethod database-get-type-specifier ((type (eql 'varchar)) args
-                                        database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "VARCHAR(~A)" (car args))
-      (format nil "VARCHAR(~D)" *default-string-length*)))
-
-(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "CHAR(~A)" (car args))
-      (format nil "VARCHAR(~D)" *default-string-length*)))
-
 (deftype universal-time ()
   "A positive integer as returned by GET-UNIVERSAL-TIME."
   '(integer 1 *))
 
-(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
-  (declare (ignore args database db-type))
-  "BIGINT")
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
-  (declare (ignore args database db-type))
-  "TIMESTAMP")
-
-(defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
-  (declare (ignore args database db-type))
-  "DATE")
-
-(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
-  (declare (ignore database args db-type))
-  "VARCHAR")
-
-(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
-  (declare (ignore database args db-type))
-  "INT8")
+(deftype generalized-boolean ()
+  "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
+  t)
 
 #+ignore
 (deftype char (&optional len)
   "A lisp type for the SQL CHAR type."
   `(string ,len))
 
-(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "FLOAT(~A)" (car args))
-      "FLOAT"))
-
-(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "FLOAT(~A)" (car args))
-      "FLOAT"))
-
-(deftype generalized-boolean ()
-  "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
-  t)
-
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
-  (declare (ignore args database db-type))
-  "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type)
+(defmethod database-get-type-specifier ((type string) args database (db-type t))
+  "Pass through the literal type as defined in the type string"
   (declare (ignore args database db-type))
-  "BOOL")
-
-(defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
-  (declare (ignore database db-type))
-  (cond
-    ((and (consp args) (= (length args) 2))
-     (format nil "NUMBER(~D,~D)" (first args) (second args)))
-    ((and (consp args) (= (length args) 1))
-     (format nil "NUMBER(~D)" (first args)))
-    (t
-     "NUMBER")))
-
-(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
-  (declare (ignore database db-type))
-  (if args
-      (format nil "CHAR(~D)" (first args))
-      "CHAR(1)"))
-
+  type)
+
+
+(defmethod database-get-type-specifier ((type symbol) args database db-type)
+  (case type
+    (char (if args
+              (format nil "CHAR(~D)" (first args))
+              "CHAR(1)"))
+    ((varchar string)
+     (if args
+         (format nil "VARCHAR(~A)" (car args))
+         (format nil "VARCHAR(~D)" *default-string-length*)))
+    ((longchar text) "text")
+    (integer (if args
+                 (format nil "INT(~A)" (car args))
+                 "INT"))
+    ((tinyint smallint mediumint) "INT")
+    ((long-float float)
+     (if args
+         (format nil "FLOAT(~A)" (car args))
+         "FLOAT"))
+    ((bigint universal-time) "BIGINT")
+    (number
+     (cond
+       ((and (consp args) (= (length args) 2))
+        (format nil "NUMBER(~D,~D)" (first args) (second args)))
+       ((and (consp args) (= (length args) 1))
+        (format nil "NUMBER(~D)" (first args)))
+       (t
+        "NUMBER")))
+    (wall-time "TIMESTAMP")
+    (date "DATE")
+    (duration "VARCHAR")
+    (money "INT8")
+    ((boolean generalized-boolean) "BOOL")
+    (t (warn "Could not determine a valid ~A type specifier for ~A ~A ~A, defaulting to VARCHAR "
+             db-type type args database)
+     (format nil "VARCHAR(~D)" *default-string-length*))))
 
 (defmethod database-output-sql-as-type (type val database db-type)
   (declare (ignore type database db-type))
   val)
 
-(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
-  (declare (ignore database db-type))
-  (progv '(*print-circle* *print-array*) '(t t)
-    (let ((escaped (prin1-to-string val)))
-      (substitute-char-string
-       escaped #\Null " "))))
-
-(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
-  (declare (ignore database db-type))
-  (if val
-      (concatenate 'string
-                   (package-name (symbol-package val))
-                   "::"
-                   (symbol-name val))
-      ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
-  (declare (ignore database db-type))
-  (if val
-      (symbol-name val)
-      ""))
-
-(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
-  (declare (ignore database db-type))
-  (progv '(*print-circle* *print-array*) '(t t)
-    (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
-  (declare (ignore database db-type))
-  (progv '(*print-circle* *print-array*) '(t t)
-    (prin1-to-string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
-  (declare (ignore database db-type))
-  (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type)
-  (declare (ignore database db-type))
-  (if val "t" "f"))
-
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (character (write-to-string val))
-    (string val)))
-
-(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
+(defmethod database-output-sql-as-type ((type symbol) val database db-type)
+  (declare (ignore database))
+  (case type ;; booleans handle null differently
+    ((boolean generalized-boolean)
+     (case db-type
+       ;; done here so it can be done once
+       ((:mssql :mysql) (if val 1 0))
+       (otherwise (if val "t" "f"))))
+    (otherwise
+     ;; in all other cases if we have nil give everyone else a shot at it,
+     ;; which by default returns nil
+     (if (null val)
+         (call-next-method)
+         (case type
+           (symbol
+            (format nil "~A::~A"
+                    (package-name (symbol-package val))
+                    (symbol-name val)))
+           (keyword (symbol-name val))
+           (string val)
+           (char (etypecase val
+                   (character (write-to-string val))
+                   (string val)))
+           (float (format nil "~F" val))
+           ((list vector array)
+            (let* ((*print-circle* t)
+                   (*print-array* t)
+                   (value (prin1-to-string val)))
+              value))
+           (otherwise (call-next-method)))))))
+
+(defmethod read-sql-value (val type database db-type
+                           &aux *read-eval*)
   (declare (ignore database db-type))
-  (if (eq (type-of val) 'null)
-      nil
-      (let ((*read-default-float-format* (type-of val)))
-       (format nil "~F" val))))
+  ;; TODO: All the read-from-strings in here do not check that
+  ;; what we read was of the correct type, should this change?
 
-(defmethod read-sql-value (val type database db-type)
-  (declare (ignore database db-type))
+  ;; TODO: Should this case `(typep val type)=>t` be an around
+  ;; method that short ciruits?
   (cond
     ((null type) val) ;;we have no desired type, just give the value
     ((typep val type) val) ;;check that it hasn't already been converted.
     ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
     (T (error "Unable to read-sql-value ~a as type ~a" val type))))
 
-(defmethod read-sql-value (val (type (eql 'string)) database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'varchar)) database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'char)) database db-type)
-  (declare (ignore database db-type))
-  (schar val 0))
-
-(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
-  (declare (ignore database db-type))
-  (when (< 0 (length val))
-    (intern (symbol-name-default-case val)
-            (find-package '#:keyword))))
-
-(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
-  (declare (ignore database db-type))
-  (when (< 0 (length val))
-    (unless (string= val (symbol-name-default-case "NIL"))
-      (read-from-string val))))
-
-(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'smallint)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'float)) database db-type)
-  (declare (ignore database db-type))
-  ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
-  (etypecase val
-    (string (float (read-from-string val)))
-    (float val)))
-
-(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
-  (declare (ignore database db-type))
-  ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
-  (etypecase val
-    (string (float
-            (let ((*read-default-float-format* 'double-float))
-              (read-from-string val))
-            1.0d0))
-    (double-float val)
-    (float (coerce val 'double-float))))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
-  (declare (ignore database db-type))
-  (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type)
-  (declare (ignore database db-type))
-  (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'number)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (read-from-string val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (etypecase val
-      (string
-       (parse-integer val))
-      (number val))))
-
-(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (parse-timestring val)))
-
-(defmethod read-sql-value (val (type (eql 'date)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (parse-datestring val)))
-
-(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
-  (declare (ignore database db-type))
-  (unless (or (eq 'NULL val)
-              (equal "NIL" val))
-    (parse-timestring val)))
+(defmethod read-sql-value (val (type symbol) database db-type
+                           ;; never eval while reading values
+                           &aux *read-eval*)
+  ;; TODO: All the read-from-strings in here do not check that
+  ;; what we read was of the correct type, should this change?
+  (unless (or (equalp "nil" val) (eql 'null val))
+    (case type
+      ((string varchar) val)
+      (char (etypecase val
+              (string (schar val 0))
+              (character val)))
+      (keyword
+       (when (< 0 (length val))
+         (intern (symbol-name-default-case val) :keyword)))
+      (symbol
+       (when (< 0 (length val))
+         (intern (symbol-name-default-case val))))
+      ((smallint mediumint bigint integer universal-time)
+       (etypecase val
+         (string (parse-integer val))
+         (number val)))
+      ((double-float float)
+       ;; ensure that whatever we got is coerced to a float of the correct
+       ;; type (eg: 1=>1.0d0)
+       (float
+        (etypecase val
+          (string (let ((*read-default-float-format*
+                          (ecase type
+                            (float 'single-float)
+                            (double-float 'double-float))))
+                    (read-from-string val)))
+          (float val))
+        (if (eql type 'double-float) 1.0d0 1.0s0)))
+      (number
+       (etypecase val
+         (string (read-from-string val))
+         (number val)))
+      ((boolean generalized-boolean)
+       (if (member val '(nil t))
+           val
+           (etypecase val
+             (string
+              (when (member val '("1" "t" "true" "y") :test #'string-equal)
+                t))
+             (number (not (zerop val))))))
+      ((wall-time duration)
+       (parse-timestring val))
+      (date
+       (parse-datestring val))
+      (t (call-next-method)))))
 
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots
   "The default value to use for the MAX-LEN keyword argument to
   UPDATE-OBJECT-JOINS.")
 
-(defun update-objects-joins (objects &key (slots t) (force-p t)
-                             class-name (max-len
-                                         *default-update-objects-max-len*))
-  "Updates from the records of the appropriate database tables
-the join slots specified by SLOTS in the supplied list of View
-Class instances OBJECTS.  SLOTS is t by default which means that
-all join slots with :retrieval :immediate are updated. CLASS-NAME
-is used to specify the View Class of all instance in OBJECTS and
-default to nil which means that the class of the first instance
-in OBJECTS is used. FORCE-P is t by default which means that all
-join slots are updated whereas a value of nil means that only
-unbound join slots are updated. MAX-LEN defaults to
-*DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that
-UPDATE-OBJECT-JOINS may issue multiple database queries with a
-maximum of MAX-LEN instances updated in each query."
+(defun %update-objects-joins-slot-defs (class slot-names)
+  "Get the slot definitions for the joins slots specified as slot-names
+   if slot-names is :immediate, :deferred or (or :all t) return all of
+   that type of slot definitions"
+  (setf class (to-class class))
+  (when (eq t slot-names) (setf slot-names :all))
+  (etypecase slot-names
+    (null nil)
+    (keyword
+     ;; slot-names is the retrieval type of the join-slot or :all
+     (get-join-slots class slot-names))
+    ((or symbol list)
+     (loop for slot in (listify slot-names)
+           for def = (find-slot-by-name class slot)
+           when (and def (join-slot-p def))
+           collecting def
+           unless (and def (join-slot-p def))
+           do (warn "Unable to find join slot named ~S in class ~S." slot class)))))
+
+(defun get-joined-objects (objects slotdef &key force-p
+                                           (batch-size *default-update-objects-max-len*))
+  "Given a list of objects and a join slot-def get the objects that need to be
+   joined to the input objects
+
+   we will query in batches as large as batch-size"
+  (when (join-slot-p slotdef)
+    (let* ((slot-name (to-slot-name slotdef))
+           (join-class (join-slot-class-name slotdef))
+           (home-key (join-slot-info-value slotdef :home-key))
+           (foreign-key (join-slot-info-value slotdef :foreign-key))
+           (foreign-key-values
+             (remove-duplicates
+              (loop for object in (listify objects)
+                    for hk = (slot-value object home-key)
+                    when (or force-p
+                             (not (slot-boundp object slot-name)))
+                    collect hk)
+              :test #'equal)))
+      ;; we want to retrieve at most batch-size objects per query
+      (flet ((fetch (keys)
+               (find-all
+                (list join-class)
+                :where (make-instance
+                        'sql-relational-exp
+                        :operator 'in
+                        :sub-expressions (list (sql-expression :attribute foreign-key)
+                                               keys))
+                :result-types :auto
+                :flatp t)))
+        (if (null batch-size)
+            (fetch foreign-key-values)
+            (loop
+              for keys = (pop-n foreign-key-values batch-size)
+              while keys
+              nconcing (fetch keys)))))))
+
+(defun %object-joins-from-list (object slot joins force-p )
+  "Given a list of objects that we are trying to join to, pull the correct
+   ones for this object"
+  (when (or force-p (not (slot-boundp object (to-slot-name slot))))
+    (let ((home-key (join-slot-info-value slot :home-key))
+          (foreign-key (join-slot-info-value slot :foreign-key)))
+      (loop for join in joins
+            when (equal (slot-value join foreign-key)
+                        (slot-value object home-key))
+            collect join))))
+
+(defun update-objects-joins (objects &key (slots :immediate) (force-p t)
+                                     class-name (max-len *default-update-objects-max-len*))
+  "Updates from the records of the appropriate database tables the join slots
+   specified by SLOTS in the supplied list of View Class instances OBJECTS.
+
+   A simpler method of causing a join-slot to be requeried is to set it to
+   unbound, then request it again.  This function has efficiency gains where
+   join-objects are shared among the `objects` (querying all join-objects,
+   then attaching them appropriately to each of the `objects`)
+
+   SLOTS can be one of:
+
+    * :immediate (DEFAULT) - refresh join slots created with :retrieval :immediate
+    * :deferred - refresh join slots created with :retrieval :deferred
+    * :all,t - refresh all join slots regardless of :retrieval
+    * list of symbols - which explicit slots to refresh
+    * a single symobl - what slot to refresh
+
+   CLASS-NAME is used to specify the View Class of all instance in OBJECTS and
+   default to nil which means that the class of the first instance in OBJECTS
+   is used.
+
+   FORCE-P is t by default which means that all join slots are updated whereas
+   a value of nil means that only unbound join slots are updated.
+
+   MAX-LEN defaults to *DEFAULT-UPDATE-OBJECTS-MAX-LEN* When non-nil this is
+   essentially a batch size for the max number of objects to query from the
+   database at a time.  If we need more than max-len we loop till we have all
+   the objects"
   (assert (or (null max-len) (plusp max-len)))
   (when objects
-    (unless class-name
-      (setq class-name (class-name (class-of (first objects)))))
+    (defaulting 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 (unless (gethash :target-slot dbi)
-                              (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 (if results
-                                 (remove-if-not #'(lambda (obj)
-                                                    (equal obj (slot-value
-                                                                object
-                                                                home-key)))
-                                                results
-                                                :key #'(lambda (res)
-                                                         (slot-value res
-                                                                     foreign-key)))
-
-                                 (progn
-                                   (when (gethash :target-slot dbi)
-                                     (fault-join-target-slot class object slotdef))))))
-                    (when res
-                      (setf (slot-value object slotdef-name)
-                            (if (gethash :set dbi) res (car res)))))))))))))
+           (slotdefs (%update-objects-joins-slot-defs class slots)))
+      (loop for slotdef in slotdefs
+            ;; all the joins we will need for *all* the objects
+            ;; which then get filtered below for each object
+            for joins = (unless (join-slot-info-value slotdef :target-slot)
+                          (get-joined-objects objects slotdef
+                                              :force-p force-p :batch-size max-len))
+            do (loop for object in objects
+                     for these-joins = ;; the joins just for this object (filtered from above)
+                                       ;; or retrieved via fault-join-target-slot
+                        (or (%object-joins-from-list object slotdef joins force-p)
+                            (when (join-slot-info-value slotdef :target-slot)
+                              (fault-join-target-slot class object slotdef)))
+                     ;; when this object has joined-objects copy them in to the correct slot
+                     do (when these-joins
+                          (setf (easy-slot-value object slotdef)
+                                (if (join-slot-info-value slotdef :set)
+                                    these-joins
+                                    (first these-joins))))))))
   (values))
 
 (defun fault-join-slot-raw (class object slot-def)
@@ -947,8 +861,6 @@ maximum of MAX-LEN instances updated in each query."
         (select jc :where jq :flatp t :result-types nil
                 :database (choose-database-for-instance object))))))
 
-
-
 (defun fault-join-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
          (ts (gethash :target-slot dbi))