iterate-pg.lisp 3.17 KB
Newer Older
Attila Lendvai's avatar
Attila Lendvai committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
;;;-*- LISP -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; An ITERATE driver for postgresql queries via PG (http://cliki.net/pg)
;;;           Written by Andreas Fuchs <asf@boinkor.net>
;;;
;;; Permission to use, copy, modify, and distribute this software and its
;;; documentation for any purpose and without fee is hereby granted,
;;; provided that this copyright and permission notice appear in all
;;; copies and supporting documentation, and that the name of M.I.T. not
;;; be used in advertising or publicity pertaining to distribution of the
;;; software without specific, written prior permission. M.I.T. makes no
;;; representations about the suitability of this software for any
;;; purpose.  It is provided "as is" without express or implied warranty.

;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;;; SOFTWARE.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

25
26
27
28
29
30
;;; An extension to Eric Marsden's pg.lisp:
;;;  https://gitlab.common-lisp.net/pg/pg
;;;  https://common-lisp.net/project/pg/
;;; As of 2016 pg seems to be abandoned and also superseded by Postmodern:
;;;  http://marijnhaverbeke.nl/postmodern/

Attila Lendvai's avatar
Attila Lendvai committed
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
;;; Usage example:
;;; (iterate (for (impl version date) in-relation "select * from version" on-connection *dbconn*)
;;;          (collect version))

(cl:in-package :iterate)

(defvar *in-pg-transaction* nil)

(defmacro with-pg-cursor (cursor connection query &body body)
  (let ((conn (gensym))
        (begin-transaction (gensym))
        (success (gensym)))
    `(let ((,cursor (symbol-name (gensym "PGCURSOR")))
           (,conn ,connection)
           (,begin-transaction (not *in-pg-transaction*))
           (,success nil)
           (*in-pg-transaction* t))
       (when ,begin-transaction
         (pg:pg-exec ,conn "BEGIN WORK"))
       (pg:pg-exec ,conn "DECLARE " ,cursor " CURSOR FOR " ,query)
       (unwind-protect (multiple-value-prog1 (progn ,@body)
			 (setf ,success t))
         (pg:pg-exec ,conn "CLOSE " ,cursor)
         (when ,begin-transaction
           (pg:pg-exec ,conn (if ,success "COMMIT WORK" "ROLLBACK WORK")))))))

(defclause-driver (FOR var-spec IN-RELATION query ON-CONNECTION conn)
  (top-level-check)
  (let* ((row-var (make-var-and-default-binding 'row :type 'list))
         (cursor (gensym "CURSOR"))
         (test `(when (null ,row-var) (go ,*loop-end*)))
         (setq (do-dsetq var-spec row-var)))
    (add-loop-body-wrapper `(with-pg-cursor ,cursor ,conn ,query))
    (setf *loop-end-used?* t)
    (return-driver-code :next (list `(setq ,row-var (first (pg:pg-result (pg:pg-exec ,conn "FETCH 1 FROM " ,cursor) :tuples)))
                                    test
                                    setq)
                        :variable var-spec)))

;;; arch-tag: c08d68b2-63b2-4347-b261-133ae30b3e18