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

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

postgresql: Use C_c_string instead of the verbose generic data accessor and typecast

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 (sprintf
419                     "SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
420                     (in-list (length type-parsers)))
421        (map car type-parsers) raw: #t)))))
422
423(define (update-type-unparsers! conn new-type-unparsers)
424  (pg-connection-type-unparsers-set! conn new-type-unparsers))
425
426;;;;;;;;;;;;;;;;;;;;
427;;;; Connections
428;;;;;;;;;;;;;;;;;;;;
429
430(define-record
431  pg-connection ptr
432  type-parsers oid-parsers type-unparsers
433  transaction-depth)
434(define connection? pg-connection?)
435(define type-parsers pg-connection-type-parsers)
436(define type-unparsers pg-connection-type-unparsers)
437
438(define (pgsql-connection->fd conn)
439  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
440
441(define (wait-for-connection! conn poll-function)
442  (let ((conn-fd (pgsql-connection->fd conn))
443        (conn-ptr (pg-connection-ptr conn)))
444    (let loop ((result (poll-function conn-ptr)))
445      (cond ((= result PGRES_POLLING_OK) (void))
446            ((= result PGRES_POLLING_FAILED)
447             (let ((message (PQerrorMessage conn-ptr)))
448               (disconnect conn)
449               (postgresql-error
450                'connect 'connect
451                (conc "Polling Postgres database failed. " message) conn)))
452            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
453             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
454                                               #:input
455                                               #:output))
456             (loop (poll-function conn-ptr)))
457            (else
458             (postgresql-error
459              'internal 'connect
460              (conc "Internal error! Unknown status code: " result) conn))))))
461
462(cond-expand
463 ((not has-PQconnectdbParams)
464  (define (alist->connection-spec alist)
465    (string-join
466     (map (lambda (subspec)
467            (sprintf "~A='~A'"
468                     (car subspec) ;; this had better not contain [ =\']
469                     (string-translate* (->string (cdr subspec))
470                                        '(("\\" . "\\\\") ("'" . "\\'")))))
471          alist))))
472 (else))
473
474(define (connect-start spec)
475  (if (string? spec)
476      (PQconnectStart spec)
477      (cond-expand
478       (has-PQconnectdbParams
479        (let ((len (length spec)))
480          ((foreign-lambda* pgconn* ((scheme-object cons) (scheme-pointer keybuf)
481                                     (scheme-pointer valbuf) (int len))
482             "const char **key = (const char **)keybuf;"
483             "const char **val = (const char **)valbuf;"
484             "int i;"
485             "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {"
486             "    C_word kvpair = C_u_i_car(cons);"
487             "    key[i] = C_c_string(C_u_i_car(kvpair));"
488             "    val[i] = C_c_string(C_u_i_cdr(kvpair));"
489             "}"
490             "key[len] = NULL;"
491             "val[len] = NULL;"
492             "C_return(PQconnectStartParams(key, val, 0));")
493           (map (lambda (x) (cons (string-append (->string (car x)) "\x00")
494                                  (string-append (->string (cdr x)) "\x00"))) spec)
495           (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
496           (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
497           len)))
498       (else (PQconnectStart (alist->connection-spec spec))))))
499
500(define (connect #!optional (conn-spec '())
501                 (type-parsers (default-type-parsers))
502                 (type-unparsers (default-type-unparsers)))
503  (let ((conn-ptr (connect-start conn-spec)))
504    (cond
505     ((not conn-ptr)
506      (postgresql-error
507       'internal 'connect
508       "Unable to allocate a Postgres connection structure" conn-spec))
509     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
510      (let ((message (PQerrorMessage conn-ptr)))
511        (PQfinish conn-ptr)
512        (postgresql-error
513         'connect 'connect
514         (conc "Connection to Postgres database failed: " message) conn-spec)))
515     (else
516      (let ((conn (make-pg-connection conn-ptr type-parsers
517                                      (make-hash-table) type-unparsers 0)))
518        ;; We don't want libpq to piss in our stderr stream
519        ((foreign-lambda* void ((pgconn* conn))
520          "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
521        (wait-for-connection! conn PQconnectPoll)
522        (set-finalizer! conn disconnect)
523        ;; Retrieve type-information from PostgreSQL metadata for use by
524        ;; the various value-parsers.
525        (update-type-parsers! conn)
526        conn)))))
527
528(define (reset-connection connection)
529  (let ((conn-ptr (pg-connection-ptr connection)))
530    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
531        (wait-for-connection! connection PQresetPoll)
532        (let ((error-message (PQerrorMessage conn-ptr)))
533          (disconnect connection)
534          (postgresql-error
535           'connect 'reset-connection
536           (conc "Reset of connection failed " error-message) connection)))))
537
538(define (disconnect connection)
539  (and-let* ((conn-ptr (pg-connection-ptr connection)))
540    (pg-connection-ptr-set! connection #f)
541    (pg-connection-type-parsers-set! connection #f)
542    (pg-connection-oid-parsers-set! connection #f)
543    (PQfinish conn-ptr))
544  (void))
545
546;;;;;;;;;;;;;;;
547;;;; Results
548;;;;;;;;;;;;;;;
549
550(define-record pg-result ptr value-parsers)
551(define result? pg-result?)
552
553(define (clear-result! result)
554  (and-let* ((result-ptr (pg-result-ptr result)))
555    (pg-result-ptr-set! result #f)
556    (PQclear result-ptr)))
557
558(define (row-count result)
559  (PQntuples (pg-result-ptr result)))
560
561(define (column-count result)
562  (PQnfields (pg-result-ptr result)))
563
564;; Helper procedures for bounds checking; so we can distinguish between
565;; out of bounds and nonexistant columns, and signal it.
566(define (check-column-index! result index location)
567  (when (>= index (column-count result))
568    (postgresql-error
569     'bounds location
570     (sprintf "Result column ~A out of bounds" index) result index)))
571
572(define (check-row-index! result index location)
573  (when (>= index (row-count result))
574    (postgresql-error
575     'bounds location
576     (sprintf "Result row ~A out of bounds" index) result index)))
577
578(define (column-name result index)
579  (check-column-index! result index 'column-name)
580  (string->symbol (PQfname (pg-result-ptr result) index)))
581
582(define (column-names result)
583  (let ((ptr (pg-result-ptr result)))
584   (let loop ((names '())
585              (column (column-count result)))
586     (if (= column 0)
587         names
588         (loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
589               (sub1 column))))))
590
591(define (column-index result name)
592  (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
593    (and (>= idx 0) idx)))
594
595(define (table-oid result index)
596  (check-column-index! result index 'table-oid)
597  (let ((oid (PQftable (pg-result-ptr result) index)))
598    (and (not (= oid invalid-oid)) oid)))
599
600;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
601;; consistent with the rest of Scheme.  However, this is inconsistent with
602;; almost all other PostgreSQL interfaces...
603(define (table-column-index result index)
604  (check-column-index! result index 'table-column-index)
605  (let ((idx (PQftablecol (pg-result-ptr result) index)))
606    (and (> idx 0) (sub1 idx))))
607
608(define format-table
609  '((0 . text) (1 . binary)))
610
611(define (format->symbol format)
612  (or (alist-ref format format-table eq?)
613      (postgresql-error 'type 'format->symbol "Unknown format" format)))
614
615(define (symbol->format symbol)
616  (or (and-let* ((res (rassoc symbol format-table eq?)))
617        (car res))
618      (postgresql-error 'type 'format->symbol "Unknown format" symbol)))
619
620(define (column-format result index)
621  (check-column-index! result index 'column-format)
622  (format->symbol (PQfformat (pg-result-ptr result) index)))
623
624(define (column-type result index)
625  (check-column-index! result index 'column-type)
626  (PQftype (pg-result-ptr result) index))
627
628;; This is really not super-useful as it requires intimate knowledge
629;; about the internal implementations of types in PostgreSQL.
630(define (column-type-modifier result index)
631  (check-column-index! result index 'column-type)
632  (let ((mod (PQfmod (pg-result-ptr result) index)))
633    (and (>= mod 0) mod)))
634
635;; Unchecked version, for speed
636(define (value-at* result column row raw)
637  (let ((ptr (pg-result-ptr result)))
638   (if (PQgetisnull ptr row column)
639       (sql-null)
640       (let* ((len (PQgetlength ptr row column))
641              (fmt (PQfformat ptr column))
642              (value (case fmt
643                       ((0) (make-string len))
644                       ((1) (make-blob len))
645                       (else (postgresql-error
646                              'internal 'value-at
647                              (conc "Unknown column format type: " fmt)
648                              result column row raw)))))
649         (memcpy value (PQgetvalue-ptr ptr row column) len)
650       (if (or raw (blob? value))
651           value
652           ((vector-ref (pg-result-value-parsers result) column) value))))))
653
654(define (value-at result #!optional (column 0) (row 0) #!key raw)
655  (check-row-index! result row 'value)
656  (check-column-index! result column 'value)
657  (value-at* result column row raw))
658
659(define (row-values* result row column-count raw)
660  (let loop ((list '())
661             (column column-count))
662    (if (= column 0)
663        list
664        (loop (cons (value-at* result (sub1 column) row raw) list)
665              (sub1 column)))))
666
667(define (row-values result #!optional (row 0) #!key raw)
668  (check-row-index! result row 'row)
669  (row-values* result row (column-count result) raw))
670
671(define (column-values* result column row-count raw)
672  (let loop ((list '())
673             (row row-count))
674    (if (= row 0)
675        list
676        (loop (cons (value-at* result column (sub1 row) raw) list)
677              (sub1 row)))))
678
679(define (column-values result #!optional (column 0) #!key raw)
680  (check-column-index! result column 'column)
681  (column-values* result column (row-count result) raw))
682
683;; (define (row-alist result #!optional (row 0) #!key raw)
684;;   (map cons (column-names result) (row-values result row raw: raw)))
685(define (row-alist result #!optional (row 0) #!key raw)
686  (check-row-index! result row 'row-alist)
687  (let loop ((alist '())
688             (column (column-count result)))
689    (if (= column 0)
690        alist
691        (loop (cons (cons (string->symbol
692                           (PQfname (pg-result-ptr result) (sub1 column)))
693                          (value-at* result (sub1 column) row raw)) alist)
694              (sub1 column)))))
695
696;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
697
698(define (affected-rows result)
699  (string->number (PQcmdTuples (pg-result-ptr result))))
700
701(define (inserted-oid result)
702  (let ((oid (PQoidValue (pg-result-ptr result))))
703    (and (not (= oid invalid-oid)) oid)))
704
705
706;;;;;;;;;;;;;;;;;;;;;;;;
707;;;; Query procedures
708;;;;;;;;;;;;;;;;;;;;;;;;
709
710;; Buffer all available input, yielding if nothing is available:
711(define (buffer-available-input! conn)
712  (let ((conn-ptr (pg-connection-ptr conn))
713        (conn-fd (pgsql-connection->fd conn)))
714    (let loop ()
715      (if (PQconsumeInput conn-ptr)
716          (when (PQisBusy conn-ptr)
717            (thread-wait-for-i/o! conn-fd #:input)
718            (loop))
719          (postgresql-error
720           'i/o 'buffer-available-input!
721           (conc "Error reading reply from server. " (PQerrorMessage conn-ptr))
722           conn)))))
723
724;; Here be more dragons
725(define (resolve-unknown-types! conn oids)
726  (unless (null? oids)
727    (let* ((parsers (pg-connection-oid-parsers conn))
728           (q (conc "SELECT t.oid, t.typtype, t.typelem, t.typdelim, "
729                    "       t.typbasetype, t.typarray, a.attrelid, a.atttypid "
730                    "FROM pg_type t "
731                    "     LEFT JOIN pg_attribute a "
732                    "     ON t.typrelid = a.attrelid AND a.attnum > 0 "
733                    "WHERE t.oid IN (~A)  "
734                    "ORDER BY COALESCE(t.typrelid,-1) ASC, a.attnum ASC"))
735           (result (query* conn (sprintf q (in-list (length oids)))
736                           (map number->string oids) raw: #t))
737           (count (row-count result)))
738      (let dissect-types ((unknown-oids (list))
739                          (pos 0)
740                          (domains (list))
741                          (arrays (list))
742                          (classes (list))
743                          (last-class 0))
744        (cond
745         ((>= pos count)     ; Done scanning rows?
746          ;; Keep going until all oids are resolved
747          (resolve-unknown-types! conn unknown-oids)
748          ;; Postprocessing step: resolve all nested types
749          (for-each (lambda (d)
750                      (and-let* ((p (hash-table-ref/default parsers (cdr d) #f)))
751                        (hash-table-set! parsers (car d) p)))
752                    domains)
753          (for-each (lambda (a)
754                      (and-let* ((p (hash-table-ref/default parsers (cddr a) #f)))
755                        (hash-table-set! parsers (car a)
756                                         (make-array-parser p (cadr a)))))
757                    arrays)
758          (for-each
759           (lambda (c)
760             (and-let* ((p-list
761                         (fold
762                          (lambda (att l)
763                            (and-let* ((l)
764                                       (p (hash-table-ref/default parsers att #f)))
765                              (cons p l)))
766                          '()
767                          (cdr c))))
768               (hash-table-set! parsers (car c)
769                                (make-composite-parser p-list))))
770           classes))
771         ((not (string=? (value-at* result 4 pos #f) "0")) ; Domain type?
772          (let* ((basetype-oid (string->number (value-at* result 4 pos #f)))
773                 (parser (hash-table-ref/default parsers basetype-oid #f))
774                 (oid (string->number (value-at* result 0 pos #f))))
775            (dissect-types (if parser
776                               unknown-oids
777                               (cons basetype-oid unknown-oids))
778                           (add1 pos) (cons (cons oid basetype-oid) domains)
779                           arrays classes last-class)))
780         ((string=? (value-at* result 5 pos #f) "0") ; Array value?
781          (let* ((elem (string->number (value-at* result 2 pos #f)))
782                 (delim (string-ref (value-at* result 3 pos #f) 0))
783                 (parser (hash-table-ref/default parsers elem #f))
784                 (oid (string->number (value-at* result 0 pos #f))))
785            (dissect-types (if parser
786                               unknown-oids
787                               (cons elem unknown-oids))
788                           (add1 pos) domains
789                           (cons (cons oid (cons delim elem)) arrays)
790                           classes last-class)))
791         ((string=? (value-at* result 1 pos #f) "c") ; Class? (i.e., table or type)
792          (let* ((classid (string->number (value-at* result 6 pos #f)))
793                 (attrid (string->number (value-at* result 7 pos #f)))
794                 (parser (hash-table-ref/default parsers attrid #f)))
795            (dissect-types (if parser
796                               unknown-oids
797                               (cons attrid unknown-oids))
798                           (add1 pos) domains arrays
799                           ;; Keep oid at the front of the list, insert this
800                           ;; attr after it, before the other attrs, if any.
801                           (if (= last-class classid)
802                               (cons (cons (caar classes)
803                                           (cons attrid (cdar classes)))
804                                     (cdr classes))
805                               (cons (cons (string->number
806                                            (value-at* result 0 pos #f))
807                                           (list attrid)) classes))
808                           classid)))
809         (else
810          (dissect-types unknown-oids (add1 pos)
811                         domains arrays classes last-class)))))))
812
813(define (make-value-parsers conn pqresult #!key raw)
814  (let* ((nfields (PQnfields pqresult))
815         (parsers (make-vector nfields))
816         (ht (pg-connection-oid-parsers conn)))
817    (let loop ((col 0)
818               (unknowns (list)))
819      (if (= col nfields)
820          (begin
821            (resolve-unknown-types! conn (map cdr unknowns))
822            (for-each (lambda (unknown)
823                        (let* ((col (car unknown))
824                               (oid (cdr unknown))
825                               (parser (hash-table-ref/default ht oid identity)))
826                          (vector-set! parsers col parser)))
827                      unknowns)
828            parsers)
829          (let* ((oid (PQftype pqresult col))
830                 (parser (if raw identity (hash-table-ref/default ht oid #f))))
831            (vector-set! parsers col parser)
832            (loop (add1 col) (if parser
833                                 unknowns
834                                 (cons (cons col oid) unknowns))))))))
835
836;; Collect the result pointers from the last query.
837;;
838;; A pgresult represents an entire resultset and is always read into memory
839;; all at once.
840(define (get-last-result conn #!key raw)
841  (buffer-available-input! conn)
842  (let* ((conn-ptr (pg-connection-ptr conn))
843         ;; Read out all remaining results (including the current one).
844         ;; TODO: Is this really needed? libpq does it (in pqExecFinish),
845         ;; but ostensibly only to concatenate the error messages for
846         ;; each query.  OTOH, maybe we want to do that, too.
847         (clean-results! (lambda (result)
848                           (let loop ((result result))
849                             (when result
850                               (PQclear result)
851                               (loop (PQgetResult conn-ptr))))))
852         (result (PQgetResult conn-ptr))
853         (status (PQresultStatus result)))
854    (cond
855     ((not result) (postgresql-error
856                    'internal 'get-last-result
857                    "Internal error! No result object available from server"
858                    conn))
859     ((member status (list PGRES_BAD_RESPONSE PGRES_FATAL_ERROR
860                           PGRES_NONFATAL_ERROR))
861      (let* ((error-field (lambda (f) (and f (PQresultErrorField result f))))
862             (error-field/int (lambda (f)
863                                (and-let* ((value (error-field f)))
864                                  (string->number value))))
865             (sqlstate (error-field PG_DIAG_SQLSTATE))
866             (maybe-severity (error-field PG_DIAG_SEVERITY))
867             (condition
868              (make-pg-condition
869               'query 'get-last-result
870               (PQresultErrorMessage result)
871               ;; TODO: Add PG_DIAG_SCHEMA_NAME, ..TABLE_NAME,
872               ;; ..COLUMN_NAME and ..CONSTRAINT_NAME (with tests!)
873               ;; These are PG 9.3-only, so tests should somehow try
874               ;; to avoid checking them if not available.
875               severity:           (and maybe-severity
876                                        (string->symbol
877                                         (string-downcase maybe-severity)))
878               error-class:        (and sqlstate (string-take sqlstate 2))
879               error-code:         sqlstate
880               message-primary:    (error-field PG_DIAG_MESSAGE_PRIMARY)
881               message-detail:     (error-field PG_DIAG_MESSAGE_DETAIL)
882               message-hint:       (error-field PG_DIAG_MESSAGE_HINT)
883               statement-position: (error-field/int PG_DIAG_STATEMENT_POSITION)
884               context:            (error-field PG_DIAG_CONTEXT)
885               source-file:        (error-field PG_DIAG_SOURCE_FILE)
886               source-line:        (error-field/int PG_DIAG_SOURCE_LINE)
887               source-function:    (error-field PG_DIAG_SOURCE_FUNCTION)
888               internal-query:     (error-field PG_DIAG_INTERNAL_QUERY)
889               internal-position:  (error-field/int PG_DIAG_INTERNAL_POSITION))))
890        (clean-results! result)
891        (signal condition)))
892     ((member status (list PGRES_COPY_OUT PGRES_COPY_IN))
893      ;; These are weird; A COPY puts the connection in "copy mode".
894      ;; As long as it's in "copy mode", pqgetresult will return the
895      ;; same result every time you call it, so don't try to call
896      ;; clean-results!
897      (let ((result-obj (make-pg-result result #f)))
898        (set-finalizer! result-obj clear-result!)
899        result-obj))
900     ((member status (list PGRES_EMPTY_QUERY PGRES_COMMAND_OK
901                           PGRES_TUPLES_OK))
902      (let ((result-obj (make-pg-result result #f)))
903        (set-finalizer! result-obj clear-result!)
904        (let ((trailing-result (PQgetResult conn-ptr)))
905          (when trailing-result
906            (clean-results! trailing-result)
907            (postgresql-error 'internal 'get-last-result
908                              (conc "Internal error! Unexpected extra "
909                                    "results after first query result")
910                              conn)))
911        (pg-result-value-parsers-set!
912         result-obj (make-value-parsers conn result raw: raw))
913        result-obj))
914     (else
915      (postgresql-error 'internal 'get-last-result
916                        (conc "Internal error! Unknown status code: " status)
917                        conn)))))
918
919(define (query conn query . params)
920  (query* conn query params))
921
922(define (query* conn query #!optional (params '()) #!key (format 'text) raw)
923  (let* ((params ;; Check all params and ensure they are proper pairs
924          (map (lambda (p)
925                 (let ((obj (if raw p (scheme-value->db-value conn p))))
926                   (cond ((string? obj) ; Convert to ASCIIZ
927                          (let* ((len (##sys#size obj))
928                                 (res (string-append obj "\x00")))
929                            (vector 0 len res)))
930                         ((blob? obj)
931                          (vector 1 (##sys#size obj) obj))
932                         ((sql-null? obj) #f)
933                         (else (postgresql-error
934                                'type 'query*
935                                (sprintf "Param value is not string, sql-null or blob: ~S" p)
936                                conn query params format)))))
937               params))
938         ;; It's a shame we need to traverse params twice (and again in C)...
939         (len (length params))
940         (send-query
941          (foreign-lambda*
942              bool ((pgconn* conn) (nonnull-c-string query)
943                    (bool is_prepped) (int num) (scheme-object params)
944                    (scheme-pointer valsbuf) (scheme-pointer lensbuf)
945                    (scheme-pointer fmtsbuf) (int rfmt))
946            "int i = 0, *lens = (int *)lensbuf, *fmts = (int *)fmtsbuf;"
947            "const char **vals = (const char **)valsbuf;"
948            "C_word obj, cons;"
949            "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
950            "    obj = C_u_i_car(cons);"
951            "    if (obj == C_SCHEME_FALSE) {"
952            "        fmts[i] = lens[i] = 0;"
953            "        vals[i] = NULL;"
954            "    } else {"
955            "        fmts[i] = C_unfix(C_block_item(obj, 0));"
956            "        lens[i] = C_unfix(C_block_item(obj, 1));"
957            "        vals[i] = (const char *)C_data_pointer(C_block_item(obj, 2));"
958            "    }"
959            "}"
960            "if (is_prepped)"
961            "  C_return(PQsendQueryPrepared((PGconn *)conn, query, num,"
962            "                               vals, lens, fmts, rfmt));"
963            "else"
964            "  C_return(PQsendQueryParams((PGconn *)conn, query, num, NULL,"
965            "                             vals, lens, fmts, rfmt));"))
966         (query-as-string (if (symbol? query) (symbol->string query) query)))
967    ;; XXX: What if we're using a newer protocol version?  Then this error is
968    ;; well-meaning but completely wrong...  Unfortunately the error message
969    ;; returned by the server if we exceed this limit is even more confusing.
970    (cond ((> len 65535)
971           (postgresql-error
972            'domain 'query*
973            (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)
974            conn query params format))
975          ((send-query (pg-connection-ptr conn) query-as-string (symbol? query)
976                       len params
977                       ;; We allocate here instead of in C to keep things simple
978                       (make-blob (* len (foreign-value "sizeof(char *)" int)))
979                       (make-blob (* len (foreign-value "sizeof(int)" int)))
980                       (make-blob (* len (foreign-value "sizeof(int)" int)))
981                       (symbol->format format))
982           (get-last-result conn raw: raw))
983          (else (postgresql-error 'i/o 'query*
984                                  (conc "Unable to send query to server. "
985                                        (PQerrorMessage (pg-connection-ptr conn)))
986                                  conn query params format)))))
987
988;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
989;;;; Transaction management
990;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
991
992(define (with-transaction conn thunk #!key isolation access)
993  (let* ((old-depth (pg-connection-transaction-depth conn))
994         (isolation (and isolation
995                         (case isolation
996                           ((read-committed) "ISOLATION LEVEL READ COMMITTED")
997                           ((serializable) "ISOLATION LEVEL SERIALIZABLE")
998                           (else (postgresql-error
999                                  'type 'with-transaction
1000                                  "Unknown isolation level" isolation)))))
1001         (access (and access
1002                      (case access
1003                        ((read/write) "READ WRITE")
1004                        ((read-only) "READ ONLY")
1005                        (else (postgresql-error
1006                               'type 'with-transaction
1007                               "Unknown access mode" access)))))
1008         (characteristics (conc (or isolation "") " " (or access "")))
1009         (rollback!
1010          (lambda ()
1011            (if (zero? old-depth)
1012                (query conn "ROLLBACK")
1013                ;; We do not *need* to give savepoints unique names,
1014                ;; but it aids debugging and we know the depth anyway.
1015                (query conn (conc "ROLLBACK TO SAVEPOINT s_" old-depth)))))
1016         (commit!
1017          (lambda ()
1018            (if (zero? old-depth)
1019                (query conn "COMMIT")
1020                (query conn (conc "RELEASE SAVEPOINT s_" old-depth))))))
1021    (when (and isolation (not (zero? old-depth)))
1022      (postgresql-error
1023       'domain 'with-transaction
1024       "Can't set isolation level in nested transactions" isolation))
1025    (if (zero? old-depth)
1026        (query conn (conc "BEGIN " characteristics))
1027        (begin (query conn (conc "SAVEPOINT s_" old-depth))
1028               ;; XXX: This should probably be SET LOCAL instead of SET
1029               ;; (which is implicitly the same as SET SESSION), but I
1030               ;; can't come up with a testcase that fails with this and
1031               ;; succeeds with SET LOCAL, so keep it around for now.
1032               (when access
1033                 (query conn (conc "SET TRANSACTION " characteristics)))))
1034    (pg-connection-transaction-depth-set! conn (add1 old-depth))
1035    ;; TODO: Add a warning mechanism (using dynamic-wind) for when the
1036    ;; user tries to jump into/out of transactions with continuations?
1037    (handle-exceptions exn
1038      (begin
1039        (pg-connection-transaction-depth-set! conn old-depth)
1040        (rollback!)
1041        (raise exn))
1042      (let ((res (thunk)))
1043        (pg-connection-transaction-depth-set! conn old-depth)
1044        (if res (commit!) (rollback!))
1045        res))))
1046
1047(define (in-transaction? conn)
1048  (> (pg-connection-transaction-depth conn) 0))
1049
1050;;;;;;;;;;;;;;;;;;;;
1051;;;; COPY support
1052;;;;;;;;;;;;;;;;;;;;
1053
1054(define (put-copy-data conn data)
1055  (let* ((data (cond
1056                ((or (string? data) (blob? data)) data)
1057                ((srfi-4-vector? data) (##sys#slot data 1))
1058                (else (postgresql-error
1059                       'type 'put-copy-data
1060                       "Expected a blob, string or srfi-4 vector" conn data))))
1061         (len (##sys#size data))
1062         (conn-ptr (pg-connection-ptr conn))
1063         (conn-fd (pgsql-connection->fd conn)))
1064    (let loop ((res (PQputCopyData conn-ptr data len)))
1065      (cond
1066       ((= res 0)
1067        (thread-wait-for-i/o! conn-fd #:output)
1068        (loop (PQputCopyData conn-ptr data len)))
1069       ((= res 1) (void))
1070       ((= res -1)
1071        (postgresql-error
1072         'i/o 'put-copy-data
1073         (conc "Error putting COPY data. " (PQerrorMessage conn-ptr)) conn))
1074       (else (postgresql-error
1075              'internal 'put-copy-data
1076              (conc "Internal error! Unexpected return value: " res) conn))))))
1077
1078(define (put-copy-end conn #!optional error-message)
1079  (let ((conn-ptr (pg-connection-ptr conn))
1080        (conn-fd (pgsql-connection->fd conn)))
1081   (let loop ((res (PQputCopyEnd conn-ptr error-message)))
1082     (cond
1083      ((= res 0)
1084       (thread-wait-for-i/o! conn-fd #:output)
1085       (loop (PQputCopyEnd conn-ptr error-message)))
1086      ((= res 1) (get-last-result conn))
1087      ((= res -1)
1088       (postgresql-error
1089        'i/o 'put-copy-end
1090        (conc "Error ending put COPY data. " (PQerrorMessage conn-ptr))
1091        conn error-message))
1092      (else
1093       (postgresql-error
1094        'internal 'put-copy-end
1095        (conc "Internal error! Unexpected return value: " res) conn))))))
1096
1097(define (get-copy-data conn #!key (format 'text))
1098  (let ((conn-ptr (pg-connection-ptr conn)))
1099    (let loop ()
1100      (let-location ((buf c-pointer))
1101        (let ((res (PQgetCopyData conn-ptr (location buf) #t)))
1102          (cond
1103           ((> res 0)
1104            (let ((value (case format
1105                           ((text) (make-string res))
1106                           ((binary) (make-blob res))
1107                           (else (postgresql-error
1108                                  'internal 'get-copy-data
1109                                  (conc "Unknown column format type: " format)
1110                                  conn)))))
1111              (memcpy value buf res)
1112              (free buf)
1113              value))
1114           ((= res 0)
1115            (buffer-available-input! conn)
1116            (loop))
1117           ((= res -1)
1118            (get-last-result conn))
1119           ((= res -2)
1120            (postgresql-error
1121             'i/o 'put-copy-data
1122             (conc "Error getting COPY data. " (PQerrorMessage conn-ptr)) conn))
1123           (else (postgresql-error
1124                  'internal 'get-copy-data
1125                  (conc "Internal error! Unexpected return value: " res)
1126                  conn))))))))
1127
1128;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1129;;;; Value escaping and quotation
1130;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1131
1132(define (escape-string conn str)
1133  (define %escape-string-conn
1134    (foreign-lambda size_t PQescapeStringConn
1135      pgconn* scheme-pointer scheme-pointer size_t (c-pointer bool)))
1136  (let-location ((err bool))
1137    (let* ((strlen (string-length str))
1138           (buffer (make-string (add1 (* strlen 2))))
1139           (size (%escape-string-conn (pg-connection-ptr conn) buffer str strlen (location err))))
1140      (cond (err (postgresql-error 'internal 'escape-string
1141                                   (conc "String escaping failed. "
1142                                         (PQerrorMessage conn)) conn str))
1143            ((fx= size strlen) buffer)
1144            (else (##sys#substring buffer 0 size))))))
1145
1146(define (quote-identifier conn str)
1147  (cond-expand
1148   (has-PQescapeIdentifier
1149    (define %escape-ident
1150      (foreign-lambda c-string* PQescapeIdentifier pgconn* scheme-pointer size_t))
1151    (or (%escape-ident (pg-connection-ptr conn) str (string-length str))
1152        (postgresql-error 'internal 'quote-identifier
1153                          (conc "Identifier escaping failed. "
1154                                (PQerrorMessage conn)) conn str)))
1155   (else (postgresql-error 'unsupported-version 'quote-identifier
1156                           (conc "Please upgrade your PostgreSQL to 9.0 or later "
1157                                 "in order to be able to use quote-identifier!")
1158                           conn str))))
1159
1160(define (escape-bytea conn obj)
1161  (define %escape-bytea-conn
1162    (foreign-lambda (c-pointer unsigned-char) PQescapeByteaConn
1163      pgconn* scheme-pointer size_t (c-pointer size_t)))
1164  (let-location ((allocated size_t))
1165    (let* ((data (cond ((or (string? obj) (blob? obj)) obj)
1166                       ((srfi-4-vector? obj) (##sys#slot obj 1))
1167                       (else (postgresql-error
1168                              'type 'escape-bytea
1169                              "Expected string, blob or srfi-4 vector" obj))))
1170           (buf (%escape-bytea-conn (pg-connection-ptr conn) data
1171                                    (##sys#size data) (location allocated))))
1172     (if buf
1173         (let* ((string-length (sub1 allocated))
1174                (result-string (make-string string-length)))
1175           (memcpy result-string buf string-length)
1176           (free buf)
1177           result-string)
1178         (postgresql-error
1179          'internal 'escape-bytea
1180          (conc "Byte array escaping failed. " (PQerrorMessage conn)) conn obj)))))
1181
1182(define (unescape-bytea str)
1183  (define %unescape-bytea
1184    (foreign-lambda (c-pointer unsigned-char) PQunescapeBytea c-string (c-pointer size_t)))
1185  (let-location ((blob-length size_t))
1186    (let ((buf (%unescape-bytea str (location blob-length))))
1187      (if buf 
1188          (let ((result-blob (make-blob blob-length)))
1189            (memcpy result-blob buf blob-length)
1190            (free buf)
1191            (blob->u8vector/shared result-blob))
1192          (postgresql-error 'internal 'unescape-bytea
1193                            "Byte array unescaping failed (out of memory?)" str)))))
1194
1195
1196;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1197;;;; High-level interface
1198;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1199
1200(define (make-result-fold item-count sub-item-count extract-item)
1201  (lambda (kons knil result)
1202   (let ((items (item-count result))
1203         (sub-items (sub-item-count result)))
1204     (let loop ((seed knil)
1205                (item 0))
1206       (if (= item items)
1207           seed
1208           (loop (kons (extract-item result item sub-items #f) seed) (add1 item)))))))
1209
1210(define row-fold (make-result-fold row-count column-count row-values*))
1211(define (row-fold* kons knil result)
1212  (row-fold (lambda (values seed)
1213              (apply kons (append values (list seed)))) knil result))
1214
1215(define column-fold (make-result-fold column-count row-count column-values*))
1216(define (column-fold* kons knil result)
1217  (column-fold (lambda (values seed)
1218                 (apply kons (append values (list seed)))) knil result))
1219
1220
1221(define (make-result-fold-right item-count sub-item-count extract-item)
1222  (lambda (kons knil result)
1223    (let ((sub-items (sub-item-count result)))
1224      (let loop ((seed knil)
1225                 (item (item-count result)))
1226        (if (= item 0)
1227            seed
1228            (loop (kons (extract-item result (sub1 item) sub-items #f) seed) (sub1 item)))))))
1229
1230(define row-fold-right (make-result-fold-right row-count column-count row-values*))
1231(define (row-fold-right* kons knil result)
1232  (row-fold-right (lambda (values seed)
1233                    (apply kons (append values (list seed)))) knil result))
1234
1235(define column-fold-right (make-result-fold-right column-count row-count column-values*))
1236(define (column-fold-right* kons knil result)
1237  (column-fold-right (lambda (values seed)
1238                       (apply kons (append values (list seed)))) knil result))
1239
1240
1241(define (row-for-each proc result)
1242  (row-fold (lambda (values seed) (proc values)) #f result)
1243  (void))
1244(define (row-for-each* proc result)
1245  (row-fold (lambda (values seed) (apply proc values)) #f result)
1246  (void))
1247
1248(define (column-for-each proc result)
1249  (column-fold (lambda (values seed) (proc values)) #f result)
1250  (void))
1251(define (column-for-each* proc result)
1252  (column-fold (lambda (values seed) (apply proc values)) #f result)
1253  (void))
1254
1255;; Like regular Scheme map, the order in which the procedure is applied is
1256;; undefined.  We make good use of that by traversing the resultset from
1257;; the end back to the beginning, thereby avoiding a reverse! on the result.
1258(define (row-map proc res)
1259  (row-fold-right (lambda (row lst) (cons (proc row) lst)) '() res))
1260(define (row-map* proc res)
1261  (row-fold-right (lambda (row lst) (cons (apply proc row) lst)) '() res))
1262(define (column-map proc res)
1263  (column-fold-right (lambda (col lst) (cons (proc col) lst)) '() res))
1264(define (column-map* proc res)
1265  (column-fold-right (lambda (col lst) (cons (apply proc col) lst)) '() res))
1266
1267(define (result-format result)
1268  (if (and result ((foreign-lambda bool PQbinaryTuples pgresult*)
1269                   (pg-result-ptr result)))
1270     'binary 'text))
1271
1272(define (copy-query*-fold kons knil conn query
1273                          #!optional (params '()) #!key (format 'text) raw)
1274  (let* ((result (query* conn query params format: format raw: raw))
1275         (data-format (result-format result)))
1276    (handle-exceptions exn
1277      (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1278      (let loop ((data (get-copy-data conn format: data-format))
1279                 (seed knil))
1280        (if (result? data)
1281            seed
1282            ;; Explicit ordering; data could be _very_ big, allow one to be GCed
1283            (let ((next (kons data seed)))
1284              (loop (get-copy-data conn format: data-format) next)))))))
1285
1286(define (copy-query-fold kons knil conn query . params)
1287  (copy-query*-fold kons knil conn query params))
1288
1289
1290;; This is slow and memory-intensive if data is big. Provided for completeness
1291(define (copy-query*-fold-right kons knil conn query
1292                                #!optional (params '()) #!key (format 'text) raw)
1293  (let* ((result (query* conn query params format: format raw: raw))
1294         (data-format (result-format result)))
1295    (handle-exceptions exn
1296      (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1297      (let loop ((data (get-copy-data conn format: data-format)))
1298        (if (result? data)
1299            knil
1300            (kons data (loop (get-copy-data conn format: data-format))))))))
1301
1302(define (copy-query-fold-right kons knil conn query . params)
1303  (copy-query*-fold-right kons knil conn query params))
1304
1305
1306(define (copy-query*-map proc conn query
1307                         #!optional (params '()) #!key (format 'text) raw)
1308  (reverse! (copy-query*-fold (lambda (data seed) (cons (proc data) seed))
1309                              '() conn query params format: format raw: raw)))
1310
1311(define (copy-query-map proc conn query . params)
1312  (copy-query*-map proc conn query params))
1313
1314
1315(define (copy-query*-for-each proc conn query
1316                              #!optional (params '()) #!key (format 'text) raw)
1317  (copy-query*-fold (lambda (data seed) (proc data))
1318                    #f conn query params format: format raw: raw)
1319  (void))
1320
1321(define (copy-query-for-each proc conn query . params)
1322  (copy-query*-for-each proc conn query params))
1323
1324;; A bit of a weird name but consistent
1325(define (call-with-output-copy-query*
1326         proc conn query #!optional (params '()) #!key (format 'text) raw)
1327  (query* conn query params format: format raw: raw)
1328  (let* ((closed? #f)
1329         (output-port (make-output-port
1330                       (lambda (data) (put-copy-data conn data))
1331                       (lambda () (put-copy-end conn) (set! closed? #t)))))
1332    (handle-exceptions exn
1333      (if closed?
1334          (raise exn)
1335          (handle-exceptions _
1336            (raise exn)
1337            ;; Previously written data will be discarded to guarantee atomicity
1338            (put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
1339      (call-with-values (lambda () (proc output-port))
1340        (lambda args
1341          (unless closed? (put-copy-end conn))
1342          (apply values args))))))
1343
1344(define (call-with-output-copy-query proc conn query . params)
1345  (call-with-output-copy-query* proc conn query params))
1346
1347(define (with-output-to-copy-query*
1348         thunk conn query #!optional (params '()) #!key (format 'text) raw)
1349  (call-with-output-copy-query* (lambda (x) (with-output-to-port x thunk))
1350                                conn query params format: format raw: raw))
1351
1352(define (with-output-to-copy-query thunk conn query . params)
1353  (with-output-to-copy-query* thunk conn query params))
1354
1355)
Note: See TracBrowser for help on using the repository browser.