From: Kevin M. Rosenberg Date: Wed, 1 Sep 2004 18:17:58 +0000 (+0000) Subject: r9951: Automated commit for Debian build of clsql upstream-version-3.0.1 X-Git-Tag: v3.8.6~249 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=24a4186aa531c3e56953413119e2308bb7c50b6b r9951: Automated commit for Debian build of clsql upstream-version-3.0.1 --- diff --git a/ChangeLog b/ChangeLog index 9935200..c91e688 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +01 Sep 2004 Kevin Rosenberg + * Version 3.0.1 Release + * tests/test-init.lisp: Add second join class to employee-address + to test a class with two join slots. + * sql/oodml.lisp: Fix find-all function for a class with multiple + join slots + * TODO: Remove need to test/fix multiple join classes + 27 Aug 2004 Kevin Rosenberg * db-mysql/Makefile, db-mysql/mysql-loader.lisp: accept patch from Jon Buffington for file locations on Darwin. diff --git a/TODO b/TODO index 190156e..87949bf 100644 --- a/TODO +++ b/TODO @@ -6,9 +6,6 @@ TESTS TO ADD * Number and Char field types * symbol slot * generalized-boolean slot -* Table with two join slots (bug reported on clsql-help 8/13/04 about - SQL FROM clause missing the second join table and the WHERE clause - having an ',' instead of ' AND ' joining phrases. OPTIMIZATIONS diff --git a/debian/changelog b/debian/changelog index fa20f99..cd98296 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +cl-sql (3.0.1-1) unstable; urgency=medium + + * New upstream, important bug fix for classes with multiple join + classes + + -- Kevin M. Rosenberg Wed, 1 Sep 2004 12:16:40 -0600 + cl-sql (3.0.0-2) unstable; urgency=low * Change assignment in rules file diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 10bd5cf..c98342e 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -812,10 +812,29 @@ maximum of MAX-LEN instances updated in each query." (join-vals (subseq vals (list-length selects))) (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) jclasses))) - ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals) + + ;;(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 (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals)) + (mapc #'(lambda (jo) + ;; find all immediate-select slots and join-vals for this object + (let* ((slots (class-slots (class-of jo))) + (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) @@ -882,17 +901,22 @@ maximum of MAX-LEN instances updated in each query." (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) (sel-tables (collect-table-refs where)) (tables (remove-if #'null - (remove-duplicates (append (mapcar #'table-sql-expr sclasses) - (mapcar #'(lambda (jcs) - (mapcan #'(lambda (jc) - (when jc (table-sql-expr jc))) - jcs)) - immediate-join-classes) - sel-tables) - :test #'tables-equal))) + (remove-duplicates + (append (mapcar #'table-sql-expr sclasses) + (mapcan #'(lambda (jc-list) + (mapcar + #'(lambda (jc) (when jc (table-sql-expr jc))) + jc-list)) + immediate-join-classes) + sel-tables) + :test #'tables-equal))) (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) - (listify order-by)))) - + (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))) @@ -911,25 +935,34 @@ maximum of MAX-LEN instances updated in each query." (mapcar #'(lambda (jclass jslot) (let ((dbi (view-class-slot-db-info jslot))) - (setq 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 where (listify where)))))) + (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) + (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)) + (when where + (list :where where)) args))) (instances-to-add (- (length rows) (length instances))) (perhaps-extended-instances diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 5fc308d..b1a8934 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -164,6 +164,11 @@ :db-info (:join-class address :home-key aaddressid :foreign-key addressid + :retrieval :immediate)) + (employee :db-kind :join + :db-info (:join-class employee + :home-key aemplid + :foreign-key emplid :retrieval :immediate))) (:base-table "ea_join"))