source: project/release/4/postgresql/trunk/postgresql.scm @ 17901

Last change on this file since 17901 was 17901, checked in by sjamaan, 9 years ago

Get rid of the current-type-unparsers parameter, pass the connection to each parser instead

File size: 53.7 KB
Line 
1;;; Bindings to the PostgreSQL C library
2;;
3;; Copyright (C) 2008-2009 Peter Bex
4;; Copyright (C) 2004 Johannes Grødem <johs@copyleft.no>
5;; Redistribution and use in source and binary forms, with or without
6;; modification, is permitted.
7;;
8;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
9;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
10;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
11;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
12;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
13;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
14;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
15;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
16;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
17;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
18;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
19;; DAMAGE.
20
21(module postgresql
22 (type-parsers update-type-parsers! default-type-parsers
23  char-parser bool-parser bytea-parser numeric-parser make-array-parser
24  scheme-value->db-value type-unparsers update-type-unparsers!
25  default-type-unparsers bool-unparser vector-unparser list-unparser
26 
27  connect reset-connection disconnect connection?
28 
29  query query* with-transaction in-transaction?
30 
31  result? clear-result! row-count column-count
32  column-index column-name column-names column-format
33  column-type column-type-modifier table-oid table-column-index
34  value-at row-values row-alist column-values affected-rows inserted-oid
35
36  invalid-oid
37 
38  escape-string escape-bytea unescape-bytea
39
40  put-copy-data put-copy-end get-copy-data
41 
42  row-fold row-fold* row-fold-right row-fold-right*
43  row-for-each row-for-each* row-map row-map*
44  column-fold column-fold* column-fold-right column-fold-right*
45  column-for-each column-for-each* column-map column-map*
46  copy-query-fold copy-query*-fold copy-query-fold-right copy-query*-fold-right
47  copy-query-for-each copy-query*-for-each copy-query-map copy-query*-map
48  call-with-output-copy-query call-with-output-copy-query*
49  with-output-to-copy-query with-output-to-copy-query*)
50
51(import chicken scheme foreign)
52
53(require-extension srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
54                   extras data-structures ports sql-null)
55
56(foreign-declare "#include <libpq-fe.h>")
57
58(define-foreign-type pg-polling-status (enum "PostgresPollingStatusType"))
59(define-foreign-variable PGRES_POLLING_FAILED pg-polling-status)
60(define-foreign-variable PGRES_POLLING_READING pg-polling-status)
61(define-foreign-variable PGRES_POLLING_WRITING pg-polling-status)
62(define-foreign-variable PGRES_POLLING_OK pg-polling-status)
63
64(define-foreign-type pg-exec-status (enum "ExecStatusType"))
65(define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status)
66(define-foreign-variable PGRES_COMMAND_OK pg-exec-status)
67(define-foreign-variable PGRES_TUPLES_OK pg-exec-status)
68(define-foreign-variable PGRES_COPY_OUT pg-exec-status)
69(define-foreign-variable PGRES_COPY_IN pg-exec-status)
70(define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status)
71(define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status)
72(define-foreign-variable PGRES_FATAL_ERROR pg-exec-status)
73
74;(define-foreign-type pgconn* (c-pointer "PGconn"))
75(define-foreign-type pgconn* c-pointer)
76
77(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string)))
78(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*))
79(define PQresetStart (foreign-lambda bool PQresetStart pgconn*))
80(define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*))
81(define PQfinish (foreign-lambda void PQfinish pgconn*))
82(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
83(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
84
85;(define-foreign-type oid "Oid")
86(define-foreign-type oid unsigned-int)
87
88(define invalid-oid (foreign-value "InvalidOid" oid))
89
90(define PQisBusy (foreign-lambda bool PQisBusy pgconn*))
91(define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*))
92
93(define-foreign-type pgresult* (c-pointer "PGresult"))
94
95(define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*))
96(define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*)))
97(define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*)))
98(define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int))
99
100(define PQclear (foreign-lambda void PQclear pgresult*))
101(define PQntuples (foreign-lambda int PQntuples (const pgresult*)))
102(define PQnfields (foreign-lambda int PQnfields (const pgresult*)))
103(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int))
104(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string)))
105(define PQftable (foreign-lambda oid PQftable (const pgresult*) int))
106(define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int))
107(define PQfformat (foreign-lambda int PQfformat (const pgresult*) int))
108(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
109(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int))
110(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
111(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
112(define PQoidValue (foreign-lambda oid PQoidValue pgresult*))
113
114(define PQputCopyData (foreign-lambda int PQputCopyData pgconn* blob int))
115(define PQputCopyEnd (foreign-lambda int PQputCopyEnd pgconn* (const c-string)))
116
117;; TODO: Create a real callback system?
118(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }")
119
120(define-syntax define-foreign-int
121  (er-macro-transformer
122   (lambda (e r c)
123     ;; cannot rename define-foreign-variable; it's a really special form
124    `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
125
126(define-foreign-int PG_DIAG_SEVERITY)
127(define-foreign-int PG_DIAG_SQLSTATE)
128(define-foreign-int PG_DIAG_MESSAGE_PRIMARY)
129(define-foreign-int PG_DIAG_MESSAGE_DETAIL)
130(define-foreign-int PG_DIAG_MESSAGE_HINT)
131(define-foreign-int PG_DIAG_STATEMENT_POSITION)
132(define-foreign-int PG_DIAG_CONTEXT)
133(define-foreign-int PG_DIAG_SOURCE_FILE)
134(define-foreign-int PG_DIAG_SOURCE_LINE)
135(define-foreign-int PG_DIAG_SOURCE_FUNCTION)
136
137;; Helper procedure.  It's a little silly but very useful, so maybe export it?
138(define (in-list len)
139  (string-intersperse
140   (list-tabulate len (lambda (p) (conc "$" (add1 p)))) ","))
141
142(define (postgresql-error loc message . args)
143  (signal (make-pg-condition loc message args: args)))
144
145(define (make-pg-condition loc message #!key (args '()) severity
146                           error-class error-code message-detail
147                           message-hint statement-position context
148                           source-file source-line
149                           source-function)
150  (make-composite-condition
151    (make-property-condition
152     'exn 'location loc 'message message 'arguments args)
153    (make-property-condition
154     'postgresql 'severity severity 'error-class error-class
155     'error-code error-code 'message-detail message-detail
156     'message-hint message-hint 'statement-position statement-position
157     'context context 'source-file source-file 'source-line source-line
158     ;; Might break not-terribly-old versions of postgresql
159     ;;'internal-position internal-position 'internal-query internal-query
160     'source-function source-function)))
161
162;;;;;;;;;;;;;;;;;;;;;;;;
163;;;; Type parsers
164;;;;;;;;;;;;;;;;;;;;;;;;
165
166(define (char-parser str) (string-ref str 0))
167
168(define (bool-parser str) (string=? str "t"))
169
170(define (numeric-parser str)
171  (or (string->number str)
172      (postgresql-error 'numeric-parser "Unable to parse number" str)))
173
174(define (bytea-parser str)
175  (blob->u8vector/shared (string->blob (unescape-bytea str))))
176
177;; Here be dragons
178(define (make-array-parser element-parser #!optional (delim #\,))
179  (define (parse str)
180    (if (string-ci=? "NULL" str)
181        (sql-null)
182        (element-parser str)))
183  (lambda (str)
184    (let loop ((chars (let ignore-bounds ((chars (string->list str)))
185                        (if (char=? (car chars) #\{)
186                            chars
187                            (ignore-bounds (cdr chars)))))
188               (result (list)))
189      (if (null? chars)
190          (car result) ; Should contain only one vector
191          (case (car chars)
192            ((#\{) (receive (value rest-chars)
193                     (loop (cdr chars) (list))
194                     (loop rest-chars (cons value result))))
195            ((#\}) (values (list->vector (reverse! result)) (cdr chars)))
196            ((#\") (let consume-string ((chars (cdr chars))
197                                        (consumed (list)))
198                     (case (car chars)
199                       ((#\\) (consume-string ; Don't interpret, just add it
200                               (cddr chars) (cons (cadr chars) consumed)))
201                       ((#\") (loop (cdr chars)
202                                    (cons (element-parser
203                                           (reverse-list->string consumed))
204                                          result)))
205                       (else (consume-string (cdr chars)
206                                             (cons (car chars) consumed))))))
207            ((#\tab #\newline #\space) (loop (cdr chars) result))
208            (else
209             (if (char=? (car chars) delim)
210                 (loop (cdr chars) result)
211                 (let consume-string ((chars chars)
212                                      (consumed (list)))
213                   (cond
214                    ((char=? (car chars) delim)
215                     (loop (cdr chars)
216                           (cons (parse (reverse-list->string consumed))
217                                 result)))
218                    ((or (char=? (car chars) #\})
219                         (char=? (car chars) #\}))
220                     (loop chars
221                           (cons (parse (reverse-list->string consumed))
222                                 result)))
223                    (else (consume-string (cdr chars)
224                                          (cons (car chars) consumed))))))))))))
225
226(define (make-composite-parser element-parsers)
227  (define (parse str element-parser)
228    (if (string=? "" str)
229        (sql-null)
230        (element-parser str)))
231  (lambda (str)
232    (let loop ((chars (cdr (string->list (string-trim str)))) ; skip leading (
233               (result (list))
234               (parsers element-parsers))
235      (case (car chars)
236        ((#\)) (reverse! result))                ; Done
237        ((#\") (let consume-string ((chars (cdr chars))
238                                    (consumed (list)))
239                 (case (car chars)
240                   ((#\\) (consume-string ; Don't interpret, just add it
241                           (cddr chars) (cons (cadr chars) consumed)))
242                   ((#\") (if (char=? #\" (cadr chars)) ; double escapes
243                              (consume-string (cddr chars)
244                                              (cons #\" consumed))
245                              (let skip-spaces ((chars (cdr chars)))
246                                (case (car chars)
247                                  ((#\space #\newline #\tab)
248                                   (skip-spaces (cdr chars)))
249                                  ((#\,)
250                                   (loop (cdr chars)
251                                         (cons ((car parsers)
252                                                (reverse-list->string consumed))
253                                               result)
254                                         (cdr parsers)))
255                                  ((#\)) (loop chars
256                                               (cons ((car parsers)
257                                                      (reverse-list->string consumed))
258                                                     result)
259                                               (cdr parsers)))
260                                  (else
261                                   (postgresql-error 'make-composite-parser
262                                                     "Bogus trailing characters"
263                                                     str))))))
264                   (else (consume-string (cdr chars)
265                                         (cons (car chars) consumed))))))
266        (else (let consume-string ((chars chars)
267                                   (consumed (list)))
268                (case (car chars)
269                  ((#\,) (loop (cdr chars)
270                               (cons (parse (reverse-list->string consumed)
271                                            (car parsers))
272                                     result)
273                               (cdr parsers)))
274                  ;; Nothing should precede this one
275                  ((#\)) (loop chars
276                               (cons (parse (reverse-list->string consumed)
277                                            (car parsers))
278                                     result)
279                               (cdr parsers)))
280                  (else (consume-string (cdr chars)
281                                        (cons (car chars) consumed))))))))))
282
283;; Array parsers and composite parsers are automatically cached when such
284;; a value is requested.
285(define default-type-parsers
286  (make-parameter
287   `(("text" . ,identity)
288     ("bytea" . ,bytea-parser)
289     ("char" . ,char-parser)
290     ("bpchar" . ,identity)
291     ("bool" . ,bool-parser)
292     ("int8" . ,numeric-parser)
293     ("int4" . ,numeric-parser)
294     ("int2" . ,numeric-parser)
295     ("float4" . ,numeric-parser)
296     ("float8" . ,numeric-parser)
297     ("numeric" . ,numeric-parser)
298     ("oid" . ,numeric-parser)
299     ;; Nasty hack, or clever hack? :)
300     ("record" . ,(make-composite-parser (circular-list identity))))))
301
302;;;;;;;;;;;;;;;;;;;;;;;
303;;;; Type unparsers
304;;;;;;;;;;;;;;;;;;;;;;;
305
306(define (scheme-value->db-value conn value)
307  (cond ((find (lambda (parse?)
308                 ((car parse?) value))
309               (pg-connection-type-unparsers conn)) =>
310               (lambda (parse)
311                 ((cdr parse) conn value)))
312        (else value)))
313
314(define (bool-unparser conn b)
315  (if b "TRUE" "FALSE"))
316
317(define (vector-unparser conn v)
318  (let loop ((result (list))
319             (pos 0)
320             (len (vector-length v)))
321    (if (= pos len)
322        (string-append "{" (string-intersperse (reverse! result) ",") "}")
323        (let* ((value (vector-ref v pos))
324               (unparsed-value (scheme-value->db-value conn value))
325               (serialized (cond
326                            ((sql-null? unparsed-value) "NULL")
327                            ((not (string? unparsed-value))
328                             (postgresql-error
329                              'vector-unparser
330                              (sprintf "Param value is not string: ~S"
331                                       unparsed-value)))
332                            ((vector? value) unparsed-value) ;; don't quote!
333                            (else
334                             (sprintf "\"~A\""
335                                      (string-translate*
336                                       unparsed-value
337                                       '(("\\" . "\\\\") ("\"" . "\\\""))))))))
338          (loop (cons serialized result) (add1 pos) len)))))
339
340(define (list-unparser conn l)
341  (let loop ((result (list))
342             (items l))
343    (if (null? items)
344        (string-append "(" (string-intersperse (reverse! result) ",") ")")
345        (let* ((unparsed-value (scheme-value->db-value conn (car items)))
346               (serialized (cond
347                            ((sql-null? unparsed-value) "")
348                            ((not (string? unparsed-value))
349                             (postgresql-error
350                              'list-unparser
351                              (sprintf "Param value is not string: ~S"
352                                       unparsed-value)))
353                            (else
354                             (sprintf "\"~A\""
355                                      (string-translate*
356                                       unparsed-value
357                                       '(("\\" . "\\\\") ("\"" . "\\\""))))))))
358          (loop (cons serialized result) (cdr items))))))
359
360(define default-type-unparsers
361  (make-parameter
362   `((,string? . ,(lambda (conn s) s))
363     (,u8vector? . ,(lambda (conn v) (u8vector->blob/shared v)))
364     (,char? . ,(lambda (conn c) (string c)))
365     (,boolean? . ,bool-unparser)
366     (,number? . ,(lambda (conn n) (number->string n)))
367     (,vector? . ,vector-unparser)
368     (,pair? . ,list-unparser))))
369
370;; Retrieve type-oids from PostgreSQL:
371(define (update-type-parsers! conn #!optional new-type-parsers)
372  (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
373        (ht (make-hash-table))
374        (result '()))
375    (pg-connection-oid-parsers-set! conn ht)
376    (pg-connection-type-parsers-set! conn type-parsers)
377    (unless (null? type-parsers)   ; empty IN () clause is not allowed
378      (row-for-each*
379       (lambda (oid typname)
380         (and-let* ((procedure (assoc typname type-parsers)))
381           (hash-table-set! ht (string->number oid) (cdr procedure))))
382       (query* conn (sprintf
383                     "SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
384                     (in-list (length type-parsers)))
385        (map car type-parsers) raw: #t)))))
386
387(define (update-type-unparsers! conn new-type-unparsers)
388  (pg-connection-type-unparsers-set! conn new-type-unparsers))
389
390;;;;;;;;;;;;;;;;;;;;
391;;;; Connections
392;;;;;;;;;;;;;;;;;;;;
393
394(define-record
395  pg-connection ptr
396  type-parsers oid-parsers type-unparsers
397  transaction-depth)
398(define connection? pg-connection?)
399(define type-parsers pg-connection-type-parsers)
400(define type-unparsers pg-connection-type-unparsers)
401
402(define (pgsql-connection->fd conn)
403  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
404
405(define (wait-for-connection! conn poll-function)
406  (let ((conn-fd (pgsql-connection->fd conn))
407        (conn-ptr (pg-connection-ptr conn)))
408    (let loop ((result (poll-function conn-ptr)))
409      (cond ((= result PGRES_POLLING_OK) (void))
410            ((= result PGRES_POLLING_FAILED)
411             (let ((error-message (PQerrorMessage conn-ptr)))
412               (disconnect conn)
413               (postgresql-error 'connect
414                                 (conc "Polling Postgres database failed. "
415                                       error-message) conn)))
416            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
417             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
418                                               #:input
419                                               #:output))
420             (loop (poll-function conn-ptr)))
421            (else
422             (postgresql-error 'connect (conc "Unknown status code!") conn))))))
423
424(define (alist->connection-spec alist)
425  (string-join
426   (map (lambda (subspec)
427          (sprintf "~A='~A'"
428                   (car subspec) ;; this had better not contain [ =\']
429                   (string-translate* (->string (cdr subspec))
430                                      '(("\\" . "\\\\") ("'" . "\\'")))))
431        alist)))
432
433(define (connect connection-spec
434                 #!optional
435                 (type-parsers (default-type-parsers))
436                 (type-unparsers (default-type-unparsers)))
437  (let* ((connection-spec (if (string? connection-spec)
438                              connection-spec
439                              (alist->connection-spec connection-spec)))
440         (conn-ptr (PQconnectStart connection-spec)))
441    (cond
442     ((not conn-ptr)
443      (postgresql-error 'connect
444                        "Unable to allocate a Postgres connection structure."
445                        connection-spec))
446     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
447      (let ((error-message (PQerrorMessage conn-ptr)))
448        (PQfinish conn-ptr)
449        (postgresql-error 'connect
450                          (conc "Connection to Postgres database failed: "
451                                error-message)
452                          connection-spec)))
453     (else
454      (let ((conn (make-pg-connection conn-ptr type-parsers
455                                      (make-hash-table) type-unparsers 0)))
456        ;; We don't want libpq to piss in our stderr stream
457        ((foreign-lambda* void ((pgconn* conn))
458          "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
459        (wait-for-connection! conn PQconnectPoll)
460        (set-finalizer! conn disconnect)
461        ;; Retrieve type-information from PostgreSQL metadata for use by
462        ;; the various value-parsers.
463        (update-type-parsers! conn)
464        conn)))))
465
466(define (reset-connection connection)
467  (let ((conn-ptr (pg-connection-ptr connection)))
468    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
469        (wait-for-connection! connection PQresetPoll)
470        (let ((error-message (PQerrorMessage conn-ptr)))
471          (disconnect connection)
472          (postgresql-error 'reset-connection
473                            (conc "Reset of connection failed " error-message)
474                            connection)))))
475
476(define (disconnect connection)
477  (and-let* ((conn-ptr (pg-connection-ptr connection)))
478    (pg-connection-ptr-set! connection #f)
479    (pg-connection-type-parsers-set! connection #f)
480    (pg-connection-oid-parsers-set! connection #f)
481    (PQfinish conn-ptr))
482  (void))
483
484;;;;;;;;;;;;;;;
485;;;; Results
486;;;;;;;;;;;;;;;
487
488(define-record pg-result ptr value-parsers)
489(define result? pg-result?)
490
491(define (clear-result! result)
492  (and-let* ((result-ptr (pg-result-ptr result)))
493    (pg-result-ptr-set! result #f)
494    (PQclear result-ptr)))
495
496(define (row-count result)
497  (PQntuples (pg-result-ptr result)))
498
499(define (column-count result)
500  (PQnfields (pg-result-ptr result)))
501
502;; Helper procedures for bounds checking; so we can distinguish between
503;; out of bounds and nonexistant columns, and signal it.
504(define (check-column-index! result index location)
505  (when (>= index (column-count result))
506    (postgresql-error
507     location (sprintf "Result column ~A out of bounds" index) result index)))
508
509(define (check-row-index! result index location)
510  (when (>= index (row-count result))
511    (postgresql-error
512     location (sprintf "Result row ~A out of bounds" index) result index)))
513
514(define (column-name result index)
515  (check-column-index! result index 'column-name)
516  (string->symbol (PQfname (pg-result-ptr result) index)))
517
518(define (column-names result)
519  (let ((ptr (pg-result-ptr result)))
520   (let loop ((names '())
521              (column (column-count result)))
522     (if (= column 0)
523         names
524         (loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
525               (sub1 column))))))
526
527(define (column-index result name)
528  (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
529    (and (>= idx 0) idx)))
530
531(define (table-oid result index)
532  (check-column-index! result index 'table-oid)
533  (let ((oid (PQftable (pg-result-ptr result) index)))
534    (and (not (= oid invalid-oid)) oid)))
535
536;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
537;; consistent with the rest of Scheme.  However, this is inconsistent with
538;; almost all other PostgreSQL interfaces...
539(define (table-column-index result index)
540  (check-column-index! result index 'table-column-index)
541  (let ((idx (PQftablecol (pg-result-ptr result) index)))
542    (and (> idx 0) (sub1 idx))))
543
544(define format-table
545  '((0 . text) (1 . binary)))
546
547(define (format->symbol format)
548  (or (alist-ref format format-table eq?)
549      (postgresql-error 'format->symbol "Unknown format" format)))
550
551(define (symbol->format symbol)
552  (or (and-let* ((res (rassoc symbol format-table eq?)))
553        (car res))
554      (postgresql-error 'format->symbol "Unknown format" symbol)))
555
556(define (column-format result index)
557  (check-column-index! result index 'column-format)
558  (format->symbol (PQfformat (pg-result-ptr result) index)))
559
560(define (column-type result index)
561  (check-column-index! result index 'column-type)
562  (PQftype (pg-result-ptr result) index))
563
564;; This is really not super-useful as it requires intimate knowledge
565;; about the internal implementations of types in PostgreSQL.
566(define (column-type-modifier result index)
567  (check-column-index! result index 'column-type)
568  (let ((mod (PQfmod (pg-result-ptr result) index)))
569    (and (>= mod 0) mod)))
570
571;; Unchecked version, for speed
572(define (value-at* result column row #!key raw)
573  (if (PQgetisnull (pg-result-ptr result) row column)
574      (sql-null)
575      (let ((value ((foreign-safe-lambda*
576                     scheme-object ((c-pointer res) (int row) (int col))
577                     "C_word fin, *str; char *val; int len;"
578                     "len = PQgetlength(res, row, col);"
579                     "str = C_alloc(C_bytestowords(len + sizeof(C_header)));"
580                     "val = PQgetvalue(res, row, col);"
581                     "fin = C_string(&str, len, val);"
582                     "if (PQfformat(res, col) == 1) /* binary? */"
583                     "        C_string_to_bytevector(fin);"
584                     "C_return(fin);")
585                    (pg-result-ptr result) row column)))
586        (if (or raw (blob? value))
587            value
588            ((vector-ref (pg-result-value-parsers result) column) value)))))
589
590(define (value-at result #!optional (column 0) (row 0) #!key raw)
591  (check-row-index! result row 'value)
592  (check-column-index! result column 'value)
593  (value-at* result column row raw: raw))
594
595(define (row-values result #!optional (row 0) #!key raw)
596  (check-row-index! result row 'row)
597  (let loop ((list '())
598             (column (column-count result)))
599    (if (= column 0)
600        list
601        (loop (cons (value-at* result (sub1 column) row raw: raw) list)
602              (sub1 column)))))
603
604(define (column-values result #!optional (column 0) #!key raw)
605  (check-column-index! result column 'column)
606  (let loop ((list '())
607             (row (row-count result)))
608    (if (= row 0)
609        list
610        (loop (cons (value-at* result column (sub1 row) raw: raw) list)
611              (sub1 row)))))
612
613;; (define (row-alist result #!optional (row 0) #!key raw)
614;;   (map cons (column-names result) (row-values result row raw: raw)))
615(define (row-alist result #!optional (row 0) #!key raw)
616  (check-row-index! result row 'row-alist)
617  (let loop ((alist '())
618             (column (column-count result)))
619    (if (= column 0)
620        alist
621        (loop (cons (cons (string->symbol
622                           (PQfname (pg-result-ptr result) (sub1 column)))
623                          (value-at* result (sub1 column) row raw: raw)) alist)
624              (sub1 column)))))
625
626;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
627
628(define (affected-rows result)
629  (string->number (PQcmdTuples (pg-result-ptr result))))
630
631(define (inserted-oid result)
632  (let ((oid (PQoidValue (pg-result-ptr result))))
633    (and (not (= oid invalid-oid)) oid)))
634
635
636;;;;;;;;;;;;;;;;;;;;;;;;
637;;;; Query procedures
638;;;;;;;;;;;;;;;;;;;;;;;;
639
640;; Buffer all available input, yielding if nothing is available:
641(define (buffer-available-input! conn)
642  (let ((conn-ptr (pg-connection-ptr conn))
643        (conn-fd (pgsql-connection->fd conn)))
644    (let loop ()
645      (if (PQconsumeInput conn-ptr)
646          (when (PQisBusy conn-ptr)
647            (thread-wait-for-i/o! conn-fd #:input)
648            (loop))
649          (postgresql-error 'buffer-available-input!
650                            (conc "Error reading reply from server. "
651                                  (PQerrorMessage conn-ptr))
652                            conn)))))
653
654;; Here be more dragons
655(define (resolve-unknown-types! conn oids)
656  (unless (null? oids)
657    (let* ((parsers (pg-connection-oid-parsers conn))
658           (q (conc "SELECT t.oid, t.typtype, t.typelem, t.typdelim, "
659                    "       t.typbasetype, a.attrelid, a.atttypid "
660                    "FROM pg_type t "
661                    "     LEFT JOIN pg_attribute a "
662                    "     ON t.typrelid = a.attrelid AND a.attnum > 0 "
663                    "WHERE t.oid IN (~A)  "
664                    "ORDER BY t.typrelid ASC NULLS FIRST, a.attnum ASC"))
665           (result (query* conn (sprintf q (in-list (length oids)))
666                           (map number->string oids) raw: #t))
667           (count (row-count result)))
668      (let dissect-types ((unknown-oids (list))
669                          (pos 0)
670                          (domains (list))
671                          (arrays (list))
672                          (classes (list))
673                          (last-class 0))
674        (cond
675         ((>= pos count)     ; Done scanning rows?
676          ;; Keep going until all oids are resolved
677          (resolve-unknown-types! conn unknown-oids)
678          ;; Postprocessing step: resolve all nested types
679          (for-each (lambda (d)
680                      (and-let* ((p (hash-table-ref/default parsers (cdr d) #f)))
681                        (hash-table-set! parsers (car d) p)))
682                    domains)
683          (for-each (lambda (a)
684                      (and-let* ((p (hash-table-ref/default parsers (cddr a) #f)))
685                        (hash-table-set! parsers (car a)
686                                         (make-array-parser p (cadr a)))))
687                    arrays)
688          (for-each
689           (lambda (c)
690             (and-let* ((p-list
691                         (fold
692                          (lambda (att l)
693                            (and-let* ((l)
694                                       (p (hash-table-ref/default parsers att #f)))
695                              (cons p l)))
696                          '()
697                          (cdr c))))
698               (hash-table-set! parsers (car c)
699                                (make-composite-parser p-list))))
700           classes))
701         ((not (string=? (value-at* result 4 pos) "0")) ; Domain type?
702          (let* ((basetype-oid (string->number (value-at* result 4 pos)))
703                 (parser (hash-table-ref/default parsers basetype-oid #f))
704                 (oid (string->number (value-at* result 0 pos))))
705            (dissect-types (if parser
706                               unknown-oids
707                               (cons basetype-oid unknown-oids))
708                           (add1 pos) (cons (cons oid basetype-oid) domains)
709                           arrays classes last-class)))
710         ((not (string=? (value-at* result 2 pos) "0")) ; Array value?
711          (let* ((elem (string->number (value-at* result 2 pos)))
712                 (delim (string-ref (value-at* result 3 pos) 0))
713                 (parser (hash-table-ref/default parsers elem #f))
714                 (oid (string->number (value-at* result 0 pos))))
715            (dissect-types (if parser
716                               unknown-oids
717                               (cons elem unknown-oids))
718                           (add1 pos) domains
719                           (cons (cons oid (cons delim elem)) arrays)
720                           classes last-class)))
721         ((string=? (value-at* result 1 pos) "c") ; Class? (i.e., table or type)
722          (let* ((classid (string->number (value-at* result 5 pos)))
723                 (attrid (string->number (value-at* result 6 pos)))
724                 (parser (hash-table-ref/default parsers attrid #f)))
725            (dissect-types (if parser
726                               unknown-oids
727                               (cons attrid unknown-oids))
728                           (add1 pos) domains arrays
729                           ;; Keep oid at the front of the list, insert this
730                           ;; attr after it, before the other attrs, if any.
731                           (if (= last-class classid)
732                               (cons (cons (caar classes)
733                                           (cons attrid (cdar classes)))
734                                     (cdr classes))
735                               (cons (cons (string->number
736                                            (value-at* result 0 pos))
737                                           (list attrid)) classes))
738                           classid)))
739         (else
740          (dissect-types unknown-oids (add1 pos)
741                         domains arrays classes last-class)))))))
742
743(define (make-value-parsers conn pqresult #!key raw)
744  (let* ((nfields (PQnfields pqresult))
745         (parsers (make-vector nfields))
746         (ht (pg-connection-oid-parsers conn)))
747    (let loop ((col 0)
748               (unknowns (list)))
749      (if (= col nfields)
750          (begin
751            (resolve-unknown-types! conn (map cdr unknowns))
752            (for-each (lambda (unknown)
753                        (let* ((col (car unknown))
754                               (oid (cdr unknown))
755                               (parser (hash-table-ref/default ht oid identity)))
756                          (vector-set! parsers col parser)))
757                      unknowns)
758            parsers)
759          (let* ((oid (PQftype pqresult col))
760                 (parser (if raw identity (hash-table-ref/default ht oid #f))))
761            (vector-set! parsers col parser)
762            (loop (add1 col) (if parser
763                                 unknowns
764                                 (cons (cons col oid) unknowns))))))))
765
766;; Collect the result pointers from the last query.
767;;
768;; A pgresult represents an entire resultset and is always read into memory
769;; all at once.
770(define (get-last-result conn #!key raw)
771  (buffer-available-input! conn)
772  (let* ((conn-ptr (pg-connection-ptr conn))
773         ;; Read out all remaining results (including the current one).
774         ;; TODO: Is this really needed? libpq does it (in pqExecFinish),
775         ;; but ostensibly only to concatenate the error messages for
776         ;; each query.  OTOH, maybe we want to do that, too.
777         (clean-results! (lambda (result)
778                           (let loop ((result result))
779                             (when result
780                               (PQclear result)
781                               (loop (PQgetResult conn-ptr))))))
782         (result (PQgetResult conn-ptr))
783         (status (PQresultStatus result)))
784    (cond
785     ((not result) (postgresql-error
786                    'get-last-result
787                    "Internal error! No result object available from server"
788                    conn))
789     ((member status (list PGRES_BAD_RESPONSE PGRES_FATAL_ERROR
790                           PGRES_NONFATAL_ERROR))
791      (let* ((get-error-field (lambda (d) (PQresultErrorField result d)))
792             (sqlstate (get-error-field PG_DIAG_SQLSTATE))
793             (maybe-severity (get-error-field PG_DIAG_SEVERITY))
794             (maybe-statement-position
795              (get-error-field PG_DIAG_STATEMENT_POSITION))
796             (condition
797              (make-pg-condition
798               'get-last-result
799               (PQresultErrorMessage result)
800               severity:           (and maybe-severity
801                                        (string->symbol
802                                         (string-downcase maybe-severity)))
803               error-class:        (and sqlstate (string-take sqlstate 2))
804               error-code:         sqlstate
805               message-detail:     (get-error-field PG_DIAG_MESSAGE_DETAIL)
806               message-hint:       (get-error-field PG_DIAG_MESSAGE_HINT)
807               statement-position: (and maybe-statement-position
808                                        (string->number
809                                         maybe-statement-position))
810               context:            (get-error-field PG_DIAG_CONTEXT)
811               source-file:        (get-error-field PG_DIAG_SOURCE_FILE)
812               source-line:        (get-error-field PG_DIAG_SOURCE_LINE)
813               source-function:    (get-error-field PG_DIAG_SOURCE_FUNCTION))))
814        (clean-results! result)
815        (signal condition)))
816     ((member status (list PGRES_COPY_OUT PGRES_COPY_IN))
817      ;; These are weird; A COPY puts the connection in "copy mode".
818      ;; As long as it's in "copy mode", pqgetresult will return the
819      ;; same result every time you call it, so don't try to call
820      ;; clean-results!
821      (let ((result-obj (make-pg-result result #f)))
822        (set-finalizer! result-obj clear-result!)
823        result-obj))
824     ((member status (list PGRES_EMPTY_QUERY PGRES_COMMAND_OK
825                           PGRES_TUPLES_OK))
826      (let ((result-obj (make-pg-result result #f)))
827        (set-finalizer! result-obj clear-result!)
828        (let ((trailing-result (PQgetResult conn-ptr)))
829          (when trailing-result
830            (clean-results! trailing-result)
831            (postgresql-error 'get-last-result
832                              (conc "Internal error! Unexpected extra "
833                                    "results after first query result")
834                              conn)))
835        (pg-result-value-parsers-set!
836         result-obj (make-value-parsers conn result raw: raw))
837        result-obj))
838     (else (postgresql-error 'get-last-result
839                             (conc "Internal error! Unknown status code: "
840                                   status)
841                             conn)))))
842
843(define (query conn query . params)
844  (query* conn query params))
845
846(define (query* conn query #!optional (params '()) #!key (format 'text) raw)
847  (let* ((params ;; Check all params and ensure they are proper pairs
848          (map ;; See if this can be moved into C
849           (lambda (p)
850             (let ((obj (if raw p (scheme-value->db-value conn p))))
851               (when (and (not (string? obj))
852                          (not (blob? obj))
853                          (not (sql-null? obj)))
854                 (postgresql-error
855                  'query*
856                  (sprintf "Param value is not string, sql-null or blob: ~S" p)
857                  conn query params format))
858               (if (sql-null? obj) #f obj))) params))
859         (send-query
860          (foreign-lambda*
861           bool ((pgconn* conn) (nonnull-c-string query)
862                 (int num) (scheme-object params) (int resfmt))
863           "int res = 0, i = 0, *lens = NULL;"
864           "char **vals = NULL;"
865           "int *fmts = NULL;"
866           "C_word obj, cons;"
867           "if (num > 0) {"
868           "    vals = C_malloc(num * sizeof(char *));"
869           "    lens = C_malloc(num * sizeof(int));"
870           "    fmts = C_malloc(num * sizeof(int));"
871           "}"
872           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
873           "    obj = C_u_i_car(cons);"
874           "    if (obj == C_SCHEME_FALSE) {"
875           "        fmts[i] = 0; /* don't care */"
876           "        lens[i] = 0;"
877           "        vals[i] = NULL;"
878           "    } else if (C_header_bits(obj) == C_BYTEVECTOR_TYPE) {"
879           "        fmts[i] = 1; /* binary */"
880           "        lens[i] = C_header_size(obj);"
881           "        vals[i] = C_c_string(obj);"
882           "    } else {"
883           "        /* text needs to be copied; it expects ASCIIZ */"
884           "        fmts[i] = 0; /* text */"
885           "        lens[i] = C_header_size(obj);"
886           "        vals[i] = malloc(lens[i] + 1);"
887           "        memcpy(vals[i], C_c_string(obj), lens[i]);"
888           "        vals[i][lens[i]] = '\\0';"
889           "    }"
890           "}"
891           "res = PQsendQueryParams((PGconn *)conn, query, num, NULL,"
892           "                        (const char * const *)vals, lens, fmts, resfmt);"
893           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
894           "    obj = C_u_i_car(cons);"
895           "    if (!C_immediatep(obj) && C_header_bits(obj) == C_STRING_TYPE)"
896           "        free(vals[i]); /* Clear copied strings only */"
897           "}"
898           "if (num > 0) {"
899           "    free(fmts);"
900           "    free(lens);"
901           "    free(vals);"
902           "}"
903           "C_return(res);")))
904   (if (send-query (pg-connection-ptr conn) query
905                   (length params) params (symbol->format format))
906       (get-last-result conn raw: raw)
907       (postgresql-error 'query*
908                         (conc "Unable to send query to server. "
909                               (PQerrorMessage (pg-connection-ptr conn)))
910                         conn query params format))))
911
912;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
913;;;; Transaction management
914;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
915
916(define (with-transaction conn thunk)
917  (let* ((old-depth (pg-connection-transaction-depth conn))
918         (rollback!
919          (lambda ()
920            (if (= old-depth 0)
921                (query conn "ROLLBACK")
922                ;; We do not *need* to give savepoints unique names,
923                ;; but it aids debugging and we know the depth anyway.
924                (query conn (conc "ROLLBACK TO SAVEPOINT s_" old-depth)))))
925         (commit!
926          (lambda ()
927            (if (= old-depth 0)
928                (query conn "COMMIT")
929                (query conn (conc "RELEASE SAVEPOINT s_" old-depth))))))
930    (if (= old-depth 0)
931        (query conn "BEGIN")
932        (query conn (conc "SAVEPOINT s_" old-depth)))
933    (pg-connection-transaction-depth-set! conn (add1 old-depth))
934    ;; TODO: Add a warning mechanism (using dynamic-wind) for when the
935    ;; user tries to jump into/out of transactions with continuations?
936    (handle-exceptions exn
937      (begin
938        (pg-connection-transaction-depth-set! conn old-depth)
939        (rollback!)
940        (raise exn))
941      (let ((res (thunk)))
942        (pg-connection-transaction-depth-set! conn old-depth)
943        (if res (commit!) (rollback!))
944        res))))
945
946(define (in-transaction? conn)
947  (> (pg-connection-transaction-depth conn) 0))
948
949;;;;;;;;;;;;;;;;;;;;
950;;;; COPY support
951;;;;;;;;;;;;;;;;;;;;
952
953(define (put-copy-data conn data)
954  (let* ((data (cond
955                ((blob? data) data)
956                ((string? data) (string->blob data))
957                ((u8vector? data) (u8vector->blob/shared data))
958                (else (postgresql-error
959                       'put-copy-data "Expected a blob, string or u8vector"
960                       conn data))))
961         (len (blob-size data))
962         (conn-ptr (pg-connection-ptr conn))
963         (conn-fd (pgsql-connection->fd conn)))
964    (let loop ((res (PQputCopyData conn-ptr data len)))
965      (cond
966       ((= res 0)
967        (thread-wait-for-i/o! conn-fd #:output)
968        (loop (PQputCopyData conn-ptr data len)))
969       ((= res 1) (void))
970       ((= res -1) (postgresql-error 'put-copy-data
971                                     (conc "Error putting COPY data. "
972                                           (PQerrorMessage conn-ptr))
973                                     conn))
974       (else (postgresql-error
975              'put-copy-data
976              (conc "Internal error! Unexpected return value: " res)
977              conn))))))
978
979(define (put-copy-end conn #!optional error-message)
980  (let ((conn-ptr (pg-connection-ptr conn))
981        (conn-fd (pgsql-connection->fd conn)))
982   (let loop ((res (PQputCopyEnd conn-ptr error-message)))
983     (cond
984      ((= res 0)
985       (thread-wait-for-i/o! conn-fd #:output)
986       (loop (PQputCopyEnd conn-ptr error-message)))
987      ((= res 1) (get-last-result conn))
988      ((= res -1) (postgresql-error 'put-copy-end
989                                    (conc "Error ending put COPY data. "
990                                          (PQerrorMessage conn-ptr))
991                                    conn error-message))
992      (else
993       (postgresql-error 'put-copy-end
994                         (conc "Internal error! Unexpected return value: " res)
995                         conn))))))
996
997(define (get-copy-data conn #!key (format 'text))
998  (let* ((conn-ptr (pg-connection-ptr conn))
999         (conn-fd (pgsql-connection->fd conn)))
1000    (let loop ()
1001      (let-location ((res int))
1002        (let ((data ((foreign-safe-lambda*
1003                      scheme-object ((pgconn* conn) ((c-pointer int) res)
1004                                     (int format))
1005                      "C_word fin = C_SCHEME_FALSE, *str; char *buf; "
1006                      "*res = PQgetCopyData(conn, &buf, 1); "
1007                      "if (buf != NULL) { /* res is length */ "
1008                      "  str = C_alloc(C_bytestowords(*res + sizeof(C_header))); "
1009                      "  fin = C_string(&str, *res, buf); "
1010                      "  if (format == 1) "
1011                      "    C_string_to_bytevector(fin);"
1012                      "  PQfreemem(buf); "
1013                      "} "
1014                      "C_return(fin);")
1015                     conn-ptr (location res) (symbol->format format))))
1016          (cond
1017           ((> res 0) data)
1018           ((= res 0) (thread-wait-for-i/o! conn-fd #:input) (loop))
1019           ((= res -1) (get-last-result conn))
1020           ((= res -2) (postgresql-error 'put-copy-data
1021                                         (conc "Error putting COPY data. "
1022                                               (PQerrorMessage conn-ptr))
1023                                         conn))
1024           (else (postgresql-error
1025                  'get-copy-data
1026                  (conc "Internal error! Unexpected return value: " res)
1027                  conn))))))))
1028
1029;;;;;;;;;;;;;;;;;;;;;;
1030;;;; Value escaping
1031;;;;;;;;;;;;;;;;;;;;;;
1032
1033(define (escape-string conn str)
1034  (define %escape-string-conn
1035    ;; This could be more efficient by copying straight into a Scheme object.
1036    ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again.
1037    ;; This can allocate up to twice as much memory than the string actually
1038    ;; uses; in extreme cases this could be a problem.
1039    (foreign-lambda* c-string* ((pgconn* conn) (c-string from) (int flen))
1040                     "int err = 0; char *to;"
1041                     "to = malloc(sizeof(char) * (flen * 2 + 1));"
1042                     "PQescapeStringConn((PGconn *)conn, to, from, (size_t)flen, &err);"
1043                     "if (err) {"
1044                     "        free(to);"
1045                     "        C_return(NULL);"
1046                     "}"
1047                     "C_return(to);"))
1048  (or (%escape-string-conn (pg-connection-ptr conn) str (string-length str))
1049      (postgresql-error 'escape-string
1050                        (conc "String escaping failed. "
1051                              (PQerrorMessage conn)) conn str)))
1052
1053(define (escape-bytea conn str)
1054  (define %escape-bytea-conn
1055    ;; This must copy because libpq returns a malloced ptr...
1056    (foreign-safe-lambda* scheme-object ((pgconn* conn)
1057                                         ;; not copied/NUL interpreted:
1058                                         ((const unsigned-c-string*) from)
1059                                         (int flen))
1060                     "size_t tolen=0; C_word res, *fin; unsigned char *esc;"
1061                     "esc = PQescapeByteaConn((PGconn *)conn, from, (size_t)flen, &tolen);"
1062                     "if (esc == NULL)"
1063                     "    C_return(C_SCHEME_FALSE);"
1064                     "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
1065                     "/* tolen includes the resulting NUL byte */"
1066                     "res = C_string(&fin, tolen - 1, (char *)esc);"
1067                     "PQfreemem(esc);"
1068                     "C_return(res);"))
1069  (or (%escape-bytea-conn (pg-connection-ptr conn) str (string-length str))
1070      (postgresql-error 'escape-bytea
1071                        (conc "Byte array escaping failed. "
1072                              (PQerrorMessage conn)) conn str)))
1073
1074(define (unescape-bytea str)
1075  (define %unescape-bytea
1076    ;; This must copy because libpq returns a malloced ptr...
1077    (foreign-safe-lambda* scheme-object (((const unsigned-c-string*) from))
1078                     "size_t tolen=0; C_word res, *fin; unsigned char *unesc;"
1079                     "unesc = PQunescapeBytea(from, &tolen);"
1080                     "if (unesc == NULL)"
1081                     "    C_return(C_SCHEME_FALSE);"
1082                     "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
1083                     "res = C_string(&fin, tolen, (char *)unesc);"
1084                     "PQfreemem(unesc);"
1085                     "C_return(res);"
1086                     ))
1087  (or (%unescape-bytea str)
1088      (postgresql-error 'unescape-bytea
1089                        "Byte array unescaping failed (out of memory?)" str)))
1090
1091
1092;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1093;;;; High-level interface
1094;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1095
1096(define (make-result-fold item-count extract-item)
1097  (lambda (kons knil result)
1098   (let ((items (item-count result)))
1099     (let loop ((seed knil)
1100                (item 0))
1101       (if (= item items)
1102           seed
1103           (loop (kons (extract-item result item) seed) (add1 item)))))))
1104
1105(define row-fold (make-result-fold row-count row-values))
1106(define (row-fold* kons knil result)
1107  (row-fold (lambda (values seed)
1108              (apply kons (append values (list seed)))) knil result))
1109
1110(define column-fold (make-result-fold column-count column-values))
1111(define (column-fold* kons knil result)
1112  (column-fold (lambda (values seed)
1113                 (apply kons (append values (list seed)))) knil result))
1114
1115
1116(define (make-result-fold-right item-count extract-item)
1117  (lambda (kons knil result)
1118    (let loop ((seed knil)
1119               (item (item-count result)))
1120      (if (= item 0)
1121          seed
1122          (loop (kons (extract-item result (sub1 item)) seed) (sub1 item))))))
1123
1124(define row-fold-right (make-result-fold-right row-count row-values))
1125(define (row-fold-right* kons knil result)
1126  (row-fold-right (lambda (values seed)
1127                    (apply kons (append values (list seed)))) knil result))
1128
1129(define column-fold-right (make-result-fold-right column-count column-values))
1130(define (column-fold-right* kons knil result)
1131  (column-fold-right (lambda (values seed)
1132                       (apply kons (append values (list seed)))) knil result))
1133
1134
1135(define (row-for-each proc result)
1136  (row-fold (lambda (values seed) (proc values)) #f result)
1137  (void))
1138(define (row-for-each* proc result)
1139  (row-fold (lambda (values seed) (apply proc values)) #f result)
1140  (void))
1141
1142(define (column-for-each proc result)
1143  (column-fold (lambda (values seed) (proc values)) #f result)
1144  (void))
1145(define (column-for-each* proc result)
1146  (column-fold (lambda (values seed) (apply proc values)) #f result)
1147  (void))
1148
1149;; Like regular Scheme map, the order in which the procedure is applied is
1150;; undefined.  We make good use of that by traversing the resultset from
1151;; the end back to the beginning, thereby avoiding a reverse! on the result.
1152(define (row-map proc res)
1153  (row-fold-right (lambda (row lst) (cons (proc row) lst)) '() res))
1154(define (row-map* proc res)
1155  (row-fold-right (lambda (row lst) (cons (apply proc row) lst)) '() res))
1156(define (column-map proc res)
1157  (column-fold-right (lambda (col lst) (cons (proc col) lst)) '() res))
1158(define (column-map* proc res)
1159  (column-fold-right (lambda (col lst) (cons (apply proc col) lst)) '() res))
1160
1161(define (result-format result)
1162  (if (and result ((foreign-lambda bool PQbinaryTuples pgresult*)
1163                   (pg-result-ptr result)))
1164     'binary 'text))
1165
1166(define (copy-query*-fold kons knil conn query
1167                          #!optional (params '()) #!key (format 'text) raw)
1168  (let* ((result (query* conn query params format: format raw: raw))
1169         (data-format (result-format result)))
1170    (handle-exceptions exn
1171      (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1172      (let loop ((data (get-copy-data conn format: data-format))
1173                 (seed knil))
1174        (if (result? data)
1175            seed
1176            ;; Explicit ordering; data could be _very_ big, allow one to be GCed
1177            (let ((next (kons data seed)))
1178              (loop (get-copy-data conn format: data-format) next)))))))
1179
1180(define (copy-query-fold kons knil conn query . params)
1181  (copy-query*-fold kons knil conn query params))
1182
1183
1184;; This is slow and memory-intensive if data is big. Provided for completeness
1185(define (copy-query*-fold-right kons knil conn query
1186                                #!optional (params '()) #!key (format 'text) raw)
1187  (let* ((result (query* conn query params format: format raw: raw))
1188         (data-format (result-format result)))
1189    (handle-exceptions exn
1190      (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1191      (let loop ((data (get-copy-data conn format: data-format)))
1192        (if (result? data)
1193            knil
1194            (kons data (loop (get-copy-data conn format: data-format))))))))
1195
1196(define (copy-query-fold-right kons knil conn query . params)
1197  (copy-query*-fold-right kons knil conn query params))
1198
1199
1200(define (copy-query*-map proc conn query
1201                         #!optional (params '()) #!key (format 'text) raw)
1202  (reverse! (copy-query*-fold (lambda (data seed) (cons (proc data) seed))
1203                              '() conn query params format: format raw: raw)))
1204
1205(define (copy-query-map proc conn query . params)
1206  (copy-query*-map proc conn query params))
1207
1208
1209(define (copy-query*-for-each proc conn query
1210                              #!optional (params '()) #!key (format 'text) raw)
1211  (copy-query*-fold (lambda (data seed) (proc data))
1212                    #f conn query params format: format raw: raw)
1213  (void))
1214
1215(define (copy-query-for-each proc conn query . params)
1216  (copy-query*-for-each proc conn query params))
1217
1218;; A bit of a weird name but consistent
1219(define (call-with-output-copy-query*
1220         proc conn query #!optional (params '()) #!key (format 'text) raw)
1221  (query* conn query params format: format raw: raw)
1222  (let* ((closed? #f)
1223         (output-port (make-output-port
1224                       (lambda (data) (put-copy-data conn data))
1225                       (lambda () (put-copy-end conn) (set! closed? #t)))))
1226    (handle-exceptions exn
1227      (if closed?
1228          (raise exn)
1229          (handle-exceptions _
1230            (raise exn)
1231            ;; Previously written data will be discarded to guarantee atomicity
1232            (put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
1233      (call-with-values (lambda () (proc output-port))
1234        (lambda args
1235          (unless closed? (put-copy-end conn))
1236          (apply values args))))))
1237
1238(define (call-with-output-copy-query proc conn query . params)
1239  (call-with-output-copy-query* proc conn query params))
1240
1241(define (with-output-to-copy-query*
1242         thunk conn query #!optional (params '()) #!key (format 'text) raw)
1243  (call-with-output-copy-query* (lambda (x) (with-output-to-port x thunk))
1244                                conn query params format: format raw: raw))
1245
1246(define (with-output-to-copy-query thunk conn query . params)
1247  (with-output-to-copy-query* thunk conn query params))
1248
1249)
Note: See TracBrowser for help on using the repository browser.