Merge pull request #150 from fukamachi/cursor

Cursor support (only for PostgreSQL)

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"

qlfile.lock

@@ -5,7 +5,7 @@
 ("cl-dbi" .
  (:class qlot/source/ql:source-ql-upstream
  :initargs nil
- :version "ql-upstream-2ff41f0706180e140a31b844da4f0272e1a281cd"
+ :version "ql-upstream-f58761b4da39e0559fcfbd744fa6f024182c6d94"
  :remote-url "https://github.com/fukamachi/cl-dbi.git"))
 ("cl-mysql" .
  (:class qlot/source/ql:source-ql-upstream

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)
@@ -58,7 +61,8 @@
  #:count-dao
  #:recreate-table
  #:ensure-table-exists
- #:deftable))
+ #:deftable
+ #:do-cursor))
 (in-package #:mito.dao)
 
 (defun foreign-value (obj slot)
@@ -198,6 +202,33 @@
  (update-dao obj)
  (insert-dao obj))))
 
+(defstruct mito-cursor
+ cursor
+ fields
+ 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
+ :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 ((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 field in fields
+ for value in row
+ collect field
+ collect value)))))
+
 (defun select-by-sql (class sql &key binds)
  (mapcar (lambda (result)
  (apply #'make-dao-instance class result))
@@ -305,6 +336,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 +360,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
@@ -417,3 +452,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-from-cursor ,cursor)
+ while ,dao
+ do (progn ,@body)))))
+ (if (dbi:in-transaction *connection*)
+ (,main)
+ (dbi:with-transaction *connection*
+ (,main))))))

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

t/dao.lisp

@@ -240,6 +240,47 @@
 
  (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* ((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-from-cursor cursor)))
+ (ok (typep row 'user))
+ (ok (equal (slot-value row 'name) "Eitaro")))
+ (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-from-cursor 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))
 
 (deftest foreign-slots