(SEMANTIC CHANGE) update-objects-joins now simpler and more predicatble
authorRuss Tyndall <russ@acceleration.net>
Tue, 20 Nov 2012 22:19:55 +0000 (17:19 -0500)
committerNathan Bird <nathan@acceleration.net>
Wed, 5 Dec 2012 22:52:33 +0000 (17:52 -0500)
The previous default was to update only :deferred slots but the
docstring *said* it was doing :immediate slots.

The new default is to do :immediate slots which was the specification,
and provides some consistency with the rest of the system which
defaults to only operating on :immediate slots.

New behavior for SLOTS parameter:
 * :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

 * :immediate - refresh join slots created with :retrieval :immediate
   (the default)
 * :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

Readability improvements:
 * split into a couple functions instead of one giant one.
 * standardize on loop instead of many different iteration constructs

ChangeLog
doc/ref-oodml.xml
sql/oodml.lisp
sql/utils.lisp
tests/ds-employees.lisp
tests/test-ooddl.lisp
tests/test-oodml.lisp

index 0db8fd1..f94cb36 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2012-11-20  Nathan Bird  <nathan@acceleration.net>
+
+       * update-objects-joins - changed the default of slot from t (which
+         used to mean :deferred) to :immediate (to match the default
+         behavior of other parts of the system).  It also seemed like a bad
+         default to pull all the slots that were explicitly specified to be
+         not pulled by default.  This function now accepts more special
+         values (:immediate, :deferred, :all, or a list of slots).  To get
+         the old behavior call with :slots :deferred.
+
+
 2012-10-30  Russ Tyndall <russ@acceleration.net>
        * sql/command-object.lisp - added dates/times to the parameter value
        coersion and pulled this into a new generic prepare-sql-parameter
index 50139a6..8a34235 100644 (file)
@@ -972,9 +972,11 @@ Details for Vladimir Lenin have been updated from the database.
        <varlistentry>
          <term><parameter>slots</parameter></term>
          <listitem>
-           <para>
-              A list of slot names in <parameter>object</parameter> or &t;. 
-            </para>
+           <para>* :immediate (default) - refresh join slots with :retrieval :immediate</para>
+            <para>* :deferred - refresh join slots created with :retrieval :deferred</para>
+            <para>* :all,t - refresh all join slots regardless of :retrieval</para>
+            <para>* list of symbols - which explicit slots to refresh</para>
+            <para>* a single symobl - what slot to refresh</para>
          </listitem>
        </varlistentry>
        <varlistentry>
@@ -1000,6 +1002,9 @@ Details for Vladimir Lenin have been updated from the database.
            <para>
               A non-negative integer or &nil; defaulting to
               <symbol>*default-update-objects-max-len*</symbol>.
+              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
            </para>
          </listitem>
        </varlistentry>
@@ -1007,25 +1012,15 @@ Details for Vladimir Lenin have been updated from the database.
     </refsect1>
     <refsect1>
       <title>Description</title>
-      <para>Updates from the records of the appropriate database
-      tables the join slots specified by <parameter>slots</parameter>
-      in the supplied list of <glossterm linkend="gloss-view-class">View
-      Class</glossterm> instances
-      <parameter>objects</parameter>. <parameter>slots</parameter>
-      when &t; means that all join slots with
-      <symbol>:retrieval</symbol> <symbol>:immediate</symbol> are
-      updated. <parameter>class-name</parameter> is used to specify
-      the <glossterm linkend="gloss-view-class">View Class</glossterm> of
-      all instance in <parameter>objects</parameter>, when &nil; then
-      the class of the first instance in
-      <parameter>objects</parameter> is
-      used. <parameter>force-p</parameter> when &t; means that all
-      join slots are updated whereas a value of &nil; means that only
-      unbound join slots are updated. <parameter>max-len</parameter>
-      when non-nil specifies that
-      <function>update-object-joins</function> may issue multiple
-      database queries with a maximum of
-      <parameter>max-len</parameter> instances updated in each query.
+      <para>
+        Updates from the records of the appropriate database tables the join slots
+        specified by SLOTS in the supplied list of 
+        <glossterm linkend="gloss-view-class">View Class</glossterm> 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`)
       </para>
     </refsect1>
     <refsect1>
index 09de90a..057031c 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 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 +991,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))
index dff2ab0..3162a7d 100644 (file)
     ,@(loop for (place value . rest) on place-value-plist by #'cddr
             collect `(unless ,place (setf ,place ,value)))))
 
