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

Last change on this file since 14762 was 14762, checked in by sjamaan, 11 years ago

Fix off-by-one error in result-row-alist

File size: 32.8 KB
Line 
1;;; Bindings to the PostgreSQL C library
2;;
3;; Copyright (C) 2008-2009 Peter Bex
4;; Copyright (C) 2004 Johannes Grødem <johs@copyleft.no>
5;; Redistribution and use in source and binary forms, with or without
6;; modification, is permitted.
7;;
8;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
9;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
10;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
11;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
12;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
13;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
14;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
15;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
16;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
17;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
18;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
19;; DAMAGE.
20
21(module postgresql
22 (update-type-parsers! default-type-parsers
23  char-parser bool-parser bytea-parser numeric-parser
24  update-type-unparsers! default-type-unparsers
25  bool-unparser
26 
27  connect reset-connection disconnect connection?
28 
29  exec-simple-queries exec-query
30 
31  result? clear-result! result-row-count result-column-count
32  result-column-index result-column-name result-column-names
33  result-column-format result-column-type result-column-type-modifier
34  result-table-oid result-table-column-index
35  result-value result-row result-row-alist result-column
36  result-affected-rows result-inserted-oid
37
38  invalid-oid
39 
40  escape-string escape-bytea unescape-bytea
41 
42  query-fold query-fold* query-fold-right query-fold-right*
43  query-for-each query-for-each* query-map query-map*)
44
45(import chicken scheme foreign)
46
47(require-extension srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
48                   extras data-structures sql-null)
49
50(foreign-declare "#include <libpq-fe.h>")
51
52(define-foreign-type pg-polling-status (enum "PostgresPollingStatusType"))
53(define-foreign-variable PGRES_POLLING_FAILED pg-polling-status)
54(define-foreign-variable PGRES_POLLING_READING pg-polling-status)
55(define-foreign-variable PGRES_POLLING_WRITING pg-polling-status)
56(define-foreign-variable PGRES_POLLING_OK pg-polling-status)
57
58(define-foreign-type pg-exec-status (enum "ExecStatusType"))
59(define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status)
60(define-foreign-variable PGRES_COMMAND_OK pg-exec-status)
61(define-foreign-variable PGRES_TUPLES_OK pg-exec-status)
62(define-foreign-variable PGRES_COPY_OUT pg-exec-status)
63(define-foreign-variable PGRES_COPY_IN pg-exec-status)
64(define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status)
65(define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status)
66(define-foreign-variable PGRES_FATAL_ERROR pg-exec-status)
67
68;(define-foreign-type pgconn* (c-pointer "PGconn"))
69(define-foreign-type pgconn* c-pointer)
70
71(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string)))
72(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*))
73(define PQresetStart (foreign-lambda bool PQresetStart pgconn*))
74(define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*))
75(define PQfinish (foreign-lambda void PQfinish pgconn*))
76(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
77(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
78
79;(define-foreign-type oid "Oid")
80(define-foreign-type oid unsigned-int)
81
82(define invalid-oid (foreign-value "InvalidOid" oid))
83
84(define PQisBusy (foreign-lambda bool PQisBusy pgconn*))
85(define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*))
86
87(define-foreign-type pgresult* (c-pointer "PGresult"))
88
89(define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*))
90(define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*)))
91(define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*)))
92(define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int))
93
94(define PQclear (foreign-lambda void PQclear pgresult*))
95(define PQntuples (foreign-lambda int PQntuples (const pgresult*)))
96(define PQnfields (foreign-lambda int PQnfields (const pgresult*)))
97(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int))
98(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string)))
99(define PQftable (foreign-lambda oid PQftable (const pgresult*) int))
100(define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int))
101(define PQfformat (foreign-lambda int PQfformat (const pgresult*) int))
102(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
103(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int))
104(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
105(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
106(define PQoidValue (foreign-lambda oid PQoidValue pgresult*))
107
108;; TODO: Create a real callback system?
109(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }")
110
111(define-syntax define-foreign-int
112  (er-macro-transformer
113   (lambda (e r c)
114     ;; cannot rename define-foreign-variable; it's a really special form
115    `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
116
117(define-foreign-int PG_DIAG_SEVERITY)
118(define-foreign-int PG_DIAG_SQLSTATE)
119(define-foreign-int PG_DIAG_MESSAGE_PRIMARY)
120(define-foreign-int PG_DIAG_MESSAGE_DETAIL)
121(define-foreign-int PG_DIAG_MESSAGE_HINT)
122(define-foreign-int PG_DIAG_STATEMENT_POSITION)
123(define-foreign-int PG_DIAG_CONTEXT)
124(define-foreign-int PG_DIAG_SOURCE_FILE)
125(define-foreign-int PG_DIAG_SOURCE_LINE)
126(define-foreign-int PG_DIAG_SOURCE_FUNCTION)
127
128(define (postgresql-error loc message . args)
129  (signal (make-pg-condition loc message args: args)))
130
131(define (make-pg-condition loc message #!key (args '()) severity
132                           error-class error-code message-detail
133                           message-hint statement-position context
134                           source-file source-line
135                           source-function)
136  (make-composite-condition
137    (make-property-condition
138     'exn 'location loc 'message message 'arguments args)
139    (make-property-condition
140     'postgresql 'severity severity 'error-class error-class
141     'error-code error-code 'message-detail message-detail
142     'message-hint message-hint 'statement-position statement-position
143     'context context 'source-file source-file 'source-line source-line
144     ;; Might break not-terribly-old versions of postgresql
145     ;;'internal-position internal-position 'internal-query internal-query
146     'source-function source-function)))
147
148;;;;;;;;;;;;;;;;;;;;;;;;
149;;;; Type parsers
150;;;;;;;;;;;;;;;;;;;;;;;;
151
152(define (char-parser str) (string-ref str 0))
153
154(define (bool-parser str) (string=? str "t"))
155
156(define (abstime-parser str) str)
157
158(define (reltime-parser str) str)
159
160(define (parse-format-string s)
161  (let-syntax ((push! (syntax-rules ()
162                        ((_ value place)
163                         (set! place (cons value place))))))
164    (do ([i 0 (+ i 1)]
165         [ranges (list)]
166         [cur-range (list)]
167         [len (string-length s)])
168        ([= i len]
169         (when (not (null? cur-range))
170           (push! (cons (- i (length cur-range)) i)
171                  ranges))
172         (reverse! ranges))
173      (let ([char (string-ref s i)])
174        (cond ([and (or (null? cur-range)
175                        (char=? char (car cur-range)))
176                    (char-alphabetic? char)]
177               (push! char cur-range))
178              ([and (not (null? cur-range))
179                    (not (char=? char (car cur-range)))]
180               (push! (cons (- i (length cur-range)) i)
181                      ranges)
182               (set! cur-range
183                     (if (char-alphabetic? char)
184                         (list char)
185                         (list)))))))))
186
187(define-syntax define-time-parser
188  (syntax-rules ()
189    ((_ name format-string)
190     (define name
191       (let ((format-ranges (parse-format-string format-string)))
192         (lambda (str)
193           (apply
194            vector
195            (map (lambda (range)
196                   (if (> (cdr range) (string-length str))
197                       0
198                       (string->number
199                        (substring str (car range) (cdr range)))))
200                 format-ranges))))))))
201
202(define-time-parser date-parser "YYYY-MM-DD")
203(define-time-parser timestamp-parser "YYYY-MM-DD hh:mm:ss.ssssss")
204(define-time-parser timestamp/tz-parser "YYYY-MM-DD hh:mm:ss.sssssszzz")
205(define-time-parser time-parser "hh:mm:ss.ssssss")
206
207(define (numeric-parser str)
208  (or (string->number str)
209      (postgresql-error 'numeric-parser "Unable to parse number" str)))
210
211(define (bytea-parser str)
212  (blob->u8vector/shared (string->blob (unescape-bytea str))))
213
214(define default-type-parsers
215  (make-parameter
216   `(("text" . ,identity)
217     ("bytea" . ,bytea-parser)
218     ("char" . ,char-parser)
219     ("bpchar" . ,identity)
220     ("bool" . ,bool-parser)
221     ("int8" . ,numeric-parser)
222     ("int4" . ,numeric-parser)
223     ("int2" . ,numeric-parser)
224     ("float4" . ,numeric-parser)
225     ("float8" . ,numeric-parser)
226     ("abstime" . ,abstime-parser)
227     ("reltime" . ,reltime-parser)
228     ("date" . ,date-parser)
229     ("time" . ,time-parser)
230     ("timestamp" . ,timestamp-parser)
231     ("timestamptz" . ,timestamp/tz-parser)
232     ("numeric" . ,numeric-parser)
233     ("oid" . ,numeric-parser))))
234
235;;;;;;;;;;;;;;;;;;;;;;;
236;;;; Type unparsers
237;;;;;;;;;;;;;;;;;;;;;;;
238
239(define (bool-unparser b)
240  (if b "TRUE" "FALSE"))
241
242(define default-type-unparsers
243  (make-parameter
244   `((,string? . ,identity)
245     (,u8vector? . ,u8vector->blob/shared)
246     (,char? . ,string)
247     (,boolean? . ,bool-unparser)
248     (,number? . ,number->string)
249     #;(,vector? . ,vector-unparser))))
250
251;; Retrieve type-oids from PostgreSQL:
252(define (update-type-parsers! conn #!optional new-type-parsers)
253  (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
254        (ht (make-hash-table))
255        (result '()))
256    ;; Set the parsers now, so that we will be retrieving raw data
257    (pg-connection-oid-parsers-set! conn ht)
258    (pg-connection-type-parsers-set! conn type-parsers)
259    (unless (null? type-parsers)   ; empty IN () clause is not allowed
260      (query-for-each*
261       (lambda (oid typname)
262         (and-let* ((procedure (assoc typname type-parsers)))
263           (hash-table-set! ht (string->number oid) (cdr procedure))))
264       conn
265       (conc "SELECT oid, typname FROM pg_type WHERE typname IN "
266             "('" (string-intersperse
267                   (map (lambda (p) (escape-string conn (car p)))
268                        type-parsers) "', '") "')")))))
269
270(define (update-type-unparsers! conn new-type-unparsers)
271  (pg-connection-type-unparsers-set! conn new-type-unparsers))
272
273;;;;;;;;;;;;;;;;;;;;
274;;;; Connections
275;;;;;;;;;;;;;;;;;;;;
276
277(define-record pg-connection ptr type-parsers oid-parsers type-unparsers)
278(define connection? pg-connection?)
279
280(define (pgsql-connection->fd conn)
281  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
282
283;; TODO: Add timeout code
284(define (wait-for-connection! conn poll-function)
285  (let ((conn-fd (pgsql-connection->fd conn))
286        (conn-ptr (pg-connection-ptr conn)))
287    (let loop ((result (poll-function conn-ptr)))
288      (cond ((= result PGRES_POLLING_OK) (void))
289            ((= result PGRES_POLLING_FAILED)
290             (let ((error-message (PQerrorMessage conn-ptr)))
291               (disconnect conn)
292               (postgresql-error 'connect
293                                 (conc "Polling Postgres database failed. "
294                                       error-message))))
295            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
296             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
297                                               #:output
298                                               #:input))
299             (loop (poll-function conn-ptr)))
300            (else
301             (postgresql-error 'connect (conc "Unknown status code!")))))))
302
303(define (alist->connection-spec alist)
304  (string-join
305   (map (lambda (subspec)
306          (sprintf "~A='~A'"
307                   (car subspec) ;; this had better not contain [ =\']
308                   (string-translate* (->string (cdr subspec))
309                                      '(("\\" . "\\\\") ("'" . "\\'")))))
310        alist)))
311
312(define (connect connection-spec
313                 #!optional
314                 (type-parsers (default-type-parsers))
315                 (type-unparsers (default-type-unparsers)))
316  (let* ((connection-spec (if (string? connection-spec)
317                              connection-spec
318                              (alist->connection-spec connection-spec)))
319         (conn-ptr (PQconnectStart connection-spec)))
320    (cond
321     ((not conn-ptr)
322      (postgresql-error 'connect
323                        "Unable to allocate a Postgres connection structure."
324                        connection-spec))
325     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
326      (let ((error-message (PQerrorMessage conn-ptr)))
327        (PQfinish conn-ptr)
328        (postgresql-error 'connect
329                          (conc "Connection to Postgres database failed: "
330                                error-message)
331                          connection-spec)))
332     (else
333      (let ((conn (make-pg-connection conn-ptr type-parsers
334                                      (make-hash-table) type-unparsers)))
335        ;; We don't want libpq to piss in our stderr stream
336        ((foreign-lambda* void ((pgconn* conn))
337          "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
338        (wait-for-connection! conn PQconnectPoll)
339        (set-finalizer! conn disconnect)
340        ;; Retrieve type-information from PostgreSQL metadata for use by
341        ;; the various value-parsers.
342        (update-type-parsers! conn)
343        conn)))))
344
345(define (reset-connection connection)
346  (let ((conn-ptr (pg-connection-ptr connection)))
347    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
348        (wait-for-connection! connection PQresetPoll)
349        (let ((error-message (PQerrorMessage conn-ptr)))
350          (disconnect connection)
351          (postgresql-error 'reset-connection
352                            (conc "Reset of connection failed " error-message)
353                            connection)))))
354
355(define (disconnect connection)
356  (and-let* ((conn-ptr (pg-connection-ptr connection)))
357    (pg-connection-ptr-set! connection #f)
358    (pg-connection-type-parsers-set! connection #f)
359    (pg-connection-oid-parsers-set! connection #f)
360    (PQfinish conn-ptr))
361  (void))
362
363;;;;;;;;;;;;;;;
364;;;; Results
365;;;;;;;;;;;;;;;
366
367(define-record pg-result ptr value-parsers)
368(define result? pg-result?)
369
370(define (clear-result! result)
371  (and-let* ((result-ptr (pg-result-ptr result)))
372    (pg-result-ptr-set! result #f)
373    (PQclear result-ptr)))
374
375(define (result-row-count result)
376  (PQntuples (pg-result-ptr result)))
377
378(define (result-column-count result)
379  (PQnfields (pg-result-ptr result)))
380
381;; Helper procedures for bounds checking; so we can distinguish between
382;; out of bounds and nonexistant columns, and signal it.
383(define (check-result-column-index! result index location)
384  (when (>= index (result-column-count result))
385    (postgresql-error
386     location (sprintf "Result column ~A out of bounds" index) result index)))
387
388(define (check-result-row-index! result index location)
389  (when (>= index (result-row-count result))
390    (postgresql-error
391     location (sprintf "Result row ~A out of bounds" index) result index)))
392
393(define (result-column-name result index)
394  (check-result-column-index! result index 'result-column)
395  (string->symbol (PQfname (pg-result-ptr result) index)))
396
397(define (result-column-names result)
398  (let loop ((ptr (pg-result-ptr result))
399             (row '())
400             (idx (result-column-count result)))
401    (if (= idx 0)
402        row
403        (loop ptr (cons (string->symbol
404                         (PQfname ptr (sub1 idx))) row) (sub1 idx)))))
405
406(define (result-column-index result name)
407  (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
408    (and (>= idx 0) idx)))
409
410(define (result-table-oid result index)
411  (check-result-column-index! result index 'result-table-oid)
412  (let ((oid (PQftable (pg-result-ptr result) index)))
413    (and (not (= oid invalid-oid)) oid)))
414
415;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
416;; consistent with the rest of Scheme.  However, this is inconsistent with
417;; almost all other PostgreSQL interfaces...
418(define (result-table-column-index result index)
419  (check-result-column-index! result index 'result-table-column-index)
420  (let ((idx (PQftablecol (pg-result-ptr result) index)))
421    (and (> idx 0) (sub1 idx))))
422
423(define format-table
424  '((0 . text) (1 . binary)))
425
426(define (format->symbol format)
427  (or (alist-ref format format-table eq?)
428      (postgresql-error 'format->symbol "Unknown format" format)))
429
430(define (symbol->format symbol)
431  (or (and-let* ((res (rassoc symbol format-table eq?)))
432        (car res))
433      (postgresql-error 'format->symbol "Unknown format" symbol)))
434
435(define (result-column-format result index)
436  (check-result-column-index! result index 'result-column-format)
437  (format->symbol (PQfformat (pg-result-ptr result) index)))
438
439(define (result-column-type result index)
440  (check-result-column-index! result index 'result-column-type)
441  (PQftype (pg-result-ptr result) index))
442
443;; This is really not super-useful as it requires intimate knowledge
444;; about the internal implementations of types in PostgreSQL.
445(define (result-column-type-modifier result index)
446  (check-result-column-index! result index 'result-column-type)
447  (let ((mod (PQfmod (pg-result-ptr result) index)))
448    (and (>= mod 0) mod)))
449
450;; Unchecked version, for speed
451(define (result-value* result row column #!key raw)
452  (if (PQgetisnull (pg-result-ptr result) row column)
453      (sql-null)
454      (let ((value ((foreign-safe-lambda*
455                     scheme-object ((c-pointer res) (int row) (int col))
456                     "C_word fin, *str; char *val; int len;"
457                     "len = PQgetlength(res, row, col);"
458                     "str = C_alloc(C_bytestowords(len + sizeof(C_header)));"
459                     "val = PQgetvalue(res, row, col);"
460                     "fin = C_string(&str, len, val);"
461                     "if (PQfformat(res, col) == 1) /* binary? */"
462                     "        C_string_to_bytevector(fin);"
463                     "C_return(fin);")
464                    (pg-result-ptr result) row column)))
465        (if (or raw (blob? value))
466            value
467            ((vector-ref (pg-result-value-parsers result) column) value)))))
468
469(define (result-value result row column #!key raw)
470  (check-result-row-index! result row 'result-value)
471  (check-result-column-index! result column 'result-value)
472  (result-value* result row column raw: raw))
473
474(define (result-row result row #!key raw)
475  (check-result-row-index! result row 'result-list)
476  (let loop ((list '())
477             (column (result-column-count result)))
478    (if (= column 0)
479        list
480        (loop (cons (result-value* result row (sub1 column) raw: raw) list)
481              (sub1 column)))))
482
483(define (result-column result column #!key raw)
484  (check-result-column-index! result column 'result-list)
485  (let loop ((list '())
486             (row (result-row-count result)))
487    (if (= row 0)
488        list
489        (loop (cons (result-value* result (sub1 row) column raw: raw) list)
490              (sub1 row)))))
491
492;; (define (result-row-alist result row)
493;;   (map cons (result-column-names result) (result-row result row)))
494(define (result-row-alist result row)
495  (check-result-row-index! result row 'result-alist)
496  (let loop ((alist '())
497             (column (result-column-count result)))
498    (if (= column 0)
499        alist
500        (loop (cons (cons (string->symbol
501                           (PQfname (pg-result-ptr result) (sub1 column)))
502                          (result-value* result row (sub1 column))) alist)
503              (sub1 column)))))
504
505;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
506
507(define (result-affected-rows result)
508  (string->number (PQcmdTuples (pg-result-ptr result))))
509
510(define (result-inserted-oid result)
511  (let ((oid (PQoidValue (pg-result-ptr result))))
512    (and (not (= oid invalid-oid)) oid)))
513
514
515;;;;;;;;;;;;;;;;;;;;;;;;
516;;;; Query procedures
517;;;;;;;;;;;;;;;;;;;;;;;;
518
519;; Buffer all available input, yielding if nothing is available:
520(define (buffer-available-input! conn)
521  (let ((conn-ptr (pg-connection-ptr conn))
522        (conn-fd (pgsql-connection->fd conn)))
523    (let loop ()
524      (if (PQconsumeInput conn-ptr)
525          (when (PQisBusy conn-ptr)
526            (thread-wait-for-i/o! conn-fd #:input)
527            (loop))
528          (postgresql-error 'buffer-available-input!
529                            (conc "Error reading reply from server. "
530                                  (PQerrorMessage conn-ptr))
531                            conn-ptr)))))
532
533(define (make-value-parsers conn pqresult)
534  (let ((nfields (PQnfields pqresult)))
535    (do ([col 0 (+ col 1)]
536         [parsers (make-vector nfields)])
537        ([= col nfields] parsers)
538      (vector-set! parsers col
539                   (hash-table-ref (pg-connection-oid-parsers conn)
540                                   (PQftype pqresult col)
541                                   (lambda () identity))))))
542
543;; Collect the result pointers from the last query.
544;;
545;; A pgresult represents an entire resultset and is always read into memory
546;; all at once.
547(define (collect-results conn)
548  (buffer-available-input! conn)
549  (let loop ((results (list)))
550    (let* ((conn-ptr (pg-connection-ptr conn))
551           (result (PQgetResult conn-ptr)))
552      (if result
553          (cond
554           ((member (PQresultStatus result) (list PGRES_BAD_RESPONSE
555                                                  PGRES_FATAL_ERROR))
556            (let* ((get-error-field (lambda (d) (PQresultErrorField result d)))
557                   (sqlstate (get-error-field PG_DIAG_SQLSTATE))
558                   (maybe-severity (get-error-field PG_DIAG_SEVERITY))
559                   (maybe-statement-position
560                    (get-error-field PG_DIAG_STATEMENT_POSITION))
561                   (condition
562                    (make-pg-condition
563                     'collect-results
564                     (PQresultErrorMessage result)
565                     severity:           (and maybe-severity
566                                              (string->symbol
567                                               (string-downcase maybe-severity)))
568                     error-class:        (and sqlstate (string-take sqlstate 2))
569                     error-code:         sqlstate
570                     message-detail:     (get-error-field PG_DIAG_MESSAGE_DETAIL)
571                     message-hint:       (get-error-field PG_DIAG_MESSAGE_HINT)
572                     statement-position: (and maybe-statement-position
573                                              (string->number
574                                               maybe-statement-position))
575                     context:            (get-error-field PG_DIAG_CONTEXT)
576                     source-file:        (get-error-field PG_DIAG_SOURCE_FILE)
577                     source-line:        (get-error-field PG_DIAG_SOURCE_LINE)
578                     source-function:    (get-error-field PG_DIAG_SOURCE_FUNCTION))))
579              ;; Read out all remaining results (including the current one).
580              ;; TODO: Is this really needed? libpq does it (in pqExecFinish),
581              ;; but ostensibly only to concatenate the error messages for
582              ;; each query.  OTOH, maybe we want to do that, too.
583              (let clean-results! ((result result))
584                (when result
585                  (PQclear result)
586                  (clean-results! (PQgetResult (pg-connection-ptr conn)))))
587              (signal condition)))
588           (else
589            (let ((result-obj (make-pg-result result
590                                              (make-value-parsers conn result))))
591              (set-finalizer! result-obj clear-result!)
592              (loop (cons result-obj results)))))
593          (reverse! results)))))
594
595(define (exec-simple-queries conn query)
596  (if ((foreign-lambda bool PQsendQuery pgconn* (const c-string))
597       (pg-connection-ptr conn) query)
598      (collect-results conn)
599      (postgresql-error 'exec-simple-queries
600                        (conc "Unable to send query to server. "
601                              (PQerrorMessage (pg-connection-ptr conn)))
602                        conn query)))
603
604(define (exec-query conn query #!optional (params '()) #!key (format 'text) raw)
605  (let* ((unparsers (pg-connection-type-unparsers conn))
606         (unparse (lambda (x)
607                    (cond ((find (lambda (parse?)
608                                   ((car parse?) x))
609                                 unparsers) => (lambda (parse)
610                                                 ((cdr parse) x)))
611                          (else x))))
612         (params ;; Check all params and ensure they are proper pairs
613          (map   ;; See if this can be moved into C
614           (lambda (p)
615             (let ((obj (if raw p (unparse p))))
616               (when (and (not (string? obj))
617                          (not (blob? obj))
618                          (not (sql-null? obj)))
619                 (postgresql-error
620                  'exec-query
621                  (sprintf "Param value is not a string, sql-null or blob: ~S" p)
622                  conn query params format))
623               (if (sql-null? obj) #f obj))) params))
624         (send-query
625          (foreign-lambda*
626           bool ((pgconn* conn) (nonnull-c-string query)
627                 (int num) (scheme-object params) (int resfmt))
628           "int res = 0, i = 0, *lens = NULL;"
629           "char **vals = NULL;"
630           "int *fmts = NULL;"
631           "C_word obj, cons;"
632           "if (num > 0) {"
633           "    vals = C_malloc(num * sizeof(char *));"
634           "    lens = C_malloc(num * sizeof(int));"
635           "    fmts = C_malloc(num * sizeof(int));"
636           "}"
637           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
638           "    obj = C_u_i_car(cons);"
639           "    if (obj == C_SCHEME_FALSE) {"
640           "        fmts[i] = 0; /* don't care */"
641           "        lens[i] = 0;"
642           "        vals[i] = NULL;"
643           "    } else if (C_header_bits(obj) == C_BYTEVECTOR_TYPE) {"
644           "        fmts[i] = 1; /* binary */"
645           "        lens[i] = C_header_size(obj);"
646           "        vals[i] = C_c_string(obj);"
647           "    } else {"
648           "        /* text needs to be copied; it expects ASCIIZ */"
649           "        fmts[i] = 0; /* text */"
650           "        lens[i] = C_header_size(obj);"
651           "        vals[i] = malloc(lens[i] + 1);"
652           "        memcpy(vals[i], C_c_string(obj), lens[i]);"
653           "        vals[i][lens[i]] = '\\0';"
654           "    }"
655           "}"
656           "res = PQsendQueryParams(conn, query, num, NULL,"
657           "                        vals, lens, fmts, resfmt);"
658           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
659           "    obj = C_u_i_car(cons);"
660           "    if (!C_immediatep(obj) && C_header_bits(obj) == C_STRING_TYPE)"
661           "        free(vals[i]); /* Clear copied strings only */"
662           "}"
663           "if (num > 0) {"
664           "    free(fmts);"
665           "    free(lens);"
666           "    free(vals);"
667           "}"
668           "C_return(res);")))
669   (if (send-query (pg-connection-ptr conn) query
670                   (length params) params (symbol->format format))
671       (car (collect-results conn)) ;; assumed to always return one result...
672       (postgresql-error 'exec-query
673                         (conc "Unable to send query to server. "
674                               (PQerrorMessage (pg-connection-ptr conn)))
675                         conn query params format))))
676
677;;;;;;;;;;;;;;;;;;;;;;
678;;;; Value escaping
679;;;;;;;;;;;;;;;;;;;;;;
680
681(define (escape-string conn str)
682  (define %escape-string-conn
683    ;; This could be more efficient by copying straight into a Scheme object.
684    ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again.
685    ;; This can allocate up to twice as much memory than the string actually
686    ;; uses; in extreme cases this could be a problem.
687    (foreign-lambda* c-string* ((pointer conn) (c-string from) (int fromlen))
688                     "int err = 0; char *to;"
689                     "to = malloc(sizeof(char) * (fromlen * 2 + 1));"
690                     "PQescapeStringConn(conn, to, from, fromlen, &err);"
691                     "if (err) {"
692                     "        free(to);"
693                     "        C_return(NULL);"
694                     "}"
695                     "C_return(to);"))
696  (or (%escape-string-conn conn str (string-length str))
697      (postgresql-error 'escape-string
698                        (conc "String escaping failed. "
699                              (PQerrorMessage conn)) conn str)))
700
701(define (escape-bytea conn str)
702  (define %escape-bytea-conn
703    ;; This must copy because libpq returns a malloced ptr...
704    (foreign-safe-lambda* scheme-object ((pointer conn)
705                                         ;; not copied/NUL interpreted:
706                                         ((const unsigned-c-string*) from)
707                                         (int fromlen))
708                     "size_t tolen=0; C_word res, *fin; unsigned char *esc;"
709                     "esc = PQescapeByteaConn(conn, from, (size_t)fromlen, &tolen);"
710                     "if (esc == NULL)"
711                     "        C_return(C_SCHEME_FALSE);"
712                     "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
713                     "/* tolen includes the resulting NUL byte */"
714                     "res = C_string(&fin, tolen - 1, (char *)esc);"
715                     "PQfreemem(esc);"
716                     "C_return(res);"))
717  (or (%escape-bytea-conn conn str (string-length str))
718      (postgresql-error 'escape-bytea
719                        (conc "Byte array escaping failed. "
720                              (PQerrorMessage conn)) conn str)))
721
722(define (unescape-bytea str)
723  (define %unescape-bytea
724    ;; This must copy because libpq returns a malloced ptr...
725    (foreign-safe-lambda* scheme-object (((const unsigned-c-string*) from))
726                     "size_t tolen=0; C_word res, *fin; unsigned char *unesc;"
727                     "unesc = PQunescapeBytea(from, &tolen);"
728                     "if (unesc == NULL)"
729                     "        C_return(C_SCHEME_FALSE);"
730                     "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
731                     "res = C_string(&fin, tolen, (char *)unesc);"
732                     "PQfreemem(unesc);"
733                     "C_return(res);"
734                     ))
735  (or (%unescape-bytea str)
736      (postgresql-error 'unescape-bytea
737                        "Byte array unescaping failed (out of memory?)" str)))
738
739
740;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
741;;;; High-level interface
742;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
743
744(define (%query-fold kons knil conn query params)
745  (let* ((result (exec-query conn query params))
746         (rows (result-row-count result)))
747    (let loop ((seed knil)
748               (row 0))
749      (if (= row rows)
750          seed
751          (loop (kons (result-row result row) seed) (add1 row))))))
752
753(define (%query-fold-right kons knil conn query params)
754  (let* ((result (exec-query conn query params))
755         (rows (result-row-count result)))
756    (let loop ((seed knil)
757               (row 0))
758      (if (= row rows)
759          seed
760          (kons (result-row result row) (loop seed (add1 row)))))))
761
762(define (query-fold kons knil conn query . params)
763  (%query-fold kons knil conn query params))
764(define (query-fold* kons knil conn query . params)
765  (%query-fold (lambda (values seed) (apply kons (append values (list seed))))
766               knil conn query params))
767(define (query-fold-right kons knil conn query . params)
768  (%query-fold-right kons knil conn query params))
769(define (query-fold-right* kons knil conn query . params)
770  (%query-fold-right (lambda (val seed) (apply kons (append val (list seed))))
771                     knil conn query params))
772
773(define (query-for-each proc conn query . params)
774  (%query-fold (lambda (values seed) (proc values)) #f conn query params)
775  (void))
776
777(define (query-for-each* proc conn query . params)
778  (%query-fold (lambda (values seed) (apply proc values)) #f conn query params)
779  (void))
780
781;; Like regular Scheme map, the order in which the procedure is applied is
782;; undefined.  We make good use of that by traversing the resultset from
783;; the end back to the beginning, thereby avoiding a reverse! on the result.
784(define (%query-map proc conn query params)
785  (let ((result (exec-query conn query params)))
786    (let loop ((ans '())
787               (row (result-row-count result)))
788      (if (= row 0)
789          ans
790          (loop (cons (proc (result-row result (sub1 row))) ans) (sub1 row))))))
791(define (query-map proc conn query . params)
792  (%query-map proc conn query params))
793
794(define (query-map* proc conn query . params)
795  (%query-map (lambda (values seed) (apply proc values)) conn query params))
796
797)
Note: See TracBrowser for help on using the repository browser.