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

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

Do not try to be too "smart" about vector values. The Scheme values don't matter, as long as the output (pgsql values) are of the same type

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