From 1619f599a1e37dd30dfe7ab803374f5eed26544a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 11 May 2004 17:02:30 +0000 Subject: [PATCH] r9314: 11 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * sql/objects.lisp: Initial caching support for SELECT * tests/test-oodml.lisp: Avoid using cache when testing select. --- ChangeLog | 4 +- TODO | 1 + sql/classes.lisp | 4 +- sql/objects.lisp | 135 +++++++++++++++++++++++++++++------------- tests/test-oodml.lisp | 55 ++++++++++------- 5 files changed, 135 insertions(+), 64 deletions(-) diff --git a/ChangeLog b/ChangeLog index c5e226d..6bfdd11 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,6 @@ -10 May 2004 Kevin Rosenberg (kevin@rosenberg.net) +11 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/objects.lisp: Initial caching support for SELECT + * tests/test-oodml.lisp: Avoid using cache when testing select. * sql/kmr-mop.lisp: Explicitly check slot order and store as a cl:*feature* * sql/recording.lisp: Remove additional types to diff --git a/TODO b/TODO index c938cf8..d7e470a 100644 --- a/TODO +++ b/TODO @@ -7,6 +7,7 @@ TESTS TO ADD * Test bigint type * :db-constraint tests * test *db-auto-sync* +* test SELECT caching COMMONSQL SPEC diff --git a/sql/classes.lisp b/sql/classes.lisp index e7bc74e..24bd71a 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -515,7 +515,9 @@ (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by :order-by-descending :set-operation :where :offset :limit - :inner-join :on)) + :inner-join :on + ;; below keywords are not a SQL argument, but these keywords may terminate select + :caching :refresh)) (defun query-arg-p (sym) (member sym *select-arguments*)) diff --git a/sql/objects.lisp b/sql/objects.lisp index e3a1853..04951f9 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -963,8 +963,7 @@ superclass of the newly-defined View Class." jcs)) immediate-join-classes) sel-tables) - :test #'tables-equal))) - (res nil)) + :test #'tables-equal)))) (dolist (ob (listify order-by)) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) @@ -1001,18 +1000,19 @@ superclass of the newly-defined View Class." (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)))) + (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))) + (objects (mapcar + #'(lambda (r) + (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp)) + rows))) + objects)))) (defmethod instance-refreshed ((instance standard-db-object))) @@ -1055,30 +1055,85 @@ ENABLE-SQL-READER-SYNTAX." target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) - (if (select-objects target-args) - (apply #'find-all target-args qualifier-args) - (let* ((expr (apply #'make-query select-all-args)) - (specified-types - (mapcar #'(lambda (attrib) - (if (typep attrib 'sql-ident-attribute) - (let ((type (slot-value attrib 'type))) - (if type - type - t)) - t)) - (slot-value expr 'selections)))) - (destructuring-bind (&key (flatp nil) - (result-types :auto) - (field-names t) - (database *default-database*) - &allow-other-keys) - qualifier-args - (query expr :flatp flatp - :result-types - ;; specifying a type for an attribute overrides result-types - (if (some #'(lambda (x) (not (eq t x))) specified-types) - specified-types - result-types) - :field-names field-names - :database database))))))) + (cond + ((select-objects target-args) + (let ((caching (getf qualifier-args :caching)) + (refresh (getf qualifier-args :refresh)) + (database (or (getf qualifier-args :database) *default-database*))) + (remf qualifier-args :caching) + (remf qualifier-args :refresh) + (cond + ((null caching) + (apply #'find-all target-args qualifier-args)) + (t + (let ((cached (records-cache-results target-args qualifier-args database))) + (cond + ((and cached (not refresh)) + cached) + ((and cached refresh) + (update-cached-results target-args qualifier-args database)) + (t + (let ((results (apply #'find-all target-args qualifier-args))) + (setf (records-cache-results target-args qualifier-args database) results) + results)))))))) + (t + (let* ((expr (apply #'make-query select-all-args)) + (specified-types + (mapcar #'(lambda (attrib) + (if (typep attrib 'sql-ident-attribute) + (let ((type (slot-value attrib 'type))) + (if type + type + t)) + t)) + (slot-value expr 'selections)))) + (destructuring-bind (&key (flatp nil) + (result-types :auto) + (field-names t) + (database *default-database*) + &allow-other-keys) + qualifier-args + (query expr :flatp flatp + :result-types + ;; specifying a type for an attribute overrides result-types + (if (some #'(lambda (x) (not (eq t x))) specified-types) + specified-types + result-types) + :field-names field-names + :database database)))))))) + +(defun compute-records-cache-key (targets qualifiers) + (list targets + (do ((args *select-arguments* (cdr args)) + (results nil)) + ((null args) results) + (let* ((arg (car args)) + (value (getf qualifiers arg))) + (when value + (push (list arg + (typecase value + (%sql-expression (sql value)) + (t value))) + results)))))) + +(defun records-cache-results (targets qualifiers database) + (when (record-caches database) + (gethash (compute-records-cache-key targets qualifiers) (record-caches database)))) + +(defun (setf records-cache-results) (results targets qualifiers database) + (unless (record-caches database) + (setf (record-caches database) + (make-hash-table :test 'equal + #+allegro :values #+allegro :weak))) + (setf (gethash (compute-records-cache-key targets qualifiers) + (record-caches database)) results) + results) + +(defun update-cached-results (targets qualifiers database) + ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached + ;; for now, dump cache entry and perform fresh search + (let ((res (apply #'find-all targets qualifiers))) + (setf (gethash (compute-records-cache-key targets qualifiers) + (record-caches database)) res) + res)) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 7ad67e6..2e906b2 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -24,13 +24,13 @@ (deftest :oodml/select/1 (mapcar #'(lambda (e) (slot-value e 'last-name)) - (clsql:select 'employee :order-by [last-name] :flatp t)) + (clsql:select 'employee :order-by [last-name] :flatp t :caching nil)) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :oodml/select/2 (mapcar #'(lambda (e) (slot-value e 'name)) - (clsql:select 'company :flatp t)) + (clsql:select 'company :flatp t :caching nil)) ("Widgets Inc.")) (deftest :oodml/select/3 @@ -40,7 +40,8 @@ [slot-value 'company 'companyid]] [= [slot-value 'company 'name] "Widgets Inc."]] - :flatp t)) + :flatp t + :caching nil)) (1 1 1 1 1 1 1 1 1 1)) (deftest :oodml/select/4 @@ -51,15 +52,16 @@ (clsql:select 'employee :where [= [slot-value 'employee 'first-name] "Vladamir"] :flatp t - :order-by [last-name])) + :order-by [last-name] + :caching nil)) ("Vladamir Lenin" "Vladamir Putin")) (deftest :oodml/select/5 - (length (clsql:select 'employee :where [married] :flatp t)) + (length (clsql:select 'employee :where [married] :flatp t :caching nil)) 3) (deftest :oodml/select/6 - (let ((a (caar (clsql:select 'address :where [= 1 [addressid]])))) + (let ((a (caar (clsql:select 'address :where [= 1 [addressid]] :caching nil)))) (values (slot-value a 'street-number) (slot-value a 'street-name) @@ -68,7 +70,7 @@ 10 "Park Place" "Leningrad" 123) (deftest :oodml/select/7 - (let ((a (caar (clsql:select 'address :where [= 2 [addressid]])))) + (let ((a (caar (clsql:select 'address :where [= 2 [addressid]] :caching nil)))) (values (slot-value a 'street-number) (slot-value a 'street-name) @@ -78,7 +80,7 @@ (deftest :oodml/select/8 (mapcar #'(lambda (e) (slot-value e 'married)) - (clsql:select 'employee :flatp t :order-by [emplid])) + (clsql:select 'employee :flatp t :order-by [emplid] :caching nil)) (t t t nil nil nil nil nil nil nil)) (deftest :oodml/select/9 @@ -106,28 +108,28 @@ ;; test retrieval is deferred (deftest :oodm/retrieval/1 (every #'(lambda (e) (not (slot-boundp e 'company))) - (select 'employee :flatp t)) + (select 'employee :flatp t :caching nil)) t) ;; :retrieval :immediate should be boundp before accessed (deftest :oodm/retrieval/2 (every #'(lambda (ea) (slot-boundp ea 'address)) - (select 'employee-address :flatp t)) + (select 'employee-address :flatp t :caching nil)) t) (deftest :oodm/retrieval/3 (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) - (select 'employee-address :flatp t)) + (select 'employee-address :flatp t :caching nil)) (t t t t t)) (deftest :oodm/retrieval/4 (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) - (select 'employee-address :flatp t)) + (select 'employee-address :flatp t :caching nil)) t) (deftest :oodm/retrieval/5 (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) - (select 'employee-address :flatp t :order-by [aaddressid])) + (select 'employee-address :flatp t :order-by [aaddressid] :caching nil)) (10 10 nil nil nil)) ;; tests update-records-from-instance @@ -137,7 +139,8 @@ (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (concatenate 'string (first-name lenin) " " @@ -152,7 +155,8 @@ (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (concatenate 'string (first-name lenin) " " @@ -167,7 +171,8 @@ (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (concatenate 'string (first-name lenin) " " @@ -184,21 +189,24 @@ (employee-email (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t))) + :flatp t + :caching nil))) (progn (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") (clsql:update-record-from-slot employee1 'email) (employee-email (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (progn (setf (slot-value employee1 'email) "lenin@soviet.org") (clsql:update-record-from-slot employee1 'email) (employee-email (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t))))) + :flatp t + :caching nil))))) "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") ;; tests update-record-from-slots @@ -207,7 +215,8 @@ (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (concatenate 'string (first-name lenin) " " @@ -222,7 +231,8 @@ (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (concatenate 'string (first-name lenin) " " @@ -237,7 +247,8 @@ (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] 1] - :flatp t)))) + :flatp t + :caching nil)))) (concatenate 'string (first-name lenin) " " -- 2.34.1