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

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

Add small note about in-list procedure

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