From: Russ Tyndall Date: Wed, 21 Nov 2012 18:11:44 +0000 (-0500) Subject: Refactored find-all and build-object to be more readable, shorter and X-Git-Tag: v6.4.0~4 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=b50166ae0ba2bc09a9094c0e675ec92010b7293e Refactored find-all and build-object to be more readable, shorter and less buggy * handles not double referencing inner-join tables now * better able to find table references and better at not duplicating * removed order-by and distinct from the select-list rather passing them as :order-by and :distinct --- diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 29363af..8b6167b 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -249,6 +249,10 @@ (declare (ignore sql)) nil) +(defmethod collect-table-refs ((sql list)) + (loop for i in sql + appending (listify (collect-table-refs i)))) + (defmethod collect-table-refs ((sql sql-ident-attribute)) (let ((qual (slot-value sql 'qualifier))) (when qual @@ -286,6 +290,9 @@ sql `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) +(defmethod collect-table-refs ((sql sql-ident-table)) + (list sql)) + (defmethod output-sql ((expr sql-ident-table) database) (with-slots (name alias) expr (flet ((p (s) ;; the etypecase is in sql-escape too diff --git a/sql/oodml.lisp b/sql/oodml.lisp index f289a49..3c65919 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -94,6 +94,9 @@ (push (cons slotdef res) sels)))))) sels)) +(defun immediate-join-slots (class) + (generate-retrieval-joins-list class :immediate)) + (defmethod choose-database-for-instance ((obj standard-db-object) &optional database) "Determine which database connection to use for a standard-db-object. Errs if none is available." @@ -1038,74 +1041,111 @@ maximum of MAX-LEN instances updated in each query." (t hk)) collect (sql-operation '== fk-sql hk-val)))))) -;; FIXME: add retrieval immediate for efficiency -;; For example, for (select 'employee-address) in test suite => -;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g - -(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances) - "Used by find-all to build objects." - (labels ((build-object (vals vclass jclasses selects immediate-selects instance) - (let* ((db-vals (butlast vals (- (list-length vals) - (list-length selects)))) - (obj (if instance instance (make-instance (class-name vclass) :view-database database))) - (join-vals (subseq vals (list-length selects))) - (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) - jclasses))) - - ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%" - ;;joins db-vals join-vals selects immediate-selects) - - ;; use refresh keyword here - (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals)) - (mapc #'(lambda (jo) - ;; find all immediate-select slots and join-vals for this object - (let* ((jo-class (class-of jo)) - (slots (slots-for-possibly-normalized-class jo-class)) - (pos-list (remove-if #'null - (mapcar - #'(lambda (s) - (position s immediate-selects - :key #'car - :test #'eq)) - slots)))) - (get-slot-values-from-view jo - (mapcar #'car - (mapcar #'(lambda (pos) - (nth pos immediate-selects)) - pos-list)) - (mapcar #'(lambda (pos) (nth pos join-vals)) - pos-list)))) - joins) - (mapc - #'(lambda (jc) - (let* ((vslots - (class-slots vclass)) - (slot (find (class-name (class-of jc)) vslots - :key #'(lambda (slot) - (when (and (eq :join (view-class-slot-db-kind slot)) - (eq (slot-definition-name slot) - (gethash :join-class (view-class-slot-db-info slot)))) - (slot-definition-name slot)))))) - (when slot - (setf (slot-value obj (slot-definition-name slot)) jc)))) - joins) - (when refresh (instance-refreshed obj)) - obj))) - (let* ((objects - (mapcar #'(lambda (sclass jclass sel immediate-join instance) - (prog1 - (build-object vals sclass jclass sel immediate-join instance) - (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join)) - vals)))) - sclasses immediate-join-classes sels immediate-joins instances))) - (if (and flatp (= (length sclasses) 1)) - (car objects) - objects)))) - (defmethod select-table-sql-expr ((table T)) "Turns an object representing a table into the :from part of the sql expression that will be executed " (sql-expression :table (view-table table))) +(defun select-reference-equal (r1 r2) + "determines if two sql select references are equal + using database identifier equal" + (flet ((id-of (r) + (etypecase r + (cons (cdr r)) + (sql-ident-attribute r)))) + (database-identifier-equal (id-of r1) (id-of r2)))) + +(defun join-slot-qualifier (class join-slot) + "Creates a sql-expression expressing the join between the home-key on the table + and its respective key on the joined-to-table" + (sql-operation + '== + (sql-expression + :attribute (join-slot-info-value join-slot :foreign-key) + :table (view-table (join-slot-class join-slot))) + (sql-expression + :attribute (join-slot-info-value join-slot :home-key) + :table (view-table class)))) + +(defun all-immediate-join-classes-for (classes) + "returns a list of all join-classes needed for a list of classes" + (loop for class in (listify classes) + appending (loop for slot in (immediate-join-slots class) + collect (join-slot-class slot)))) + +(defun %tables-for-query (classes from where inner-joins) + "Given lists of classes froms wheres and inner-join compile a list + of tables that should appear in the FROM section of the query. + + This includes any immediate join classes from each of the classes" + (let ((inner-join-tables (collect-table-refs (listify inner-joins)))) + (loop for tbl in (append + (mapcar #'select-table-sql-expr classes) + (mapcar #'select-table-sql-expr + (all-immediate-join-classes-for classes)) + (collect-table-refs (listify where)) + (collect-table-refs (listify from))) + when (and tbl + (not (find tbl rtn :test #'database-identifier-equal)) + ;; TODO: inner-join is currently hacky as can be + (not (find tbl inner-join-tables :test #'database-identifier-equal))) + 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 + + 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 + + We also used to remove duplicates, but that seems like it would make + filling/building objects much more difficult so skipping for now... + " + (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) + "Used by find-all to build objects. + + THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST + + TODO: this caching scheme seems bad for a number of reasons + * order is not guaranteed so references being held by one object + might change to represent a different database row (seems HIGHLY + suspect) + * also join objects are overwritten rather than refreshed + + TODO: the way we handle immediate joins seems only valid if it is a single + object. I suspect that making a :set :immediate join column would result + in an invalid number of objects returned from the database, because there + 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) + (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)) + collect object)) (defun find-all (view-classes &rest args @@ -1115,108 +1155,52 @@ maximum of MAX-LEN instances updated in each query." (database *default-database*) instances parameters) "Called by SELECT to generate object query results when the - View Classes VIEW-CLASSES are passed as arguments to SELECT." - (declare (ignore all set-operation group-by having offset limit inner-join on parameters) + View Classes VIEW-CLASSES are passed as arguments to SELECT. + + TODO: the caching scheme of passing in instances and overwriting their + values seems bad for a number of reasons + * order is not guaranteed so references being held by one object + might change to represent a different database row (seems HIGHLY + suspect) + + TODO: the way we handle immediate joins seems only valid if it is a single + object. I suspect that making a :set :immediate join column would result + in an invalid number of objects returned from the database, because there + would be multiple objects returned from the database + " + (declare (ignore all set-operation group-by having offset limit on parameters + distinct order-by) (dynamic-extent args)) - (flet ((ref-equal (ref1 ref2) - (string= (sql-output ref1 database) - (sql-output ref2 database)))) - (declare (dynamic-extent (function ref-equal))) - (let ((args (filter-plist args :from :where :flatp :additional-fields :result-types :instances))) - (let* ((*db-deserializing* t) - (sclasses (mapcar #'find-class view-classes)) - (immediate-join-slots - (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses)) - (immediate-join-classes - (mapcar #'(lambda (jcs) - (mapcar #'(lambda (slotdef) - (find-class (gethash :join-class (view-class-slot-db-info slotdef)))) - jcs)) - immediate-join-slots)) - (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses)) - (sels (mapcar #'generate-selection-list sclasses)) - (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) - (sel-tables (collect-table-refs where)) - (tables (remove-if #'null - (remove-duplicates - (append (mapcar #'select-table-sql-expr sclasses) - (mapcan #'(lambda (jc-list) - (mapcar - #'(lambda (jc) (when jc (select-table-sql-expr jc))) - jc-list)) - immediate-join-classes) - sel-tables) - :test #'database-identifier-equal))) - (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) - (listify order-by))) - (join-where nil)) - - ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables) - - (dolist (ob order-by-slots) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - order-by-slots))))) - (dolist (ob (listify distinct)) - (when (and (typep ob 'sql-ident) - (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (mapcar #'(lambda (vclass jclasses jslots) - (when jclasses - (mapcar - #'(lambda (jclass jslot) - (let ((dbi (view-class-slot-db-info jslot))) - (setq join-where - (append - (list (sql-operation '== - (sql-expression - :attribute (gethash :foreign-key dbi) - :table (view-table jclass)) - (sql-expression - :attribute (gethash :home-key dbi) - :table (view-table vclass)))) - (when join-where (listify join-where)))))) - jclasses jslots))) - sclasses immediate-join-classes immediate-join-slots) - ;; Reported buggy on clsql-devel - ;; (when where (setq where (listify where))) - (cond - ((and where join-where) - (setq where (list (apply #'sql-and where join-where)))) - ((and (null where) (> (length join-where) 1)) - (setq where (list (apply #'sql-and join-where))))) - - (let* ((rows (apply #'select - (append (mapcar #'cdr fullsels) - (cons :from - (list (append (when from (listify from)) - (listify tables)))) - (list :result-types result-types) - (when where - (list :where where)) - args))) - (instances-to-add (- (length rows) (length instances))) - (perhaps-extended-instances - (if (plusp instances-to-add) - (append instances (do ((i 0 (1+ i)) - (res nil)) - ((= i instances-to-add) res) - (push (make-list (length sclasses) :initial-element nil) res))) - instances)) - (objects (mapcar - #'(lambda (row instance) - (build-objects row sclasses immediate-join-classes sels - immediate-join-sels database refresh flatp - (if (and flatp (atom instance)) - (list instance) - instance))) - rows perhaps-extended-instances))) - objects))))) + (let* ((args (filter-plist + args :from :where :flatp :additional-fields :result-types :instances)) + (*db-deserializing* t) + (sclasses (mapcar #'to-class view-classes)) + (tables (%tables-for-query sclasses from where inner-join)) + (join-where + (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)) + (where (clsql-ands (append (listify where) (listify join-where)))) + #| + (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%" + sclasses immediate-join-classes tables)) + |# + (rows (apply #'select + (append full-select-list + (list :from tables + :result-types result-types + :where where) + args))) + (return-objects + (loop for row in rows + for old-objs = (pop instances) + for objs = (build-objects sclasses row database + (when refresh old-objs)) + collecting (if flatp + (delist-if-single objs) + objs)))) + return-objects)) (defmethod instance-refreshed ((instance standard-db-object))) diff --git a/sql/utils.lisp b/sql/utils.lisp index 12d5d28..dff2ab0 100644 --- a/sql/utils.lisp +++ b/sql/utils.lisp @@ -455,6 +455,12 @@ removed. keys are searched with #'MEMBER" (symbol (find-class it)) (standard-object (class-of it)))) +(defun to-class-name (o) + (etypecase o + (symbol o) + (standard-class (class-name o)) + (standard-object (class-name (class-of o))))) + (defun easy-slot-value (obj slot) "like slot-value except it accepts slot-names or defs and returns nil when the slot is unbound" @@ -466,3 +472,8 @@ removed. keys are searched with #'MEMBER" "like slot-value except it accepts slot-names or defs" (setf (slot-value obj (to-slot-name slot)) new)) +(defun delist-if-single (x) + "if this is a single item in a list return it" + (if (and (listp x) (= 1 (length x))) + (first x) + x)) diff --git a/tests/ds-nodes.lisp b/tests/ds-nodes.lisp index 016c5a7..00c8af4 100644 --- a/tests/ds-nodes.lisp +++ b/tests/ds-nodes.lisp @@ -18,7 +18,6 @@ (defparameter subloc2 nil) - ;; classes for testing the normalizedp stuff (def-view-class node () ((node-id :accessor node-id :initarg :node-id