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

Last change on this file since 21512 was 21512, checked in by sjamaan, 10 years ago

postgresql: Fix problem with reading of composite values with trailing NULLs

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