1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
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
|
;;;-*- 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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/
;;; 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
|
