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

Last change on this file since 30251 was 30251, checked in by sjamaan, 7 years ago

postgresql: Fix formatting

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