+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
<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>
<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>
</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>
(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)
(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))
,@(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))
(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.
(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.
(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)
))
+