From 75defa0ce7e93c50c87fe272632dcdd942e80d49 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 16 May 2004 01:28:40 +0000 Subject: [PATCH] r9365: 15 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.10.18: Caching and refreshing complete * sql/objects.lisp: implement UPDATE-OBJECT-JOINS, implement REFRESH for SELECT. * tests/test-oodml.lisp: Add tests for deferred retrieval, caching, refresh, and update-object-joins * tests/test-init.lisp: Add deferred-employee-address class --- ChangeLog | 8 +++ TODO | 25 +++++-- sql/objects.lisp | 153 ++++++++++++++++++++++++++++-------------- tests/test-init.lisp | 3 +- tests/test-oodml.lisp | 64 +++++++++++++++++- 5 files changed, 193 insertions(+), 60 deletions(-) diff --git a/ChangeLog b/ChangeLog index c555bdc..87c4a76 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +15 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.10.18: Caching and refreshing complete + * sql/objects.lisp: implement UPDATE-OBJECT-JOINS, + implement REFRESH for SELECT. + * tests/test-oodml.lisp: Add tests for deferred retrieval, + caching, refresh, and update-object-joins + * tests/test-init.lisp: Add deferred-employee-address class + 15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) * sql/operations.lisp: make MINUS operator a synonym for EXCEPT. Add COALESCE operator and make NVL a synonym for this. Make ANY, SOME, diff --git a/TODO b/TODO index bf7884a..c373914 100644 --- a/TODO +++ b/TODO @@ -3,18 +3,28 @@ TESTS TO ADD * CACHE-TABLE-QUERIES * Test that ":db-kind :key" adds an index for that key. This is complicated by different backends showing autogenerated primary key in different ways. -* Large object testing * Test bigint type * :db-constraint tests * test *db-auto-sync* -* test SELECT caching * for-each-row macro * universal-time -COMMONSQL SPEC +COMMONSQL INCOMPATIBILITY -* Incompatible +<<<<<<< .mine + o Complete sql expressions (see operations.lisp) + nvl (Oracle specific) + userenv (Oracle specific) + minus (Oracle specific: does the same as EXCEPT) + || + +======= +>>>>>>> .r9364 + o variables (e.g., table identifiers) should be instantiated at runtime + +<<<<<<< .mine +======= >> The functional sql interface SELECT @@ -31,19 +41,20 @@ UPDATE-OBJECT-JOINS: object, to meet CommonSQL spec need to generate a single query to read values for all objects, up to max-len count. +>>>>>>> .r9364 COMMIT,ROLLBACK,START-TRANSACTION: When COMMIT or ROLLBACK are called outside of WITH-TRANSACTION, an sql transaction must be explicitly started first with START-TRANSACTION. OPTIMIZATIONS -* Revisit result-type list creation,perhaps caching +* Revisit result-type list creation, perhaps caching POSSIBLE EXTENSIONS -* port Oracle backend to UFFI -* large object support +* extend large object support to databases beyond postgresql, improve large object api * add support for prepared statements +* port Oracle backend to UFFI NOTES ABOUT THE BACKENDS diff --git a/sql/objects.lisp b/sql/objects.lisp index 523ff61..869e643 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -808,27 +808,59 @@ superclass of the newly-defined View Class." class-name (max-len *default-update-objects-max-len*)) "Updates the remote join slots, that is those slots defined without :retrieval :immediate." + (assert (or (null max-len) (plusp max-len))) (when objects (unless class-name (setq class-name (class-name (class-of (first objects))))) (let* ((class (find-class class-name)) - (deferred-joins (generate-retrieval-joins-list class :deferred))) - (cond - (deferred-joins - (mapcar - #'(lambda (slotdef) - ;; FIXME: Rather than simply reading the values for each - ;; object, to meet CommonSQL spec need to generate a single - ;; query to read values for all objects, up to max-len count - (mapcar - #'(lambda (object) - (slot-value object (slot-definition-name slotdef))) - objects)) - deferred-joins)) - (t - (warn "Class ~A does not have any deferred join slots." class-name))) - ))) - + (class-slots (ordered-class-slots class)) + (slotdefs + (if (eq t slots) + (generate-retrieval-joins-list class :deferred) + (remove-if #'null + (mapcar #'(lambda (name) + (let ((slotdef (find name class-slots :key #'slot-definition-name))) + (unless slotdef + (warn "Unable to find slot named ~S in class ~S." name class)) + slotdef)) + slots))))) + (dolist (slotdef slotdefs) + (let* ((dbi (view-class-slot-db-info slotdef)) + (slotdef-name (slot-definition-name slotdef)) + (foreign-key (gethash :foreign-key dbi)) + (home-key (gethash :home-key dbi)) + (object-keys + (remove-duplicates + (if force-p + (mapcar #'(lambda (o) (slot-value o home-key)) objects) + (remove-if #'null + (mapcar + #'(lambda (o) (if (slot-boundp o slotdef-name) + nil + (slot-value o home-key))) + objects))))) + (n-object-keys (length object-keys)) + (query-len (or max-len n-object-keys))) + + (do ((i 0 (+ i query-len))) + ((>= i n-object-keys)) + (let* ((keys (if max-len + (subseq object-keys i (min (+ i query-len) n-object-keys)) + object-keys)) + (results (find-all (list (gethash :join-class dbi)) + :where (make-instance 'sql-relational-exp + :operator 'in + :sub-expressions (list (sql-expression :attribute foreign-key) + keys)) + :flatp t))) + (dolist (object objects) + (when (or force-p (not (slot-boundp object slotdef-name))) + (let ((res (find (slot-value object home-key) results + :key #'(lambda (res) (slot-value res foreign-key)) + :test #'equal))) + (when res + (setf (slot-value object slotdef-name) res))))))))))) + (values)) (defun fault-join-slot-raw (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) @@ -895,49 +927,51 @@ 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) +(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) - (let* ((class-name (class-name vclass)) - (db-vals (butlast vals (- (list-length vals) + (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))) - (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)) + (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)))) - + #'(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))) + (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)))) + objects)))) (defun find-all (view-classes &rest args &key all set-operation distinct from where group-by having order-by order-by-descending offset limit refresh flatp result-types inner-join on - (database *default-database*)) + (database *default-database*) + instances) "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) @@ -956,14 +990,17 @@ superclass of the newly-defined View Class." (remf args :flatp) (remf args :additional-fields) (remf args :result-types) + (remf args :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-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))) @@ -1021,10 +1058,22 @@ superclass of the newly-defined View Class." (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 (r) - (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp)) - rows))) + #'(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)))) (defmethod instance-refreshed ((instance standard-db-object))) @@ -1070,8 +1119,8 @@ ENABLE-SQL-READER-SYNTAX." (query-get-selections select-all-args) (cond ((select-objects target-args) - (let ((caching (getf qualifier-args :caching)) - (refresh (getf qualifier-args :refresh)) + (let ((caching (getf qualifier-args :caching t)) + (refresh (getf qualifier-args :refresh nil)) (database (or (getf qualifier-args :database) *default-database*))) (remf qualifier-args :caching) (remf qualifier-args :refresh) @@ -1084,7 +1133,9 @@ ENABLE-SQL-READER-SYNTAX." ((and cached (not refresh)) cached) ((and cached refresh) - (update-cached-results target-args qualifier-args database)) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)) (t (let ((results (apply #'find-all target-args qualifier-args))) (setf (records-cache-results target-args qualifier-args database) results) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index d98cbf2..7d7273f 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -171,7 +171,8 @@ :db-info (:join-class address :home-key aaddressid :foreign-key addressid - :retrieval :deferred))) + :retrieval :deferred + :set nil))) (:base-table "ea_join")) (defun test-connect-to-database (db-type spec) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 8d2281e..2ae3005 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -381,6 +381,68 @@ (every #'(lambda (a b) (eq a b)) employees (select 'employee)))) t) - + + (deftest oodml/cache/2 + (let ((employees (select 'employee))) + (equal employees (select 'employee :flatp t))) + nil) + + (deftest oodml/refresh/1 + (let ((addresses (select 'address))) + (equal addresses (select 'address :refresh t))) + t) + + (deftest oodml/refresh/2 + (let* ((addresses (select 'address :order-by [addressid] :flatp t)) + (city (slot-value (car addresses) 'city))) + (clsql:update-records [addr] + :av-pairs '((city_field "A new city")) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (let* ((new-addresses (select 'address :order-by [addressid] :refresh t :flatp t)) + (new-city (slot-value (car addresses) 'city)) +) + (clsql:update-records [addr] + :av-pairs `((city_field ,city)) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (values (equal addresses new-addresses) + city + new-city))) + t "Leningrad" "A new city") + + (deftest oodml/refresh/3 + (let* ((addresses (select 'address :order-by [addressid] :flatp t))) + (values + (equal addresses (select 'address :refresh t :flatp t)) + (equal addresses (select 'address :flatp t)))) + nil nil) + + (deftest oodml/refresh/4 + (let* ((addresses (select 'address :order-by [addressid] :flatp t)) + (*db-auto-sync* t)) + (make-instance 'address :addressid 1000 :city "A new address city") + (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t))) + (delete-records :from [addr] :where [= [addressid] 1000]) + (values + (length addresses) + (length new-addresses) + (eq (first addresses) (first new-addresses)) + (eq (second addresses) (second new-addresses))))) + 2 3 t t) + + + (deftest oodml/uoj/1 + (progn + (let* ((dea-list (select 'deferred-employee-address :caching nil :order-by [ea_join aaddressid] + :flatp t)) + (dea-list-copy (copy-seq dea-list)) + (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) + (update-object-joins dea-list) + (values + initially-unbound + (equal dea-list dea-list-copy) + (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) + (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) + (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list)))) + t t t t (1 1 2 2 2)) )) #.(clsql:restore-sql-reader-syntax-state) -- 2.34.1