From d5e70925c53fceafcbf9acce87a4c20ca03dc817 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 8 May 2004 17:41:46 +0000 Subject: [PATCH] r9285: 8 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * sql/objects.lisp: Add :retrieval :immediate for object selections. More tests --- ChangeLog | 2 + TODO | 4 - debian/changelog | 6 ++ sql/classes.lisp | 1 + sql/objects.lisp | 205 ++++++++++++++++++++++++++++-------------- tests/test-oodml.lisp | 22 +++-- 6 files changed, 162 insertions(+), 78 deletions(-) diff --git a/ChangeLog b/ChangeLog index eed07eb..440e6f9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,6 @@ 8 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/objects.lisp: Add :retrieval :immediate for + object selections * tests/test-init.lisp: Add non-index fields for testing join class employee-addresss * test/test-oodml.lisp: Add tests for retrieval immediate diff --git a/TODO b/TODO index a7a913c..07c9c78 100644 --- a/TODO +++ b/TODO @@ -22,10 +22,6 @@ COMMONSQL SPEC SELECT o keyword arg :refresh should function as advertised - DEF-VIEW-CLASS - o Rework functioning of :immediate to be conformant. It - works as expect with target-slot, but not without target-slot - >> Symbolic SQL syntax o Complete sql expressions (see operations.lisp) diff --git a/debian/changelog b/debian/changelog index 10d29c0..9217130 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.10.13-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Sat, 8 May 2004 11:41:13 -0600 + cl-sql (2.10.12-1) unstable; urgency=low * New upstream diff --git a/sql/classes.lisp b/sql/classes.lisp index 9e2338c..aa7a185 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -679,6 +679,7 @@ uninclusive, and the args from that keyword to the end." ;; Here's a real warhorse of a function! +(declaim (inline listify)) (defun listify (x) (if (atom x) (list x) diff --git a/sql/objects.lisp b/sql/objects.lisp index 0285ca4..fcb2a66 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -234,14 +234,28 @@ superclass of the newly-defined View Class." sels (error "No slots of type :base in view-class ~A" (class-name vclass))))) -(defun generate-immediate-joins-list (vclass) - "Returns list of pairs of join slots and their class for a class." - (let ((sels nil)) - (dolist (slotdef (ordered-class-slots vclass)) + + +(defun generate-retrieval-joins-list (vclass 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 :immediate (gethash :retrieval (view-class-slot-db-info slotdef)))) - (push slotdef sels))) - (cons vclass (list sels)))) + (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)) + ;; Called by 'get-slot-values-from-view' ;; @@ -795,8 +809,11 @@ superclass of the newly-defined View Class." (when objects (unless class-name (class-name (class-of (first objects)))) - ) - ) + (let* ((class (find-class class-name)) + (deferred-joins (generate-retrieval-joins-list class :deferred))) + (when deferred-joins + (warn "not yet implemented.") + )))) (defun fault-join-slot-raw (class object slot-def) @@ -864,6 +881,43 @@ superclass of the newly-defined View Class." ;; 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) + "Used by find-all to build objects." + (labels ((build-object (vals vclass jclasses selects immediate-selects) + (let* ((class-name (class-name vclass)) + (db-vals (butlast vals (- (list-length vals) + (list-length selects)))) + (join-vals (subseq vals (list-length selects))) + (obj (make-instance class-name :view-database database)) + (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) + ;; 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)) + joins) + (mapc + #'(lambda (jc) (let ((slot (find (class-name (class-of jc)) (class-slots vclass) + :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) + (prog1 (build-object vals sclass jclass sel immediate-join) + (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join)) + vals)))) + sclasses immediate-join-classes sels immediate-joins))) + (if (and flatp (= (length sclasses) 1)) + (car objects) + objects)))) + (defun find-all (view-classes &rest args &key all set-operation distinct from where group-by having @@ -874,75 +928,90 @@ superclass of the newly-defined View Class." View Classes VIEW-CLASSES are passed as arguments to SELECT." (declare (ignore all set-operation group-by having offset limit inner-join on) (optimize (debug 3) (speed 1))) - (remf args :from) - (remf args :flatp) - (remf args :additional-fields) - (remf args :result-types) - (labels ((table-sql-expr (table) - (sql-expression :table (view-table table))) - (ref-equal (ref1 ref2) + (labels ((ref-equal (ref1 ref2) (equal (sql ref1) (sql ref2))) + (table-sql-expr (table) + (sql-expression :table (view-table table))) (tables-equal (table-a table-b) - (string= (string (slot-value table-a 'name)) - (string (slot-value table-b 'name)))) - (build-object (vals vclass selects) - (let* ((class-name (class-name vclass)) - (db-vals (butlast vals (- (list-length vals) - (list-length selects)))) - (obj (make-instance class-name :view-database database))) - ;; use refresh keyword here - (setf obj (get-slot-values-from-view obj (mapcar #'car selects) - db-vals)) - (when refresh (instance-refreshed obj)) - obj)) - (build-objects (vals sclasses sels) - (let ((objects (mapcar #'(lambda (sclass sel) - (prog1 (build-object vals sclass sel) - (setf vals (nthcdr (list-length sel) - vals)))) - sclasses sels))) - (if (and flatp (= (length sclasses) 1)) - (car objects) - objects)))) + (when (and table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name)))))) + (remf args :from) + (remf args :where) + (remf args :flatp) + (remf args :additional-fields) + (remf args :result-types) (let* ((*db-deserializing* t) (sclasses (mapcar #'find-class view-classes)) - (immediate-joins (mapcar #'generate-immediate-joins-list sclasses)) + (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 sels)) + (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) (sel-tables (collect-table-refs where)) - (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) - sel-tables) - :test #'tables-equal)) + (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))) (res nil)) - (dolist (ob (listify order-by)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (dolist (ob (listify order-by-descending)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (dolist (ob (listify distinct)) - (when (and (typep ob 'sql-ident) - (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels + (dolist (ob (listify order-by)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) (listify ob)))))) - (setq res - (apply #'select - (append (mapcar #'cdr fullsels) - (cons :from - (list (append (when from (listify from)) - (listify tables)))) - (list :result-types result-types) - args))) - (mapcar #'(lambda (r) (build-objects r sclasses sels)) res)))) + (dolist (ob (listify order-by-descending)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (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 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)))))) + jclasses jslots))) + sclasses immediate-join-classes immediate-join-slots) + (setq res + (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))) + (mapcar #'(lambda (r) + (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp)) + res)))) (defmethod instance-refreshed ((instance standard-db-object))) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 88a7790..7ad67e6 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -103,23 +103,33 @@ (employee-addresses employee2)) ((t t 2 2 2))) - ;; :retrieval :immediate should be boundp before accessed + ;; test retrieval is deferred (deftest :oodm/retrieval/1 + (every #'(lambda (e) (not (slot-boundp e 'company))) + (select 'employee :flatp t)) + t) + + ;; :retrieval :immediate should be boundp before accessed + (deftest :oodm/retrieval/2 (every #'(lambda (ea) (slot-boundp ea 'address)) (select 'employee-address :flatp t)) t) - (deftest :oodm/retrieval/2 + (deftest :oodm/retrieval/3 (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) (select 'employee-address :flatp t)) (t t t t t)) - ;; test retrieval is deferred - (deftest :oodm/retrieval/3 - (every #'(lambda (e) (not (slot-boundp e 'company))) - (select 'employee :flatp t)) + (deftest :oodm/retrieval/4 + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'employee-address :flatp t)) t) + (deftest :oodm/retrieval/5 + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'employee-address :flatp t :order-by [aaddressid])) + (10 10 nil nil nil)) + ;; tests update-records-from-instance (deftest :oodml/update-records/1 (values -- 2.34.1