Refactored find-all and build-object to be more readable, shorter and
authorRuss Tyndall <russ@acceleration.net>
Wed, 21 Nov 2012 18:11:44 +0000 (13:11 -0500)
committerNathan Bird <nathan@acceleration.net>
Wed, 5 Dec 2012 22:52:33 +0000 (17:52 -0500)
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

sql/expressions.lisp
sql/oodml.lisp
sql/utils.lisp
tests/ds-nodes.lisp

index 29363af..8b6167b 100644 (file)
   (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
     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
index f289a49..3c65919 100644 (file)
@@ -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)))
 
index 12d5d28..dff2ab0 100644 (file)
@@ -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))
index 016c5a7..00c8af4 100644 (file)
@@ -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