From 541066e6726b102d1b6360cef98f16e773e7a38c Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Wed, 7 Aug 2024 08:27:42 +0000 Subject: [PATCH 1/7] Update CL-DBI. --- qlfile.lock | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qlfile.lock b/qlfile.lock index 52738a8..a0e41fc 100644 --- a/qlfile.lock +++ b/qlfile.lock @@ -5,7 +5,7 @@ ("cl-dbi" . (:class qlot/source/ql:source-ql-upstream :initargs nil - :version "ql-upstream-2ff41f0706180e140a31b844da4f0272e1a281cd" + :version "ql-upstream-48fa6fbda153414a87f5c1c5b5626ee0aed9de2e" :remote-url "https://github.com/fukamachi/cl-dbi.git")) ("cl-mysql" . (:class qlot/source/ql:source-ql-upstream From 3917d495eb5ebaa41fcd7461ea57ca022fa8c234 Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Wed, 7 Aug 2024 08:28:01 +0000 Subject: [PATCH 2/7] Add a CURSOR support to `select-dao`. It returns a cursor object when `*want-cursor*` is `t`. When it's given to `fetch-dao`, a DAO object will be returned. --- src/core/dao.lisp | 43 +++++++++++++++++++++++++++++++++++++------ src/core/db.lisp | 41 +++++++++++++++++++---------------------- t/dao.lisp | 30 ++++++++++++++++++++++++++++++ 3 files changed, 86 insertions(+), 28 deletions(-) diff --git a/src/core/dao.lisp b/src/core/dao.lisp index d3b30f3..6c4817b 100644 --- a/src/core/dao.lisp +++ b/src/core/dao.lisp @@ -28,13 +28,16 @@ #:last-insert-id #:execute-sql #:retrieve-by-sql - #:table-exists-p) + #:table-exists-p + #:ensure-sql) (:import-from #:mito.logger #:with-sql-logging) (:import-from #:mito.util + #:lispify #:unlispify #:symbol-name-literally - #:ensure-class) + #:ensure-class + #:execute-with-retry) (:import-from #:trivia #:match #:guard) @@ -50,6 +53,8 @@ #:delete-by-values #:save-dao #:select-dao + #:*want-cursor* + #:fetch-dao #:select-by-sql #:includes #:include-foreign-objects @@ -198,6 +203,28 @@ (update-dao obj) (insert-dao obj)))) +(defstruct mito-cursor + cursor + class) + +(defun select-by-sql-as-cursor (class sql &key binds) + (multiple-value-bind (sql yield-binds) + (ensure-sql sql) + (let* ((cursor (dbi:make-cursor *connection* sql)) + (cursor (execute-with-retry cursor (or binds yield-binds)))) + (make-mito-cursor :cursor cursor + :class class)))) + +(defun fetch-dao (cursor) + (check-type cursor mito-cursor) + (let ((row (dbi:fetch (mito-cursor-cursor cursor) + :format :alist))) + (when row + (apply #'make-dao-instance (mito-cursor-class cursor) + (loop for (k . v) in row + collect (intern (lispify (string-upcase k)) :keyword) + collect v))))) + (defun select-by-sql (class sql &key binds) (mapcar (lambda (result) (apply #'make-dao-instance class result)) @@ -305,6 +332,8 @@ (expand-op arg class)) args))) (otherwise object)))) +(defparameter *want-cursor* nil) + (defmacro select-dao (class &body clauses) (with-gensyms (sql clause results include-classes foreign-class) (once-only (class) @@ -327,10 +356,12 @@ (dolist (,clause (list ,@clauses)) (when ,clause (add-child ,sql ,clause))) - (let ((,results (select-by-sql ,class ,sql))) - (dolist (,foreign-class (remove-duplicates ,include-classes)) - (include-foreign-objects ,foreign-class ,results)) - (values ,results ,sql)))))))))) + (if *want-cursor* + (select-by-sql-as-cursor ,class ,sql) + (let ((,results (select-by-sql ,class ,sql))) + (dolist (,foreign-class (remove-duplicates ,include-classes)) + (include-foreign-objects ,foreign-class ,results)) + (values ,results ,sql))))))))))) (defun where-and (fields-and-values class) (when fields-and-values diff --git a/src/core/db.lisp b/src/core/db.lisp index e228937..3cbe055 100644 --- a/src/core/db.lisp +++ b/src/core/db.lisp @@ -115,6 +115,18 @@ Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.") :format :plist) t)))) +(defun sxql-to-sql (sql) + (with-quote-char (sxql:yield sql))) + +(defun ensure-sql (sql) + (etypecase sql + (string sql) + ((or sql-statement + composed-statement + ;; For UNION [ALL] + conjunctive-op) + (sxql-to-sql sql)))) + (defgeneric execute-sql (sql &optional binds) (:method ((sql string) &optional binds) (check-connected) @@ -124,10 +136,9 @@ Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.") (query-row-count query)))) (:method ((sql sql-statement) &optional binds) (declare (ignore binds)) - (with-quote-char - (multiple-value-bind (sql binds) - (sxql:yield sql) - (execute-sql sql binds))))) + (multiple-value-bind (sql binds) + (sxql-to-sql sql) + (execute-sql sql binds)))) (defun lispified-fields (query) (mapcar (lambda (field) @@ -203,25 +214,11 @@ Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.") (:plist t) (otherwise nil))))) (retrieve-from-query query format)))) - (:method ((sql sql-statement) &rest args &key binds &allow-other-keys) - (assert (null binds)) - (with-quote-char - (multiple-value-bind (sql binds) - (sxql:yield sql) - (apply #'retrieve-by-sql sql :binds binds args)))) - (:method ((sql composed-statement) &rest args &key binds &allow-other-keys) - (assert (null binds)) - (with-quote-char - (multiple-value-bind (sql binds) - (sxql:yield sql) - (apply #'retrieve-by-sql sql :binds binds args)))) - ;; For UNION [ALL] - (:method ((sql conjunctive-op) &rest args &key binds &allow-other-keys) + (:method (sql &rest args &key binds &allow-other-keys) (assert (null binds)) - (with-quote-char - (multiple-value-bind (sql binds) - (sxql:yield sql) - (apply #'retrieve-by-sql sql :binds binds args))))) + (multiple-value-bind (sql binds) + (ensure-sql sql) + (apply #'retrieve-by-sql sql :binds binds args)))) (defun acquire-advisory-lock (conn id) (funcall diff --git a/t/dao.lisp b/t/dao.lisp index a74bf55..cc0e257 100644 --- a/t/dao.lisp +++ b/t/dao.lisp @@ -240,6 +240,36 @@ (dolist (class-name '(user-setting user tweet friend-relationship tweet2)) (setf (find-class class-name) nil)) + + (disconnect-toplevel)) + +(deftest cursor + (setf *connection* (connect-to-testdb :postgres)) + (when (find-class 'user nil) + (setf (find-class 'user) nil)) + (defclass user () + ((name :col-type :text + :initarg :name)) + (:metaclass dao-table-class)) + (mito:execute-sql "DROP TABLE IF EXISTS \"user\"") + (mito:ensure-table-exists 'user) + (mito:create-dao 'user :name "Eitaro") + (mito:create-dao 'user :name "Btaro") + (mito:create-dao 'user :name "Charlie") + (dbi:with-transaction *connection* + (let* ((*want-cursor* t) + (cursor (mito.dao:select-dao 'user + (where (:like :name "%aro"))))) + (ok (typep cursor 'mito.dao::mito-cursor)) + (let ((row (mito.dao:fetch-dao cursor))) + (ok (typep row 'user)) + (ok (equal (slot-value row 'name) "Eitaro"))) + (let ((row (mito.dao:fetch-dao cursor))) + (ok (typep row 'user)) + (ok (equal (slot-value row 'name) "Btaro"))) + (ok (null (mito.dao:fetch-dao cursor))))) + (when (find-class 'user nil) + (setf (find-class 'user) nil)) (disconnect-toplevel)) (deftest foreign-slots From c0100e1bf0afa3bdaa59936661d0bd2044cd0dad Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Wed, 7 Aug 2024 08:56:48 +0000 Subject: [PATCH 3/7] Add `do-cursor`. --- src/core/dao.lisp | 17 ++++++++++++++++- t/dao.lisp | 11 +++++++++++ 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/src/core/dao.lisp b/src/core/dao.lisp index 6c4817b..546bf3a 100644 --- a/src/core/dao.lisp +++ b/src/core/dao.lisp @@ -63,7 +63,8 @@ #:count-dao #:recreate-table #:ensure-table-exists - #:deftable)) + #:deftable + #:do-cursor)) (in-package #:mito.dao) (defun foreign-value (obj slot) @@ -448,3 +449,17 @@ ,@(unless (find :conc-name options :key #'car) `((:conc-name ,(intern (format nil "~@:(~A-~)" name) (symbol-package name))))) ,@options)) + +(defmacro do-cursor ((dao select &optional index) &body body) + (with-gensyms (main cursor) + `(flet ((,main () + (let* ((*want-cursor* t) + (,cursor ,select)) + (loop ,@(and index `(for ,index from 0)) + for ,dao = (fetch-dao ,cursor) + while ,dao + do (progn ,@body))))) + (if (dbi:in-transaction *connection*) + (,main) + (dbi:with-transaction *connection* + (,main)))))) diff --git a/t/dao.lisp b/t/dao.lisp index cc0e257..2adb71d 100644 --- a/t/dao.lisp +++ b/t/dao.lisp @@ -268,6 +268,17 @@ (ok (typep row 'user)) (ok (equal (slot-value row 'name) "Btaro"))) (ok (null (mito.dao:fetch-dao cursor))))) + + (let ((records '())) + (do-cursor (dao (mito.dao:select-dao 'user) i) + (push (cons i dao) records) + (when (<= 1 i) + (return))) + (ok (= (length records) 2)) + (ok (every (lambda (record) + (typep (cdr record) 'user)) + records))) + (when (find-class 'user nil) (setf (find-class 'user) nil)) (disconnect-toplevel)) From 9de6e42989102ef1b467ff04db54a6773f04a4ea Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Wed, 7 Aug 2024 09:30:20 +0000 Subject: [PATCH 4/7] Rename `fetch-dao` to `fetch-dao-from-cursor` and unexport it. --- src/core/dao.lisp | 7 ++----- t/dao.lisp | 8 ++++---- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/src/core/dao.lisp b/src/core/dao.lisp index 546bf3a..39f6093 100644 --- a/src/core/dao.lisp +++ b/src/core/dao.lisp @@ -53,8 +53,6 @@ #:delete-by-values #:save-dao #:select-dao - #:*want-cursor* - #:fetch-dao #:select-by-sql #:includes #:include-foreign-objects @@ -216,8 +214,7 @@ (make-mito-cursor :cursor cursor :class class)))) -(defun fetch-dao (cursor) - (check-type cursor mito-cursor) +(defun fetch-dao-from-cursor (cursor) (let ((row (dbi:fetch (mito-cursor-cursor cursor) :format :alist))) (when row @@ -456,7 +453,7 @@ (let* ((*want-cursor* t) (,cursor ,select)) (loop ,@(and index `(for ,index from 0)) - for ,dao = (fetch-dao ,cursor) + for ,dao = (fetch-dao-from-cursor ,cursor) while ,dao do (progn ,@body))))) (if (dbi:in-transaction *connection*) diff --git a/t/dao.lisp b/t/dao.lisp index 2adb71d..744a266 100644 --- a/t/dao.lisp +++ b/t/dao.lisp @@ -257,17 +257,17 @@ (mito:create-dao 'user :name "Btaro") (mito:create-dao 'user :name "Charlie") (dbi:with-transaction *connection* - (let* ((*want-cursor* t) + (let* ((mito.dao::*want-cursor* t) (cursor (mito.dao:select-dao 'user (where (:like :name "%aro"))))) (ok (typep cursor 'mito.dao::mito-cursor)) - (let ((row (mito.dao:fetch-dao cursor))) + (let ((row (mito.dao::fetch-dao-from-cursor cursor))) (ok (typep row 'user)) (ok (equal (slot-value row 'name) "Eitaro"))) - (let ((row (mito.dao:fetch-dao cursor))) + (let ((row (mito.dao::fetch-dao-from-cursor cursor))) (ok (typep row 'user)) (ok (equal (slot-value row 'name) "Btaro"))) - (ok (null (mito.dao:fetch-dao cursor))))) + (ok (null (mito.dao::fetch-dao-from-cursor cursor))))) (let ((records '())) (do-cursor (dao (mito.dao:select-dao 'user) i) From fa7fcea8aaf7551c7acac5b87e3b1076496ce682 Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Thu, 8 Aug 2024 07:24:26 +0000 Subject: [PATCH 5/7] Update DBI to 0.11.1. --- qlfile.lock | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qlfile.lock b/qlfile.lock index a0e41fc..869dbee 100644 --- a/qlfile.lock +++ b/qlfile.lock @@ -5,7 +5,7 @@ ("cl-dbi" . (:class qlot/source/ql:source-ql-upstream :initargs nil - :version "ql-upstream-48fa6fbda153414a87f5c1c5b5626ee0aed9de2e" + :version "ql-upstream-f58761b4da39e0559fcfbd744fa6f024182c6d94" :remote-url "https://github.com/fukamachi/cl-dbi.git")) ("cl-mysql" . (:class qlot/source/ql:source-ql-upstream From 9cde889f85ef39f9db485ed5afc2d25d1a738327 Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Thu, 8 Aug 2024 07:27:52 +0000 Subject: [PATCH 6/7] Stop interning every call of `fetch`. --- src/core/dao.lisp | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/core/dao.lisp b/src/core/dao.lisp index 39f6093..0dc3803 100644 --- a/src/core/dao.lisp +++ b/src/core/dao.lisp @@ -204,6 +204,7 @@ (defstruct mito-cursor cursor + fields class) (defun select-by-sql-as-cursor (class sql &key binds) @@ -212,16 +213,21 @@ (let* ((cursor (dbi:make-cursor *connection* sql)) (cursor (execute-with-retry cursor (or binds yield-binds)))) (make-mito-cursor :cursor cursor + :fields (mapcar (lambda (column-name) + (intern (lispify (string-upcase column-name)) :keyword)) + (dbi.driver:query-fields cursor)) :class class)))) (defun fetch-dao-from-cursor (cursor) - (let ((row (dbi:fetch (mito-cursor-cursor cursor) - :format :alist))) + (let ((fields (mito-cursor-fields cursor)) + (row (dbi:fetch (mito-cursor-cursor cursor) + :format :values))) (when row (apply #'make-dao-instance (mito-cursor-class cursor) - (loop for (k . v) in row - collect (intern (lispify (string-upcase k)) :keyword) - collect v))))) + (loop for field in fields + for value in row + collect field + collect value))))) (defun select-by-sql (class sql &key binds) (mapcar (lambda (result) From e31f7a56661ac4e491995eeb323268bbeda57386 Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi Date: Thu, 8 Aug 2024 07:35:28 +0000 Subject: [PATCH 7/7] Require DBI 0.11.1 or above. --- mito-core.asd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mito-core.asd b/mito-core.asd index 951aefd..6cd1017 100644 --- a/mito-core.asd +++ b/mito-core.asd @@ -2,7 +2,7 @@ :version "0.2.0" :author "Eitaro Fukamachi" :license "LLGPL" - :depends-on ((:version "dbi" "0.10.0") + :depends-on ((:version "dbi" "0.11.1") "sxql" "cl-ppcre" "closer-mop"