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

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

postgresql: reindent

File size: 59.9 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
119;; TODO: Create a real callback system?
120(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }")
121
122(define-syntax define-foreign-int
123  (er-macro-transformer
124   (lambda (e r c)
125     ;; cannot rename define-foreign-variable; it's a really special form
126    `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
127
128(define-foreign-int PG_DIAG_SEVERITY)
129(define-foreign-int PG_DIAG_SQLSTATE)
130(define-foreign-int PG_DIAG_MESSAGE_PRIMARY)
131(define-foreign-int PG_DIAG_MESSAGE_DETAIL)
132(define-foreign-int PG_DIAG_MESSAGE_HINT)
133(define-foreign-int PG_DIAG_STATEMENT_POSITION)
134(define-foreign-int PG_DIAG_CONTEXT)
135(define-foreign-int PG_DIAG_SOURCE_FILE)
136(define-foreign-int PG_DIAG_SOURCE_LINE)
137(define-foreign-int PG_DIAG_SOURCE_FUNCTION)
138(cond-expand
139  (has-PG_DIAG_INTERNAL_QUERY+POSITION
140   (define-foreign-int PG_DIAG_INTERNAL_QUERY)
141   (define-foreign-int PG_DIAG_INTERNAL_POSITION))
142  (else
143   (define PG_DIAG_INTERNAL_QUERY #f)
144   (define PG_DIAG_INTERNAL_POSITION #f)))
145
146;; Helper procedure for lists (TODO: use ANY instead of IN with an array?)
147(define (in-list len)
148  (string-intersperse
149   (list-tabulate len (lambda (p) (conc "$" (add1 p)))) ","))
150
151(define (postgresql-error subtype loc message . args)
152  (signal (make-pg-condition subtype loc message args: args)))
153
154;; TODO: DEPRECATED/OBSOLETE: We should only attach this info to the
155;; query subcondition where it's generated.
156(define (make-pg-condition subtype loc message #!key (args '()) severity
157                           error-class error-code
158                           message-primary message-detail message-hint
159                           statement-position context
160                           source-file source-line source-function
161                           internal-query internal-position)
162  (make-composite-condition
163    (make-property-condition
164     'exn 'location loc 'message message 'arguments args)
165    (make-property-condition
166     'postgresql 'severity severity 'error-class error-class
167     'error-code error-code
168     'message-primary message-primary 'message-detail message-detail
169     'message-hint message-hint 'statement-position statement-position
170     'context context 'source-file source-file 'source-line source-line
171     'internal-query internal-query 'internal-position internal-position
172     'source-function source-function)
173    (if (eq? subtype 'query)
174        (make-property-condition
175         'query '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 (condition? subtype) subtype (make-property-condition subtype)))))
183
184;;;;;;;;;;;;;;;;;;;;;;;;
185;;;; Type parsers
186;;;;;;;;;;;;;;;;;;;;;;;;
187
188(define (char-parser str) (string-ref str 0))
189
190(define (bool-parser str) (string=? str "t"))
191
192(define (numeric-parser str)
193  (or (string->number str)
194      (postgresql-error 'parse 'numeric-parser "Unable to parse number" str)))
195
196(define (bytea-parser str)
197  (blob->u8vector/shared (string->blob (unescape-bytea str))))
198
199;; Here be dragons
200(define (make-array-parser element-parser #!optional (delim #\,))
201  (define (parse str)
202    (if (string-ci=? "NULL" str)
203        (sql-null)
204        (element-parser str)))
205  (lambda (str)
206    (let loop ((chars (let ignore-bounds ((chars (string->list str)))
207                        (if (char=? (car chars) #\{)
208                            chars
209                            (ignore-bounds (cdr chars)))))
210               (result (list)))
211      (if (null? chars)
212          (car result) ; Should contain only one vector
213          (case (car chars)
214            ((#\{) (receive (value rest-chars)
215                     (loop (cdr chars) (list))
216                     (loop rest-chars (cons value result))))
217            ((#\}) (values (list->vector (reverse! result)) (cdr chars)))
218            ((#\") (let consume-string ((chars (cdr chars))
219                                        (consumed (list)))
220                     (case (car chars)
221                       ((#\\) (consume-string ; Don't interpret, just add it
222                               (cddr chars) (cons (cadr chars) consumed)))
223                       ((#\") (loop (cdr chars)
224                                    (cons (element-parser
225                                           (reverse-list->string consumed))
226                                          result)))
227                       (else (consume-string (cdr chars)
228                                             (cons (car chars) consumed))))))
229            ((#\tab #\newline #\space) (loop (cdr chars) result))
230            (else
231             (if (char=? (car chars) delim)
232                 (loop (cdr chars) result)
233                 (let consume-string ((chars chars)
234                                      (consumed (list)))
235                   (cond
236                    ((char=? (car chars) delim)
237                     (loop (cdr chars)
238                           (cons (parse (reverse-list->string consumed))
239                                 result)))
240                    ((or (char=? (car chars) #\})
241                         (char=? (car chars) #\}))
242                     (loop chars
243                           (cons (parse (reverse-list->string consumed))
244                                 result)))
245                    (else (consume-string (cdr chars)
246                                          (cons (car chars) consumed))))))))))))
247
248(define (make-composite-parser element-parsers)
249  (define (parse str element-parser)
250    (if (string=? "" str)
251        (sql-null)
252        (element-parser str)))
253  (lambda (str)
254    (let loop ((chars (cdr (string->list (string-trim str)))) ; skip leading (
255               (maybe-null? #t)
256               (result (list))
257               (parsers element-parsers))
258      (case (car chars)
259        ((#\)) (reverse! (if maybe-null?
260                             (cons (sql-null) result)
261                             result)))
262        ((#\") (let consume-string ((chars (cdr chars))
263                                    (consumed (list)))
264                 (case (car chars)
265                   ((#\\) (consume-string ; Don't interpret, just add it
266                           (cddr chars) (cons (cadr chars) consumed)))
267                   ((#\") (if (char=? #\" (cadr chars)) ; double escapes
268                              (consume-string (cddr chars)
269                                              (cons #\" consumed))
270                              (let skip-spaces ((chars (cdr chars)))
271                                (case (car chars)
272                                  ((#\space #\newline #\tab)
273                                   (skip-spaces (cdr chars)))
274                                  ((#\,)
275                                   (loop (cdr chars)
276                                         #t
277                                         (cons ((car parsers)
278                                                (reverse-list->string consumed))
279                                               result)
280                                         (cdr parsers)))
281                                  ((#\)) (loop chars
282                                               #f
283                                               (cons ((car parsers)
284                                                      (reverse-list->string consumed))
285                                                     result)
286                                               (cdr parsers)))
287                                  (else
288                                   (postgresql-error
289                                    'parse 'make-composite-parser
290                                    "Bogus trailing characters" str))))))
291                   (else (consume-string (cdr chars)
292                                         (cons (car chars) consumed))))))
293        (else (let consume-string ((chars chars)
294                                   (consumed (list)))
295                (case (car chars)
296                  ((#\,) (loop (cdr chars)
297                               #t
298                               (cons (parse (reverse-list->string consumed)
299                                            (car parsers))
300                                     result)
301                               (cdr parsers)))
302                  ;; Nothing should precede this one
303                  ((#\)) (loop chars
304                               #f
305                               (cons (parse (reverse-list->string consumed)
306                                            (car parsers))
307                                     result)
308                               (cdr parsers)))
309                  (else (consume-string (cdr chars)
310                                        (cons (car chars) consumed))))))))))
311
312;; Array parsers and composite parsers are automatically cached when such
313;; a value is requested.
314(define default-type-parsers
315  (make-parameter
316   `(("text" . ,identity)
317     ("bytea" . ,bytea-parser)
318     ("char" . ,char-parser)
319     ("bpchar" . ,identity)
320     ("bool" . ,bool-parser)
321     ("int8" . ,numeric-parser)
322     ("int4" . ,numeric-parser)
323     ("int2" . ,numeric-parser)
324     ("float4" . ,numeric-parser)
325     ("float8" . ,numeric-parser)
326     ("numeric" . ,numeric-parser)
327     ("oid" . ,numeric-parser)
328     ;; Nasty hack, or clever hack? :)
329     ("record" . ,(make-composite-parser (circular-list identity))))))
330
331;;;;;;;;;;;;;;;;;;;;;;;
332;;;; Type unparsers
333;;;;;;;;;;;;;;;;;;;;;;;
334
335(define (scheme-value->db-value conn value)
336  (cond ((find (lambda (parse?)
337                 ((car parse?) value))
338               (pg-connection-type-unparsers conn)) =>
339               (lambda (parse)
340                 ((cdr parse) conn value)))
341        (else value)))
342
343(define (bool-unparser conn b)
344  (if b "TRUE" "FALSE"))
345
346(define (vector-unparser conn v)
347  (let loop ((result (list))
348             (pos 0)
349             (len (vector-length v)))
350    (if (= pos len)
351        (string-append "{" (string-intersperse (reverse! result) ",") "}")
352        (let* ((value (vector-ref v pos))
353               (unparsed-value (scheme-value->db-value conn value))
354               (serialized (cond
355                            ((sql-null? unparsed-value) "NULL")
356                            ((not (string? unparsed-value))
357                             (postgresql-error
358                              'unparse 'vector-unparser
359                              "Param value is not string" unparsed-value))
360                            ((vector? value) unparsed-value) ;; don't quote!
361                            (else
362                             (sprintf "\"~A\""
363                                      (string-translate*
364                                       unparsed-value
365                                       '(("\\" . "\\\\") ("\"" . "\\\""))))))))
366          (loop (cons serialized result) (add1 pos) len)))))
367
368(define (list-unparser conn l)
369  (let loop ((result (list))
370             (items l))
371    (if (null? items)
372        (string-append "(" (string-intersperse (reverse! result) ",") ")")
373        (let* ((unparsed-value (scheme-value->db-value conn (car items)))
374               (serialized (cond
375                            ((sql-null? unparsed-value) "")
376                            ((not (string? unparsed-value))
377                             (postgresql-error
378                              'unparse 'list-unparser
379                              "Param value is not string" unparsed-value))
380                            (else
381                             (sprintf "\"~A\""
382                                      (string-translate*
383                                       unparsed-value
384                                       '(("\\" . "\\\\") ("\"" . "\\\""))))))))
385          (loop (cons serialized result) (cdr items))))))
386
387(define default-type-unparsers
388  (make-parameter
389   `((,string? . ,(lambda (conn s) s))
390     (,u8vector? . ,(lambda (conn v) (u8vector->blob/shared v)))
391     (,char? . ,(lambda (conn c) (string c)))
392     (,boolean? . ,bool-unparser)
393     (,number? . ,(lambda (conn n) (number->string n)))
394     (,vector? . ,vector-unparser)
395     (,pair? . ,list-unparser))))
396
397;; Retrieve type-oids from PostgreSQL:
398(define (update-type-parsers! conn #!optional new-type-parsers)
399  (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
400        (ht (make-hash-table))
401        (result '()))
402    (pg-connection-oid-parsers-set! conn ht)
403    (pg-connection-type-parsers-set! conn type-parsers)
404    (unless (null? type-parsers)   ; empty IN () clause is not allowed
405      (row-for-each*
406       (lambda (oid typname)
407         (and-let* ((procedure (assoc typname type-parsers)))
408           (hash-table-set! ht (string->number oid) (cdr procedure))))
409       (query* conn (sprintf
410                     "SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
411                     (in-list (length type-parsers)))
412        (map car type-parsers) raw: #t)))))
413
414(define (update-type-unparsers! conn new-type-unparsers)
415  (pg-connection-type-unparsers-set! conn new-type-unparsers))
416
417;;;;;;;;;;;;;;;;;;;;
418;;;; Connections
419;;;;;;;;;;;;;;;;;;;;
420
421(define-record
422  pg-connection ptr
423  type-parsers oid-parsers type-unparsers
424  transaction-depth)
425(define connection? pg-connection?)
426(define type-parsers pg-connection-type-parsers)
427(define type-unparsers pg-connection-type-unparsers)
428
429(define (pgsql-connection->fd conn)
430  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
431
432(define (wait-for-connection! conn poll-function)
433  (let ((conn-fd (pgsql-connection->fd conn))
434        (conn-ptr (pg-connection-ptr conn)))
435    (let loop ((result (poll-function conn-ptr)))
436      (cond ((= result PGRES_POLLING_OK) (void))
437            ((= result PGRES_POLLING_FAILED)
438             (let ((message (PQerrorMessage conn-ptr)))
439               (disconnect conn)
440               (postgresql-error
441                'connect 'connect
442                (conc "Polling Postgres database failed. " message) conn)))
443            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
444             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
445                                               #:input
446                                               #:output))
447             (loop (poll-function conn-ptr)))
448            (else
449             (postgresql-error
450              'internal 'connect
451              (conc "Internal error! Unknown status code: " result) conn))))))
452
453(cond-expand
454 ((not has-PQconnectdbParams)
455  (define (alist->connection-spec alist)
456    (string-join
457     (map (lambda (subspec)
458            (sprintf "~A='~A'"
459                     (car subspec) ;; this had better not contain [ =\']
460                     (string-translate* (->string (cdr subspec))
461                                        '(("\\" . "\\\\") ("'" . "\\'")))))
462          alist))))
463 (else))
464
465(define (connect-start spec)
466  (if (string? spec)
467      (PQconnectStart spec)
468      (cond-expand
469       (has-PQconnectdbParams
470        ((foreign-lambda* pgconn* ((scheme-object cons) (int len))
471                          "char **key, **val;"
472                          "int i, n;"
473                          "C_word obj;"
474                          "PGconn *res;"
475                          "key = C_alloca(sizeof(char *) * (len+1));"
476                          "val = C_alloca(sizeof(char *) * (len+1));"
477                          "if (key == NULL || val == NULL)"
478                          "    C_return(NULL);"
479                          "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {"
480                          "    obj = C_u_i_car(C_u_i_car(cons));"
481                          "    n = C_header_size(obj);"
482                          "    key[i] = C_alloca(n+1);"
483                          "    if (key[i] == NULL) "
484                          "        C_return(NULL);"
485                          "    memcpy(key[i], C_c_string(obj), n);"
486                          "    key[i][n] = '\\0';"
487                          "    "
488                          "    obj = C_u_i_cdr(C_u_i_car(cons));"
489                          "    n = C_header_size(obj);"
490                          "    val[i] = C_alloca(n+1);"
491                          "    if (val[i] == NULL) "
492                          "        C_return(NULL);"
493                          "    memcpy(val[i], C_c_string(obj), n);"
494                          "    val[i][n] = '\\0';"
495                          "}"
496                          "key[len] = NULL;"
497                          "val[len] = NULL;"
498                          "C_return(PQconnectStartParams((const char **)key, "
499                          "                              (const char **)val, 0));")
500         (map (lambda (x) (cons (->string (car x)) (->string (cdr x)))) spec)
501         (length spec)))
502       (else (PQconnectStart (alist->connection-spec spec))))))
503
504(define (connect #!optional (conn-spec '())
505                 (type-parsers (default-type-parsers))
506                 (type-unparsers (default-type-unparsers)))
507  (let ((conn-ptr (connect-start conn-spec)))
508    (cond
509     ((not conn-ptr)
510      (postgresql-error
511       'internal 'connect
512       "Unable to allocate a Postgres connection structure" conn-spec))
513     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
514      (let ((message (PQerrorMessage conn-ptr)))
515        (PQfinish conn-ptr)
516        (postgresql-error
517         'connect 'connect
518         (conc "Connection to Postgres database failed: " message) conn-spec)))
519     (else
520      (let ((conn (make-pg-connection conn-ptr type-parsers
521                                      (make-hash-table) type-unparsers 0)))
522        ;; We don't want libpq to piss in our stderr stream
523        ((foreign-lambda* void ((pgconn* conn))
524          "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
525        (wait-for-connection! conn PQconnectPoll)
526        (set-finalizer! conn disconnect)
527        ;; Retrieve type-information from PostgreSQL metadata for use by
528        ;; the various value-parsers.
529        (update-type-parsers! conn)
530        conn)))))
531
532(define (reset-connection connection)
533  (let ((conn-ptr (pg-connection-ptr connection)))
534    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
535        (wait-for-connection! connection PQresetPoll)
536        (let ((error-message (PQerrorMessage conn-ptr)))
537          (disconnect connection)
538          (postgresql-error
539           'connect 'reset-connection
540           (conc "Reset of connection failed " error-message) connection)))))
541
542(define (disconnect connection)
543  (and-let* ((conn-ptr (pg-connection-ptr connection)))
544    (pg-connection-ptr-set! connection #f)
545    (pg-connection-type-parsers-set! connection #f)
546    (pg-connection-oid-parsers-set! connection #f)
547    (PQfinish conn-ptr))
548  (void))
549
550;;;;;;;;;;;;;;;
551;;;; Results
552;;;;;;;;;;;;;;;
553
554(define-record pg-result ptr value-parsers)
555(define result? pg-result?)
556
557(define (clear-result! result)
558  (and-let* ((result-ptr (pg-result-ptr result)))
559    (pg-result-ptr-set! result #f)
560    (PQclear result-ptr)))
561
562(define (row-count result)
563  (PQntuples (pg-result-ptr result)))
564
565(define (column-count result)
566  (PQnfields (pg-result-ptr result)))
567
568;; Helper procedures for bounds checking; so we can distinguish between
569;; out of bounds and nonexistant columns, and signal it.
570(define (check-column-index! result index location)
571  (when (>= index (column-count result))
572    (postgresql-error
573     'bounds location
574     (sprintf "Result column ~A out of bounds" index) result index)))
575
576(define (check-row-index! result index location)
577  (when (>= index (row-count result))
578    (postgresql-error
579     'bounds location
580     (sprintf "Result row ~A out of bounds" index) result index)))
581
582(define (column-name result index)
583  (check-column-index! result index 'column-name)
584  (string->symbol (PQfname (pg-result-ptr result) index)))
585
586(define (column-names result)
587  (let ((ptr (pg-result-ptr result)))
588   (let loop ((names '())
589              (column (column-count result)))
590     (if (= column 0)
591         names
592         (loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
593               (sub1 column))))))
594
595(define (column-index result name)
596  (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
597    (and (>= idx 0) idx)))
598
599(define (table-oid result index)
600  (check-column-index! result index 'table-oid)
601  (let ((oid (PQftable (pg-result-ptr result) index)))
602    (and (not (= oid invalid-oid)) oid)))
603
604;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
605;; consistent with the rest of Scheme.  However, this is inconsistent with
606;; almost all other PostgreSQL interfaces...
607(define (table-column-index result index)
608  (check-column-index! result index 'table-column-index)
609  (let ((idx (PQftablecol (pg-result-ptr result) index)))
610    (and (> idx 0) (sub1 idx))))
611
612(define format-table
613  '((0 . text) (1 . binary)))
614
615(define (format->symbol format)
616  (or (alist-ref format format-table eq?)
617      (postgresql-error 'type 'format->symbol "Unknown format" format)))
618
619(define (symbol->format symbol)
620  (or (and-let* ((res (rassoc symbol format-table eq?)))
621        (car res))
622      (postgresql-error 'type 'format->symbol "Unknown format" symbol)))
623
624(define (column-format result index)
625  (check-column-index! result index 'column-format)
626  (format->symbol (PQfformat (pg-result-ptr result) index)))
627
628(define (column-type result index)
629  (check-column-index! result index 'column-type)
630  (PQftype (pg-result-ptr result) index))
631
632;; This is really not super-useful as it requires intimate knowledge
633;; about the internal implementations of types in PostgreSQL.
634(define (column-type-modifier result index)
635  (check-column-index! result index 'column-type)
636  (let ((mod (PQfmod (pg-result-ptr result) index)))
637    (and (>= mod 0) mod)))
638
639;; Unchecked version, for speed
640(define (value-at* result column row #!key raw)
641  (let ((ptr (pg-result-ptr result)))
642   (if (PQgetisnull ptr row column)
643       (sql-null)
644       (let* ((len (PQgetlength ptr row column))
645              (fmt (PQfformat ptr column))
646              (value (case fmt
647                       ((0) (make-string len))
648                       ((1) (make-blob len))
649                       (else (postgresql-error
650                              'internal 'value-at
651                              (conc "Unknown column format type: " fmt)
652                              result column row raw)))))
653       ((foreign-lambda c-pointer "C_memcpy" scheme-pointer c-pointer size_t)
654          value (PQgetvalue-ptr ptr row column) len)
655       (if (or raw (blob? value))
656           value
657           ((vector-ref (pg-result-value-parsers result) column) value))))))
658
659(define (value-at result #!optional (column 0) (row 0) #!key raw)
660  (check-row-index! result row 'value)
661  (check-column-index! result column 'value)
662  (value-at* result column row raw: raw))
663
664(define (row-values result #!optional (row 0) #!key raw)
665  (check-row-index! result row 'row)
666  (let loop ((list '())
667             (column (column-count result)))
668    (if (= column 0)
669        list
670        (loop (cons (value-at* result (sub1 column) row raw: raw) list)
671              (sub1 column)))))
672
673(define (column-values result #!optional (column 0) #!key raw)
674  (check-column-index! result column 'column)
675  (let loop ((list '())
676             (row (row-count result)))
677    (if (= row 0)
678        list
679        (loop (cons (value-at* result column (sub1 row) raw: raw) list)
680              (sub1 row)))))
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: 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) "0")) ; Domain type?
771          (let* ((basetype-oid (string->number (value-at* result 4 pos)))
772                 (parser (hash-table-ref/default parsers basetype-oid #f))
773                 (oid (string->number (value-at* result 0 pos))))
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) "0") ; Array value?
780          (let* ((elem (string->number (value-at* result 2 pos)))
781                 (delim (string-ref (value-at* result 3 pos) 0))
782                 (parser (hash-table-ref/default parsers elem #f))
783                 (oid (string->number (value-at* result 0 pos))))
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) "c") ; Class? (i.e., table or type)
791          (let* ((classid (string->number (value-at* result 6 pos)))
792                 (attrid (string->number (value-at* result 7 pos)))
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))
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 ;; See if this can be moved into C
924           (lambda (p)
925             (let ((obj (if raw p (scheme-value->db-value conn p))))
926               (when (and (not (string? obj))
927                          (not (blob? obj))
928                          (not (sql-null? obj)))
929                 (postgresql-error
930                  'type 'query*
931                  (sprintf "Param value is not string, sql-null or blob: ~S" p)
932                  conn query params format))
933               (if (sql-null? obj) #f obj))) params))
934         (send-query
935          (foreign-lambda*
936           bool ((pgconn* conn) (nonnull-c-string query) (bool is_prepped)
937                 (int num) (scheme-object params) (int rfmt))
938           "int res = 0, i = 0, *lens = NULL;"
939           "char **vals = NULL;"
940           "int *fmts = NULL;"
941           "C_word obj, cons;"
942           "if (num > 0) {"
943           "    vals = C_alloca(num * sizeof(char *));"
944           "    lens = C_alloca(num * sizeof(int));"
945           "    fmts = C_alloca(num * sizeof(int));"
946           "    "
947           "    for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
948           "        obj = C_u_i_car(cons);"
949           "        if (obj == C_SCHEME_FALSE) {"
950           "            fmts[i] = 0; /* don't care */"
951           "            lens[i] = 0;"
952           "            vals[i] = NULL;"
953           "        } else if (C_header_bits(obj) == C_BYTEVECTOR_TYPE) {"
954           "            fmts[i] = 1; /* binary */"
955           "            lens[i] = C_header_size(obj);"
956           "            vals[i] = C_c_string(obj);"
957           "        } else {"
958           "            /* text needs to be copied; it expects ASCIIZ */"
959           "            fmts[i] = 0; /* text */"
960           "            lens[i] = C_header_size(obj);"
961           "            vals[i] = C_malloc(lens[i] + 1);"
962           "            memcpy(vals[i], C_c_string(obj), lens[i]);"
963           "            vals[i][lens[i]] = '\\0';"
964           "        }"
965           "    }"
966           "}"
967           "if (is_prepped)"
968           "  res = PQsendQueryPrepared((PGconn *)conn, query, num, "
969           "                            (const char **)vals, lens, fmts, rfmt);"
970           "else"
971           "  res = PQsendQueryParams((PGconn *)conn, query, num, NULL,"
972           "                          (const char **)vals, lens, fmts, rfmt);"
973           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
974           "    obj = C_u_i_car(cons);"
975           "    if (!C_immediatep(obj) && C_header_bits(obj) == C_STRING_TYPE)"
976           "        free(vals[i]); /* Clear copied strings only */"
977           "}"
978           "C_return(res);"))
979         (query-as-string (if (symbol? query) (symbol->string query) query)))
980   (if (send-query (pg-connection-ptr conn) query-as-string (symbol? query)
981                   (length params) params (symbol->format format))
982       (get-last-result conn raw: raw)
983       (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 (blob? data) (string? data)) data)
1057                ((u8vector? data) (u8vector->blob/shared data))
1058                (else (postgresql-error
1059                       'type 'put-copy-data
1060                       "Expected a blob, string or u8vector" conn data))))
1061         (len (if (or (blob? data) (string? data))
1062                  (number-of-bytes data)
1063                  (u8vector-length data)))
1064         (conn-ptr (pg-connection-ptr conn))
1065         (conn-fd (pgsql-connection->fd conn)))
1066    (let loop ((res (PQputCopyData conn-ptr data len)))
1067      (cond
1068       ((= res 0)
1069        (thread-wait-for-i/o! conn-fd #:output)
1070        (loop (PQputCopyData conn-ptr data len)))
1071       ((= res 1) (void))
1072       ((= res -1)
1073        (postgresql-error
1074         'i/o 'put-copy-data
1075         (conc "Error putting COPY data. " (PQerrorMessage conn-ptr)) conn))
1076       (else (postgresql-error
1077              'internal 'put-copy-data
1078              (conc "Internal error! Unexpected return value: " res) conn))))))
1079
1080(define (put-copy-end conn #!optional error-message)
1081  (let ((conn-ptr (pg-connection-ptr conn))
1082        (conn-fd (pgsql-connection->fd conn)))
1083   (let loop ((res (PQputCopyEnd conn-ptr error-message)))
1084     (cond
1085      ((= res 0)
1086       (thread-wait-for-i/o! conn-fd #:output)
1087       (loop (PQputCopyEnd conn-ptr error-message)))
1088      ((= res 1) (get-last-result conn))
1089      ((= res -1)
1090       (postgresql-error
1091        'i/o 'put-copy-end
1092        (conc "Error ending put COPY data. " (PQerrorMessage conn-ptr))
1093        conn error-message))
1094      (else
1095       (postgresql-error
1096        'internal 'put-copy-end
1097        (conc "Internal error! Unexpected return value: " res) conn))))))
1098
1099(define (get-copy-data conn #!key (format 'text))
1100  (let* ((conn-ptr (pg-connection-ptr conn))
1101         (conn-fd (pgsql-connection->fd conn)))
1102    (let loop ()
1103      (let-location ((res int))
1104        (let ((data ((foreign-safe-lambda*
1105                      scheme-object ((pgconn* conn) ((c-pointer int) res)
1106                                     (int format))
1107                      "C_word fin = C_SCHEME_FALSE, *str; char *buf; "
1108                      "*res = PQgetCopyData(conn, &buf, 1); "
1109                      "if (buf != NULL) { /* res is length */ "
1110                      "  str = C_alloc(C_SIZEOF_STRING(*res)); "
1111                      "  fin = C_string(&str, *res, buf); "
1112                      "  if (format == 1) "
1113                      "    C_string_to_bytevector(fin);"
1114                      "  PQfreemem(buf); "
1115                      "} "
1116                      "C_return(fin);")
1117                     conn-ptr (location res) (symbol->format format))))
1118          (cond
1119           ((> res 0) data)
1120           ((= res 0) (thread-wait-for-i/o! conn-fd #:input) (loop))
1121           ((= res -1) (get-last-result conn))
1122           ((= res -2)
1123            (postgresql-error
1124             'i/o 'put-copy-data
1125             (conc "Error getting COPY data. " (PQerrorMessage conn-ptr)) conn))
1126           (else (postgresql-error
1127                  'internal 'get-copy-data
1128                  (conc "Internal error! Unexpected return value: " res)
1129                  conn))))))))
1130
1131;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1132;;;; Value escaping and quotation
1133;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1134
1135(define (escape-string conn str)
1136  (define %escape-string-conn
1137    ;; This could be more efficient by copying straight into a Scheme object.
1138    ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again.
1139    ;; This can allocate up to twice as much memory than the string actually
1140    ;; uses; in extreme cases this could be a problem.
1141    (foreign-lambda* c-string* ((pgconn* conn) (c-string from) (int flen))
1142                     "int err = 0; char *to;"
1143                     "to = malloc(sizeof(char) * (flen * 2 + 1));"
1144                     "PQescapeStringConn((PGconn *)conn, to, from, (size_t)flen, &err);"
1145                     "if (err) {"
1146                     "        free(to);"
1147                     "        C_return(NULL);"
1148                     "}"
1149                     "C_return(to);"))
1150  (or (%escape-string-conn (pg-connection-ptr conn) str (string-length str))
1151      (postgresql-error 'internal 'escape-string
1152                        (conc "String escaping failed. "
1153                              (PQerrorMessage conn)) conn str)))
1154
1155(define (quote-identifier conn str)
1156  (cond-expand
1157   (has-PQescapeIdentifier
1158    (define %escape-ident
1159      (foreign-safe-lambda* scheme-object ((pgconn* conn)
1160                                           (c-string from)
1161                                           (int len))
1162                            "char *to;"
1163                            "C_word res, *fin;"
1164                            "int to_len;"
1165                            "to = PQescapeIdentifier((PGconn *)conn, from, len);"
1166                            "if (to == NULL)"
1167                            "    C_return(C_SCHEME_FALSE);"
1168                            "to_len = strlen(to);"
1169                            "fin = C_alloc(C_SIZEOF_STRING(to_len));"
1170                            "res = C_string(&fin, to_len, to);"
1171                            "PQfreemem(to);"
1172                            "C_return(res);"))
1173    (or (%escape-ident (pg-connection-ptr conn) str (string-length str))
1174        (postgresql-error 'internal 'quote-identifier
1175                          (conc "Identifier escaping failed. "
1176                                (PQerrorMessage conn)) conn str)))
1177   (else (postgresql-error 'unsupported-version 'quote-identifier
1178                           (conc "Please upgrade your PostgreSQL to 9.0 or later "
1179                                 "in order to be able to use quote-identifier!")
1180                           conn str))))
1181
1182(define (escape-bytea conn str)
1183  (define %escape-bytea-conn
1184    ;; This must copy because libpq returns a malloced ptr...
1185    (foreign-safe-lambda* scheme-object ((pgconn* conn)
1186                                         (scheme-pointer from)
1187                                         (int flen))
1188                     "size_t tolen=0; C_word res, *fin; unsigned char *esc;"
1189                     "esc = PQescapeByteaConn((PGconn *)conn, from, (size_t)flen, &tolen);"
1190                     "if (esc == NULL)"
1191                     "    C_return(C_SCHEME_FALSE);"
1192                     "fin = C_alloc(C_SIZEOF_STRING(tolen));"
1193                     "/* tolen includes the resulting NUL byte */"
1194                     "res = C_string(&fin, tolen - 1, (char *)esc);"
1195                     "PQfreemem(esc);"
1196                     "C_return(res);"))
1197  (or (%escape-bytea-conn (pg-connection-ptr conn) str (string-length str))
1198      (postgresql-error 'internal 'escape-bytea
1199                        (conc "Byte array escaping failed. "
1200                              (PQerrorMessage conn)) conn str)))
1201
1202(define (unescape-bytea str)
1203  (define %unescape-bytea
1204    ;; This must copy because libpq returns a malloced ptr...
1205    (foreign-safe-lambda* scheme-object (((const unsigned-c-string*) from))
1206                     "size_t tolen=0; C_word res, *fin; unsigned char *unesc;"
1207                     "unesc = PQunescapeBytea(from, &tolen);"
1208                     "if (unesc == NULL)"
1209                     "    C_return(C_SCHEME_FALSE);"
1210                     "fin = C_alloc(C_SIZEOF_STRING(tolen));"
1211                     "res = C_string(&fin, tolen, (char *)unesc);"
1212                     "PQfreemem(unesc);"
1213                     "C_return(res);"
1214                     ))
1215  (or (%unescape-bytea str)
1216      (postgresql-error 'internal 'unescape-bytea
1217                        "Byte array unescaping failed (out of memory?)" str)))
1218
1219
1220;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1221;;;; High-level interface
1222;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1223
1224(define (make-result-fold item-count extract-item)
1225  (lambda (kons knil result)
1226   (let ((items (item-count result)))
1227     (let loop ((seed knil)
1228                (item 0))
1229       (if (= item items)
1230           seed
1231           (loop (kons (extract-item result item) seed) (add1 item)))))))
1232
1233(define row-fold (make-result-fold row-count row-values))
1234(define (row-fold* kons knil result)
1235  (row-fold (lambda (values seed)
1236              (apply kons (append values (list seed)))) knil result))
1237
1238(define column-fold (make-result-fold column-count column-values))
1239(define (column-fold* kons knil result)
1240  (column-fold (lambda (values seed)
1241                 (apply kons (append values (list seed)))) knil result))
1242
1243
1244(define (make-result-fold-right item-count extract-item)
1245  (lambda (kons knil result)
1246    (let loop ((seed knil)
1247               (item (item-count result)))
1248      (if (= item 0)
1249          seed
1250          (loop (kons (extract-item result (sub1 item)) seed) (sub1 item))))))
1251
1252(define row-fold-right (make-result-fold-right row-count row-values))
1253(define (row-fold-right* kons knil result)
1254  (row-fold-right (lambda (values seed)
1255                    (apply kons (append values (list seed)))) knil result))
1256
1257(define column-fold-right (make-result-fold-right column-count column-values))
1258(define (column-fold-right* kons knil result)
1259  (column-fold-right (lambda (values seed)
1260                       (apply kons (append values (list seed)))) knil result))
1261
1262
1263(define (row-for-each proc result)
1264  (row-fold (lambda (values seed) (proc values)) #f result)
1265  (void))
1266(define (row-for-each* proc result)
1267  (row-fold (lambda (values seed) (apply proc values)) #f result)
1268  (void))
1269
1270(define (column-for-each proc result)
1271  (column-fold (lambda (values seed) (proc values)) #f result)
1272  (void))
1273(define (column-for-each* proc result)
1274  (column-fold (lambda (values seed) (apply proc values)) #f result)
1275  (void))
1276
1277;; Like regular Scheme map, the order in which the procedure is applied is
1278;; undefined.  We make good use of that by traversing the resultset from
1279;; the end back to the beginning, thereby avoiding a reverse! on the result.
1280(define (row-map proc res)
1281  (row-fold-right (lambda (row lst) (cons (proc row) lst)) '() res))
1282(define (row-map* proc res)
1283  (row-fold-right (lambda (row lst) (cons (apply proc row) lst)) '() res))
1284(define (column-map proc res)
1285  (column-fold-right (lambda (col lst) (cons (proc col) lst)) '() res))
1286(define (column-map* proc res)
1287  (column-fold-right (lambda (col lst) (cons (apply proc col) lst)) '() res))
1288
1289(define (result-format result)
1290  (if (and result ((foreign-lambda bool PQbinaryTuples pgresult*)
1291                   (pg-result-ptr result)))
1292     'binary 'text))
1293
1294(define (copy-query*-fold kons knil conn query
1295                          #!optional (params '()) #!key (format 'text) raw)
1296  (let* ((result (query* conn query params format: format raw: raw))
1297         (data-format (result-format result)))
1298    (handle-exceptions exn
1299      (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1300      (let loop ((data (get-copy-data conn format: data-format))
1301                 (seed knil))
1302        (if (result? data)
1303            seed
1304            ;; Explicit ordering; data could be _very_ big, allow one to be GCed
1305            (let ((next (kons data seed)))
1306              (loop (get-copy-data conn format: data-format) next)))))))
1307
1308(define (copy-query-fold kons knil conn query . params)
1309  (copy-query*-fold kons knil conn query params))
1310
1311
1312;; This is slow and memory-intensive if data is big. Provided for completeness
1313(define (copy-query*-fold-right kons knil conn query
1314                                #!optional (params '()) #!key (format 'text) raw)
1315  (let* ((result (query* conn query params format: format raw: raw))
1316         (data-format (result-format result)))
1317    (handle-exceptions exn
1318      (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1319      (let loop ((data (get-copy-data conn format: data-format)))
1320        (if (result? data)
1321            knil
1322            (kons data (loop (get-copy-data conn format: data-format))))))))
1323
1324(define (copy-query-fold-right kons knil conn query . params)
1325  (copy-query*-fold-right kons knil conn query params))
1326
1327
1328(define (copy-query*-map proc conn query
1329                         #!optional (params '()) #!key (format 'text) raw)
1330  (reverse! (copy-query*-fold (lambda (data seed) (cons (proc data) seed))
1331                              '() conn query params format: format raw: raw)))
1332
1333(define (copy-query-map proc conn query . params)
1334  (copy-query*-map proc conn query params))
1335
1336
1337(define (copy-query*-for-each proc conn query
1338                              #!optional (params '()) #!key (format 'text) raw)
1339  (copy-query*-fold (lambda (data seed) (proc data))
1340                    #f conn query params format: format raw: raw)
1341  (void))
1342
1343(define (copy-query-for-each proc conn query . params)
1344  (copy-query*-for-each proc conn query params))
1345
1346;; A bit of a weird name but consistent
1347(define (call-with-output-copy-query*
1348         proc conn query #!optional (params '()) #!key (format 'text) raw)
1349  (query* conn query params format: format raw: raw)
1350  (let* ((closed? #f)
1351         (output-port (make-output-port
1352                       (lambda (data) (put-copy-data conn data))
1353                       (lambda () (put-copy-end conn) (set! closed? #t)))))
1354    (handle-exceptions exn
1355      (if closed?
1356          (raise exn)
1357          (handle-exceptions _
1358            (raise exn)
1359            ;; Previously written data will be discarded to guarantee atomicity
1360            (put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
1361      (call-with-values (lambda () (proc output-port))
1362        (lambda args
1363          (unless closed? (put-copy-end conn))
1364          (apply values args))))))
1365
1366(define (call-with-output-copy-query proc conn query . params)
1367  (call-with-output-copy-query* proc conn query params))
1368
1369(define (with-output-to-copy-query*
1370         thunk conn query #!optional (params '()) #!key (format 'text) raw)
1371  (call-with-output-copy-query* (lambda (x) (with-output-to-port x thunk))
1372                                conn query params format: format raw: raw))
1373
1374(define (with-output-to-copy-query thunk conn query . params)
1375  (with-output-to-copy-query* thunk conn query params))
1376
1377)
Note: See TracBrowser for help on using the repository browser.