-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
* Test bigint type
* :db-constraint tests
* test *db-auto-sync*
+* test SELECT caching
COMMONSQL SPEC
(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*))
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)))
(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)))
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))
(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
[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
(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)
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)
(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
;; 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
(let ((lenin (car (clsql:select 'employee
:where [= [slot-value 'employee 'emplid]
1]
- :flatp t))))
+ :flatp t
+ :caching nil))))
(concatenate 'string
(first-name lenin)
" "
(let ((lenin (car (clsql:select 'employee
:where [= [slot-value 'employee 'emplid]
1]
- :flatp t))))
+ :flatp t
+ :caching nil))))
(concatenate 'string
(first-name lenin)
" "
(let ((lenin (car (clsql:select 'employee
:where [= [slot-value 'employee 'emplid]
1]
- :flatp t))))
+ :flatp t
+ :caching nil))))
(concatenate 'string
(first-name lenin)
" "
(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
(let ((lenin (car (clsql:select 'employee
:where [= [slot-value 'employee 'emplid]
1]
- :flatp t))))
+ :flatp t
+ :caching nil))))
(concatenate 'string
(first-name lenin)
" "
(let ((lenin (car (clsql:select 'employee
:where [= [slot-value 'employee 'emplid]
1]
- :flatp t))))
+ :flatp t
+ :caching nil))))
(concatenate 'string
(first-name lenin)
" "
(let ((lenin (car (clsql:select 'employee
:where [= [slot-value 'employee 'emplid]
1]
- :flatp t))))
+ :flatp t
+ :caching nil))))
(concatenate 'string
(first-name lenin)
" "
projects / clsql.git / commitdiff