+(defmacro pop-n (place &optional (n 1))
+  "pops n items off of a list in place and returns their values in a new list
+
+   if n > the length of the list in place, then we return the full list,
+     setting the place to nil"
+  `(loop repeat ,n
+    while ,place
+    collect (pop ,place)))
+
 (defun %get-int (v)
   (etypecase v
     (string (parse-integer v :junk-allowed t))
index 7c11874..55312a4 100644 (file)
 (defparameter employee10 nil)
 (defparameter address1 nil)
 (defparameter address2 nil)
+(defparameter address3 nil)
 (defparameter employee-address1 nil)
 (defparameter employee-address2 nil)
 (defparameter employee-address3 nil)
 (defparameter employee-address4 nil)
 (defparameter employee-address5 nil)
+(defparameter employee-address6 nil)
 
 (defclass thing ()
   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
                                   :postal-code 123)
           address2 (make-instance 'address
                                   :addressid 2)
+          address3 (make-instance 'address
+                                  :addressid 3)
           employee-address1 (make-instance 'employee-address
                                            :emplid 1
                                            :addressid 1
                                            :verified nil)
           employee-address5 (make-instance 'employee-address
                                            :emplid 3
-                                           :addressid 2)))
+                                           :addressid 2)
+          employee-address6 (make-instance 'employee-address
+                                           :emplid 4
+                                           :addressid 3)))
 
   ;; sleep to ensure birthdays are no longer at current time
   ;(sleep 1) ;want to find the test that depends on it, put the sleep there.
index 5be105c..9037e53 100644 (file)
       (slot-value (employee-manager employee2) 'last-name))
   "Lenin")
 
+(deftest :ooddl/join/4
+    (with-dataset *ds-employees*
+      (values
+       (length (employee-addresses employee10))
+       ;; add an address
+       (let ((*db-auto-sync* T))
+         (make-instance 'address :addressid 50)
+         (make-instance 'employee-address :emplid 10 :addressid 50)
+         ;; again
+         (length (employee-addresses employee10)))
+       (progn
+         (update-objects-joins (list employee10) :slots '(addresses))
+         (length (employee-addresses employee10)))))
+  0 0 1)
+
 (deftest :ooddl/big/1
     ;;tests that we can create-view-from-class with a bigint slot,
     ;; and stick a value in there.
index 4848075..da513da 100644 (file)
 
 (deftest :oodm/retrieval/4
     (with-dataset *ds-employees*
-      (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address))
+      (every #'(lambda (ea) (typep (slot-value ea 'address) 'address))
              (select 'employee-address :flatp t :caching nil)))
-  (t t t t t))
+  t)
 
 (deftest :oodm/retrieval/5
     (with-dataset *ds-employees*
-      (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address))
-             (select 'deferred-employee-address :flatp t :caching nil)))
-  (t t t t t))
+      (every #'(lambda (ea) (typep (slot-value ea 'address) 'address))
+             (select 'deferred-employee-address :flatp t :caching nil)))
+  t)
 
 (deftest :oodm/retrieval/6
     (with-dataset *ds-employees*
     (with-dataset *ds-employees*
       (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number))
              (select 'employee-address :flatp t :order-by [aaddressid] :caching nil)))
-  (10 10 nil nil nil))
+  (10 10 nil nil nil nil))
 
 (deftest :oodm/retrieval/9
     (with-dataset *ds-employees*
       (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number))
              (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil)))
-  (10 10 nil nil nil))
+  (10 10 nil nil nil nil))
 
 ;; tests update-records-from-instance
 (deftest :oodml/update-records/1
 
 (deftest :oodml/cache/1
     (with-dataset *ds-employees*
-      (progn
+      (let ((*default-caching* t))
        (setf (clsql-sys:record-caches *default-database*) nil)
        (let ((employees (select 'employee)))
          (every #'(lambda (a b) (eq a b))
 
 (deftest :oodml/cache/2
     (with-dataset *ds-employees*
-      (let ((employees (select 'employee)))
+      (let* ((*default-caching* t)
+             (employees (select 'employee)))
        (equal employees (select 'employee :flatp t))))
   nil)
 
 (deftest :oodml/refresh/1
     (with-dataset *ds-employees*
-      (let ((addresses (select 'address)))
+      (let* ((clsql-sys:*default-caching* t)
+             (addresses (select 'address)))
        (equal addresses (select 'address :refresh t))))
   t)
 
 (deftest :oodml/refresh/2
     (with-dataset *ds-employees*
-      (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t))
+      (let* ((clsql-sys:*default-caching* t)
+             (addresses (select 'address :order-by [addressid] :flatp t :refresh t))
             (city (slot-value (car addresses) 'city)))
        (clsql:update-records [addr]
                              :av-pairs '((city_field "A new city"))
 
 (deftest :oodml/refresh/3
     (with-dataset *ds-employees*
-      (let* ((addresses (select 'address :order-by [addressid] :flatp t)))
+      (let* ((clsql-sys:*default-caching* t)
+             (addresses (select 'address :order-by [addressid] :flatp t)))
        (values
          (equal addresses (select 'address :refresh t :flatp t))
          (equal addresses (select 'address :flatp t)))))
 
 (deftest :oodml/refresh/4
     (with-dataset *ds-employees*
-      (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t))
+      (let* ((clsql-sys:*default-caching* t)
+             (addresses (select 'address :order-by [addressid] :flatp t :refresh t))
             (*db-auto-sync* t))
        (make-instance 'address :addressid 1000 :city "A new address city")
        (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t)))
-         (delete-records :from [addr] :where [= [addressid] 1000])
          (values
            (length addresses)
            (length new-addresses)
            (eq (first addresses) (first new-addresses))
            (eq (second addresses) (second new-addresses))))))
-  2 3 t t)
+  3 4 t t)
 
 
-(deftest :oodml/uoj/1
+(deftest :oodml/uoj/full-set
     (with-dataset *ds-employees*
       (progn
-       (let* ((dea-list (select 'deferred-employee-address :caching nil :order-by ["ea_join" aaddressid]
-                                :flatp t))
+       (let* ((dea-list (select 'deferred-employee-address
+                           :caching nil :order-by ["ea_join" aaddressid]
+                           :flatp t))
               (dea-list-copy (copy-seq dea-list))
               (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list)))
-         (update-objects-joins dea-list)
+         (update-objects-joins dea-list :slots 'address :max-len nil)
          (values
            initially-unbound
            (equal dea-list dea-list-copy)
            (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list)
            (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list)
            (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list)))))
-  t t t t (1 1 2 2 2))
+  t t t t (1 1 2 2 2 3))
+
+(deftest :oodml/uoj/batched
+    (with-dataset *ds-employees*
+      (progn
+        (let* ((dea-list (select 'deferred-employee-address
+                           :caching nil :order-by ["ea_join" aaddressid]
+                           :flatp t))
+               (dea-list-copy (copy-seq dea-list))
+               (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list)))
+          (update-objects-joins dea-list :slots 'address :max-len 2)
+          (values
+           initially-unbound
+           (equal dea-list dea-list-copy)
+           (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list)
+           (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list)
+           (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list)))))
+  t t t t (1 1 2 2 2 3))
 
 ;; update-object-joins needs to be fixed for multiple keys
 #+ignore
-(deftest :oodml/uoj/2
+(deftest :oodml/uoj/multi-key
     (progn
       (clsql:update-objects-joins (list company1))
       (mapcar #'(lambda (e)
   t)
 ))
 
+