From: Russ Tyndall Date: Tue, 20 Nov 2012 20:55:05 +0000 (-0500) Subject: removed generate-selection-list in favor of a make-select-list X-Git-Tag: v6.4.0~3 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=8051f42ccbb44eca6bb94b24fbc01f846041915a removed generate-selection-list in favor of a make-select-list function and object * structures this data and simplifies interactions with it * speeds up build-objects (better than pre-refactor levels) by caching this data rather than recalculating each iteration --- diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 3c65919..09de90a 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -42,57 +42,17 @@ "Turns key class and slot-def into a sql-expression representing the table and column it comes from - used by things like generate-selection-list, update-slot-from-record" + used by things like make-select-list, update-slot-from-record" (when (key-or-base-slot-p slotdef) (sql-expression :attribute (database-identifier slotdef database) :table (database-identifier vclass database)))) -;; -;; Function used by 'find-all' -;; - -(defun generate-selection-list (vclass) - (let* ((sels nil) - (this-class vclass) - (slots (if (normalizedp vclass) - (labels ((getdslots () - (let ((sl (ordered-class-direct-slots this-class))) - (cond (sl) - (t - (setf this-class - (car (class-direct-superclasses this-class))) - (getdslots)))))) - (getdslots)) - (ordered-class-slots this-class)))) - (dolist (slotdef slots) - (let ((res (generate-attribute-reference this-class slotdef))) - (when res - (push (cons slotdef res) sels)))) - (if sels - sels - (error "No slots of type :base in view-class ~A" (class-name vclass))))) - - - -(defun generate-retrieval-joins-list (vclass retrieval-method) +(defun generate-retrieval-joins-list (class retrieval-method) "Returns list of immediate join slots for a class." - (let ((join-slotdefs nil)) - (dolist (slotdef (ordered-class-slots vclass) join-slotdefs) - (when (and (eq :join (view-class-slot-db-kind slotdef)) - (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef)))) - (push slotdef join-slotdefs))))) - -(defun generate-immediate-joins-selection-list (vclass) - "Returns list of immediate join slots for a class." - (let (sels) - (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels) - (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot))) - (join-class (when join-class-name (find-class join-class-name)))) - (dolist (slotdef (ordered-class-slots join-class)) - (let ((res (generate-attribute-reference join-class slotdef))) - (when res - (push (cons slotdef res) sels)))))) - sels)) + (setf class (to-class class)) + (loop for slot in (ordered-class-slots class) + when (eql (join-slot-retrieval-method slot) retrieval-method) + collect slot)) (defun immediate-join-slots (class) (generate-retrieval-joins-list class :immediate)) @@ -415,31 +375,35 @@ (signal-no-database-error database)))) (defmethod update-instance-from-records ((instance standard-db-object) - &key (database *default-database*) - this-class) - (let* ((view-class (or this-class (class-of instance))) - (pclass (car (class-direct-superclasses view-class))) - (pres nil)) - (when (normalizedp view-class) - (setf pres (update-instance-from-records instance :database database - :this-class pclass))) - (let* ((view-table (sql-expression :table (view-table view-class))) - (vd (choose-database-for-instance instance database)) - (view-qual (key-qualifier-for-instance instance :database vd - :this-class view-class)) - (sels (generate-selection-list view-class)) - (res nil)) - (cond (view-qual - (setf res (apply #'select (append (mapcar #'cdr sels) - (list :from view-table - :where view-qual - :result-types nil - :database vd)))) - (when res - (setf (slot-value instance 'view-database) vd) - (get-slot-values-from-view instance (mapcar #'car sels) (car res)))) - (pres) - (t nil))))) + &key (database *default-database*)) + "Updates a database object with the current values stored in the database + + TODO: Should this update immediate join slots similar to build-objects? + Can we just call build-objects?, update-objects-joins? + " + + (let* ((classes-and-slots (view-classes-and-storable-slots instance)) + (vd (choose-database-for-instance instance database))) + (labels ((do-update (class-and-slots) + (let* ((select-list (make-select-list class-and-slots :do-joins-p nil)) + (view-table (sql-table select-list)) + (view-qual (key-qualifier-for-instance + instance :database vd + :this-class (view-class select-list))) + (res (when view-qual + (first + (apply #'select + (append (full-select-list select-list) + (list :from view-table + :where view-qual + :result-types nil + :database vd))))))) + (when res + (setf (slot-value instance 'view-database) vd) + (get-slot-values-from-view instance (slot-list select-list) res)) + ))) + (loop for class-and-slots in classes-and-slots + do (do-update class-and-slots))))) (defmethod get-slot-value-from-record ((instance standard-db-object) @@ -1091,29 +1055,69 @@ maximum of MAX-LEN instances updated in each query." collect tbl into rtn finally (return rtn)))) -(defun full-select-list ( classes ) - "Returns a list of sql-ref of things to select for the given classes - THIS NEEDS TO MATCH THE ORDER OF build-objects +(defclass select-list () + ((view-class :accessor view-class :initarg :view-class :initform nil) + (select-list :accessor select-list :initarg :select-list :initform nil) + (slot-list :accessor slot-list :initarg :slot-list :initform nil) + (joins :accessor joins :initarg :joins :initform nil) + (join-slots :accessor join-slots :initarg :join-slots :initform nil)) + (:documentation + "Collects the classes, slots and their respective sql representations + so that update-instance-from-recors, find-all, build-objects can share this + info and calculate it once. Joins are select-lists for each immediate join-slot + but only if make-select-list is called with do-joins-p")) + +(defmethod view-table ((o select-list)) + (view-table (view-class o))) + +(defmethod sql-table ((o select-list)) + (sql-expression :table (view-table o))) - TODO: this used to include order-by and distinct as more things to select. - distinct seems to always be used in a boolean context, so it doesnt seem - like appending it to the select makes any sense +(defun make-select-list (class-and-slots &key (do-joins-p nil)) + "Make a select-list for the current class (or class-and-slots) object." + (let* ((class-and-slots + (etypecase class-and-slots + (class-and-slots class-and-slots) + ((or symbol standard-db-class) + ;; find the first class with slots for us to select (this should be) + ;; the first of its classes / parent-classes with slots + (first (reverse (view-classes-and-storable-slots + (to-class class-and-slots))))))) + (class (view-class class-and-slots)) + (join-slots (when do-joins-p (immediate-join-slots class)))) + (multiple-value-bind (slots sqls) + (loop for slot in (slot-defs class-and-slots) + for sql = (generate-attribute-reference class slot) + collect slot into slots + collect sql into sqls + finally (return (values slots sqls))) + (unless slots + (error "No slots of type :base in view-class ~A" (class-name class))) + (make-instance + 'select-list + :view-class class + :select-list sqls + :slot-list slots + :join-slots join-slots + ;; only do a single layer of join objects + :joins (when do-joins-p + (loop for js in join-slots + collect (make-select-list + (join-slot-class js) + :do-joins-p nil))))))) + +(defun full-select-list ( select-lists ) + "Returns a list of sql-ref of things to select for the given classes - We also used to remove duplicates, but that seems like it would make - filling/building objects much more difficult so skipping for now... + THIS NEEDS TO MATCH THE ORDER OF build-objects " - (setf classes (mapcar #'to-class (listify classes))) - (mapcar - #'cdr - (loop for class in classes - appending (generate-selection-list class) - appending - (loop for join-slot in (immediate-join-slots class) - for join-class = (join-slot-class-name join-slot) - appending (generate-selection-list join-class))))) - -(defun build-objects (classes row database &optional existing-instances) + (loop for s in (listify select-lists) + appending (select-list s) + appending (loop for join in (joins s) + appending (select-list join)))) + +(defun build-objects (select-lists row database &optional existing-instances) "Used by find-all to build objects. THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST @@ -1130,21 +1134,23 @@ maximum of MAX-LEN instances updated in each query." would be multiple rows per object, but we would return an object per row " (setf existing-instances (listify existing-instances)) - (loop for class in classes - for existing = (pop existing-instances) - for object = (or existing - (make-instance class :view-database database)) - do (loop for (slot . _) in (generate-selection-list class) - do (update-slot-from-db-value object slot (pop row))) - do (loop for join-slot in (immediate-join-slots class) - for join-class = (join-slot-class-name join-slot) - for join-object = - (setf - (easy-slot-value object join-slot) + (loop + for select-list in select-lists + for class = (view-class select-list) + for existing = (pop existing-instances) + for object = (or existing + (make-instance class :view-database database)) + do (loop for slot in (slot-list select-list) + do (update-slot-from-db-value object slot (pop row))) + do (loop for join-slot in (join-slots select-list) + for join in (joins select-list) + for join-class = (view-class join) + for join-object = + (setf (easy-slot-value object join-slot) (make-instance join-class)) - do (loop for (slot . _) in (generate-selection-list join-class) - do (update-slot-from-db-value join-object slot (pop row)))) - do (when existing (instance-refreshed object)) + do (loop for slot in (slot-list join) + do (update-slot-from-db-value join-object slot (pop row)))) + do (when existing (instance-refreshed object)) collect object)) (defun find-all (view-classes @@ -1180,7 +1186,9 @@ maximum of MAX-LEN instances updated in each query." (loop for class in sclasses appending (loop for slot in (immediate-join-slots class) collect (join-slot-qualifier class slot)))) - (full-select-list (full-select-list sclasses)) + (select-lists (loop for class in sclasses + collect (make-select-list class :do-joins-p t))) + (full-select-list (full-select-list select-lists)) (where (clsql-ands (append (listify where) (listify join-where)))) #| (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%" @@ -1195,7 +1203,7 @@ maximum of MAX-LEN instances updated in each query." (return-objects (loop for row in rows for old-objs = (pop instances) - for objs = (build-objects sclasses row database + for objs = (build-objects select-lists row database (when refresh old-objs)) collecting (if flatp (delist-if-single objs)