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

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

Get rid of time parsing procedures -- at least for now.
The problem with datetime is that output is highly dependent on the DateStyle? setting in postgresql.conf. We need to find out a way to obtain that setting or we cannot reliably parse the output of date types.
Another problem is the vector representation; nothing in Chicken can handle date vectors that are not 10 elements long, so it's pretty useless. srfi-18 is still not ported to Chicken 4 either...
Then there's the unparsing of vectors; do you simply unparse every vector to a datetime? Which date type is determined by the vector's length? ugh!

File size: 30.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 (numeric-parser str)
157  (or (string->number str)
158      (postgresql-error 'numeric-parser "Unable to parse number" str)))
159
160(define (bytea-parser str)
161  (blob->u8vector/shared (string->blob (unescape-bytea str))))
162
163(define default-type-parsers
164  (make-parameter
165   `(("text" . ,identity)
166     ("bytea" . ,bytea-parser)
167     ("char" . ,char-parser)
168     ("bpchar" . ,identity)
169     ("bool" . ,bool-parser)
170     ("int8" . ,numeric-parser)
171     ("int4" . ,numeric-parser)
172     ("int2" . ,numeric-parser)
173     ("float4" . ,numeric-parser)
174     ("float8" . ,numeric-parser)
175     ("numeric" . ,numeric-parser)
176     ("oid" . ,numeric-parser))))
177
178;;;;;;;;;;;;;;;;;;;;;;;
179;;;; Type unparsers
180;;;;;;;;;;;;;;;;;;;;;;;
181
182(define (bool-unparser b)
183  (if b "TRUE" "FALSE"))
184
185(define default-type-unparsers
186  (make-parameter
187   `((,string? . ,identity)
188     (,u8vector? . ,u8vector->blob/shared)
189     (,char? . ,string)
190     (,boolean? . ,bool-unparser)
191     (,number? . ,number->string))))
192
193;; Retrieve type-oids from PostgreSQL:
194(define (update-type-parsers! conn #!optional new-type-parsers)
195  (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
196        (ht (make-hash-table))
197        (result '()))
198    ;; Set the parsers now, so that we will be retrieving raw data
199    (pg-connection-oid-parsers-set! conn ht)
200    (pg-connection-type-parsers-set! conn type-parsers)
201    (unless (null? type-parsers)   ; empty IN () clause is not allowed
202      (query-for-each*
203       (lambda (oid typname)
204         (and-let* ((procedure (assoc typname type-parsers)))
205           (hash-table-set! ht (string->number oid) (cdr procedure))))
206       conn
207       (conc "SELECT oid, typname FROM pg_type WHERE typname IN "
208             "('" (string-intersperse
209                   (map (lambda (p) (escape-string conn (car p)))
210                        type-parsers) "', '") "')")))))
211
212(define (update-type-unparsers! conn new-type-unparsers)
213  (pg-connection-type-unparsers-set! conn new-type-unparsers))
214
215;;;;;;;;;;;;;;;;;;;;
216;;;; Connections
217;;;;;;;;;;;;;;;;;;;;
218
219(define-record pg-connection ptr type-parsers oid-parsers type-unparsers)
220(define connection? pg-connection?)
221
222(define (pgsql-connection->fd conn)
223  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
224
225;; TODO: Add timeout code
226(define (wait-for-connection! conn poll-function)
227  (let ((conn-fd (pgsql-connection->fd conn))
228        (conn-ptr (pg-connection-ptr conn)))
229    (let loop ((result (poll-function conn-ptr)))
230      (cond ((= result PGRES_POLLING_OK) (void))
231            ((= result PGRES_POLLING_FAILED)
232             (let ((error-message (PQerrorMessage conn-ptr)))
233               (disconnect conn)
234               (postgresql-error 'connect
235                                 (conc "Polling Postgres database failed. "
236                                       error-message))))
237            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
238             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
239                                               #:output
240                                               #:input))
241             (loop (poll-function conn-ptr)))
242            (else
243             (postgresql-error 'connect (conc "Unknown status code!")))))))
244
245(define (alist->connection-spec alist)
246  (string-join
247   (map (lambda (subspec)
248          (sprintf "~A='~A'"
249                   (car subspec) ;; this had better not contain [ =\']
250                   (string-translate* (->string (cdr subspec))
251                                      '(("\\" . "\\\\") ("'" . "\\'")))))
252        alist)))
253
254(define (connect connection-spec
255                 #!optional
256                 (type-parsers (default-type-parsers))
257                 (type-unparsers (default-type-unparsers)))
258  (let* ((connection-spec (if (string? connection-spec)
259                              connection-spec
260                              (alist->connection-spec connection-spec)))
261         (conn-ptr (PQconnectStart connection-spec)))
262    (cond
263     ((not conn-ptr)
264      (postgresql-error 'connect
265                        "Unable to allocate a Postgres connection structure."
266                        connection-spec))
267     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
268      (let ((error-message (PQerrorMessage conn-ptr)))
269        (PQfinish conn-ptr)
270        (postgresql-error 'connect
271                          (conc "Connection to Postgres database failed: "
272                                error-message)
273                          connection-spec)))
274     (else
275      (let ((conn (make-pg-connection conn-ptr type-parsers
276                                      (make-hash-table) type-unparsers)))
277        ;; We don't want libpq to piss in our stderr stream
278        ((foreign-lambda* void ((pgconn* conn))
279          "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
280        (wait-for-connection! conn PQconnectPoll)
281        (set-finalizer! conn disconnect)
282        ;; Retrieve type-information from PostgreSQL metadata for use by
283        ;; the various value-parsers.
284        (update-type-parsers! conn)
285        conn)))))
286
287(define (reset-connection connection)
288  (let ((conn-ptr (pg-connection-ptr connection)))
289    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
290        (wait-for-connection! connection PQresetPoll)
291        (let ((error-message (PQerrorMessage conn-ptr)))
292          (disconnect connection)
293          (postgresql-error 'reset-connection
294                            (conc "Reset of connection failed " error-message)
295                            connection)))))
296
297(define (disconnect connection)
298  (and-let* ((conn-ptr (pg-connection-ptr connection)))
299    (pg-connection-ptr-set! connection #f)
300    (pg-connection-type-parsers-set! connection #f)
301    (pg-connection-oid-parsers-set! connection #f)
302    (PQfinish conn-ptr))
303  (void))
304
305;;;;;;;;;;;;;;;
306;;;; Results
307;;;;;;;;;;;;;;;
308
309(define-record pg-result ptr value-parsers)
310(define result? pg-result?)
311
312(define (clear-result! result)
313  (and-let* ((result-ptr (pg-result-ptr result)))
314    (pg-result-ptr-set! result #f)
315    (PQclear result-ptr)))
316
317(define (result-row-count result)
318  (PQntuples (pg-result-ptr result)))
319
320(define (result-column-count result)
321  (PQnfields (pg-result-ptr result)))
322
323;; Helper procedures for bounds checking; so we can distinguish between
324;; out of bounds and nonexistant columns, and signal it.
325(define (check-result-column-index! result index location)
326  (when (>= index (result-column-count result))
327    (postgresql-error
328     location (sprintf "Result column ~A out of bounds" index) result index)))
329
330(define (check-result-row-index! result index location)
331  (when (>= index (result-row-count result))
332    (postgresql-error
333     location (sprintf "Result row ~A out of bounds" index) result index)))
334
335(define (result-column-name result index)
336  (check-result-column-index! result index 'result-column)
337  (string->symbol (PQfname (pg-result-ptr result) index)))
338
339(define (result-column-names result)
340  (let loop ((ptr (pg-result-ptr result))
341             (row '())
342             (idx (result-column-count result)))
343    (if (= idx 0)
344        row
345        (loop ptr (cons (string->symbol
346                         (PQfname ptr (sub1 idx))) row) (sub1 idx)))))
347
348(define (result-column-index result name)
349  (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
350    (and (>= idx 0) idx)))
351
352(define (result-table-oid result index)
353  (check-result-column-index! result index 'result-table-oid)
354  (let ((oid (PQftable (pg-result-ptr result) index)))
355    (and (not (= oid invalid-oid)) oid)))
356
357;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
358;; consistent with the rest of Scheme.  However, this is inconsistent with
359;; almost all other PostgreSQL interfaces...
360(define (result-table-column-index result index)
361  (check-result-column-index! result index 'result-table-column-index)
362  (let ((idx (PQftablecol (pg-result-ptr result) index)))
363    (and (> idx 0) (sub1 idx))))
364
365(define format-table
366  '((0 . text) (1 . binary)))
367
368(define (format->symbol format)
369  (or (alist-ref format format-table eq?)
370      (postgresql-error 'format->symbol "Unknown format" format)))
371
372(define (symbol->format symbol)
373  (or (and-let* ((res (rassoc symbol format-table eq?)))
374        (car res))
375      (postgresql-error 'format->symbol "Unknown format" symbol)))
376
377(define (result-column-format result index)
378  (check-result-column-index! result index 'result-column-format)
379  (format->symbol (PQfformat (pg-result-ptr result) index)))
380
381(define (result-column-type result index)
382  (check-result-column-index! result index 'result-column-type)
383  (PQftype (pg-result-ptr result) index))
384
385;; This is really not super-useful as it requires intimate knowledge
386;; about the internal implementations of types in PostgreSQL.
387(define (result-column-type-modifier result index)
388  (check-result-column-index! result index 'result-column-type)
389  (let ((mod (PQfmod (pg-result-ptr result) index)))
390    (and (>= mod 0) mod)))
391
392;; Unchecked version, for speed
393(define (result-value* result row column #!key raw)
394  (if (PQgetisnull (pg-result-ptr result) row column)
395      (sql-null)
396      (let ((value ((foreign-safe-lambda*
397                     scheme-object ((c-pointer res) (int row) (int col))
398                     "C_word fin, *str; char *val; int len;"
399                     "len = PQgetlength(res, row, col);"
400                     "str = C_alloc(C_bytestowords(len + sizeof(C_header)));"
401                     "val = PQgetvalue(res, row, col);"
402                     "fin = C_string(&str, len, val);"
403                     "if (PQfformat(res, col) == 1) /* binary? */"
404                     "        C_string_to_bytevector(fin);"
405                     "C_return(fin);")
406                    (pg-result-ptr result) row column)))
407        (if (or raw (blob? value))
408            value
409            ((vector-ref (pg-result-value-parsers result) column) value)))))
410
411(define (result-value result row column #!key raw)
412  (check-result-row-index! result row 'result-value)
413  (check-result-column-index! result column 'result-value)
414  (result-value* result row column raw: raw))
415
416(define (result-row result row #!key raw)
417  (check-result-row-index! result row 'result-list)
418  (let loop ((list '())
419             (column (result-column-count result)))
420    (if (= column 0)
421        list
422        (loop (cons (result-value* result row (sub1 column) raw: raw) list)
423              (sub1 column)))))
424
425(define (result-column result column #!key raw)
426  (check-result-column-index! result column 'result-list)
427  (let loop ((list '())
428             (row (result-row-count result)))
429    (if (= row 0)
430        list
431        (loop (cons (result-value* result (sub1 row) column raw: raw) list)
432              (sub1 row)))))
433
434;; (define (result-row-alist result row)
435;;   (map cons (result-column-names result) (result-row result row)))
436(define (result-row-alist result row)
437  (check-result-row-index! result row 'result-alist)
438  (let loop ((alist '())
439             (column (result-column-count result)))
440    (if (= column 0)
441        alist
442        (loop (cons (cons (string->symbol
443                           (PQfname (pg-result-ptr result) (sub1 column)))
444                          (result-value* result row (sub1 column))) alist)
445              (sub1 column)))))
446
447;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
448
449(define (result-affected-rows result)
450  (string->number (PQcmdTuples (pg-result-ptr result))))
451
452(define (result-inserted-oid result)
453  (let ((oid (PQoidValue (pg-result-ptr result))))
454    (and (not (= oid invalid-oid)) oid)))
455
456
457;;;;;;;;;;;;;;;;;;;;;;;;
458;;;; Query procedures
459;;;;;;;;;;;;;;;;;;;;;;;;
460
461;; Buffer all available input, yielding if nothing is available:
462(define (buffer-available-input! conn)
463  (let ((conn-ptr (pg-connection-ptr conn))
464        (conn-fd (pgsql-connection->fd conn)))
465    (let loop ()
466      (if (PQconsumeInput conn-ptr)
467          (when (PQisBusy conn-ptr)
468            (thread-wait-for-i/o! conn-fd #:input)
469            (loop))
470          (postgresql-error 'buffer-available-input!
471                            (conc "Error reading reply from server. "
472                                  (PQerrorMessage conn-ptr))
473                            conn-ptr)))))
474
475(define (make-value-parsers conn pqresult)
476  (let ((nfields (PQnfields pqresult)))
477    (do ([col 0 (+ col 1)]
478         [parsers (make-vector nfields)])
479        ([= col nfields] parsers)
480      (vector-set! parsers col
481                   (hash-table-ref (pg-connection-oid-parsers conn)
482                                   (PQftype pqresult col)
483                                   (lambda () identity))))))
484
485;; Collect the result pointers from the last query.
486;;
487;; A pgresult represents an entire resultset and is always read into memory
488;; all at once.
489(define (collect-results conn)
490  (buffer-available-input! conn)
491  (let loop ((results (list)))
492    (let* ((conn-ptr (pg-connection-ptr conn))
493           (result (PQgetResult conn-ptr)))
494      (if result
495          (cond
496           ((member (PQresultStatus result) (list PGRES_BAD_RESPONSE
497                                                  PGRES_FATAL_ERROR))
498            (let* ((get-error-field (lambda (d) (PQresultErrorField result d)))
499                   (sqlstate (get-error-field PG_DIAG_SQLSTATE))
500                   (maybe-severity (get-error-field PG_DIAG_SEVERITY))
501                   (maybe-statement-position
502                    (get-error-field PG_DIAG_STATEMENT_POSITION))
503                   (condition
504                    (make-pg-condition
505                     'collect-results
506                     (PQresultErrorMessage result)
507                     severity:           (and maybe-severity
508                                              (string->symbol
509                                               (string-downcase maybe-severity)))
510                     error-class:        (and sqlstate (string-take sqlstate 2))
511                     error-code:         sqlstate
512                     message-detail:     (get-error-field PG_DIAG_MESSAGE_DETAIL)
513                     message-hint:       (get-error-field PG_DIAG_MESSAGE_HINT)
514                     statement-position: (and maybe-statement-position
515                                              (string->number
516                                               maybe-statement-position))
517                     context:            (get-error-field PG_DIAG_CONTEXT)
518                     source-file:        (get-error-field PG_DIAG_SOURCE_FILE)
519                     source-line:        (get-error-field PG_DIAG_SOURCE_LINE)
520                     source-function:    (get-error-field PG_DIAG_SOURCE_FUNCTION))))
521              ;; Read out all remaining results (including the current one).
522              ;; TODO: Is this really needed? libpq does it (in pqExecFinish),
523              ;; but ostensibly only to concatenate the error messages for
524              ;; each query.  OTOH, maybe we want to do that, too.
525              (let clean-results! ((result result))
526                (when result
527                  (PQclear result)
528                  (clean-results! (PQgetResult (pg-connection-ptr conn)))))
529              (signal condition)))
530           (else
531            (let ((result-obj (make-pg-result result
532                                              (make-value-parsers conn result))))
533              (set-finalizer! result-obj clear-result!)
534              (loop (cons result-obj results)))))
535          (reverse! results)))))
536
537(define (exec-simple-queries conn query)
538  (if ((foreign-lambda bool PQsendQuery pgconn* (const c-string))
539       (pg-connection-ptr conn) query)
540      (collect-results conn)
541      (postgresql-error 'exec-simple-queries
542                        (conc "Unable to send query to server. "
543                              (PQerrorMessage (pg-connection-ptr conn)))
544                        conn query)))
545
546(define (exec-query conn query #!optional (params '()) #!key (format 'text) raw)
547  (let* ((unparsers (pg-connection-type-unparsers conn))
548         (unparse (lambda (x)
549                    (cond ((find (lambda (parse?)
550                                   ((car parse?) x))
551                                 unparsers) => (lambda (parse)
552                                                 ((cdr parse) x)))
553                          (else x))))
554         (params ;; Check all params and ensure they are proper pairs
555          (map   ;; See if this can be moved into C
556           (lambda (p)
557             (let ((obj (if raw p (unparse p))))
558               (when (and (not (string? obj))
559                          (not (blob? obj))
560                          (not (sql-null? obj)))
561                 (postgresql-error
562                  'exec-query
563                  (sprintf "Param value is not a string, sql-null or blob: ~S" p)
564                  conn query params format))
565               (if (sql-null? obj) #f obj))) params))
566         (send-query
567          (foreign-lambda*
568           bool ((pgconn* conn) (nonnull-c-string query)
569                 (int num) (scheme-object params) (int resfmt))
570           "int res = 0, i = 0, *lens = NULL;"
571           "char **vals = NULL;"
572           "int *fmts = NULL;"
573           "C_word obj, cons;"
574           "if (num > 0) {"
575           "    vals = C_malloc(num * sizeof(char *));"
576           "    lens = C_malloc(num * sizeof(int));"
577           "    fmts = C_malloc(num * sizeof(int));"
578           "}"
579           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
580           "    obj = C_u_i_car(cons);"
581           "    if (obj == C_SCHEME_FALSE) {"
582           "        fmts[i] = 0; /* don't care */"
583           "        lens[i] = 0;"
584           "        vals[i] = NULL;"
585           "    } else if (C_header_bits(obj) == C_BYTEVECTOR_TYPE) {"
586           "        fmts[i] = 1; /* binary */"
587           "        lens[i] = C_header_size(obj);"
588           "        vals[i] = C_c_string(obj);"
589           "    } else {"
590           "        /* text needs to be copied; it expects ASCIIZ */"
591           "        fmts[i] = 0; /* text */"
592           "        lens[i] = C_header_size(obj);"
593           "        vals[i] = malloc(lens[i] + 1);"
594           "        memcpy(vals[i], C_c_string(obj), lens[i]);"
595           "        vals[i][lens[i]] = '\\0';"
596           "    }"
597           "}"
598           "res = PQsendQueryParams(conn, query, num, NULL,"
599           "                        vals, lens, fmts, resfmt);"
600           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
601           "    obj = C_u_i_car(cons);"
602           "    if (!C_immediatep(obj) && C_header_bits(obj) == C_STRING_TYPE)"
603           "        free(vals[i]); /* Clear copied strings only */"
604           "}"
605           "if (num > 0) {"
606           "    free(fmts);"
607           "    free(lens);"
608           "    free(vals);"
609           "}"
610           "C_return(res);")))
611   (if (send-query (pg-connection-ptr conn) query
612                   (length params) params (symbol->format format))
613       (car (collect-results conn)) ;; assumed to always return one result...
614       (postgresql-error 'exec-query
615                         (conc "Unable to send query to server. "
616                               (PQerrorMessage (pg-connection-ptr conn)))
617                         conn query params format))))
618
619;;;;;;;;;;;;;;;;;;;;;;
620;;;; Value escaping
621;;;;;;;;;;;;;;;;;;;;;;
622
623(define (escape-string conn str)
624  (define %escape-string-conn
625    ;; This could be more efficient by copying straight into a Scheme object.
626    ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again.
627    ;; This can allocate up to twice as much memory than the string actually
628    ;; uses; in extreme cases this could be a problem.
629    (foreign-lambda* c-string* ((pointer conn) (c-string from) (int fromlen))
630                     "int err = 0; char *to;"
631                     "to = malloc(sizeof(char) * (fromlen * 2 + 1));"
632                     "PQescapeStringConn(conn, to, from, fromlen, &err);"
633                     "if (err) {"
634                     "        free(to);"
635                     "        C_return(NULL);"
636                     "}"
637                     "C_return(to);"))
638  (or (%escape-string-conn conn str (string-length str))
639      (postgresql-error 'escape-string
640                        (conc "String escaping failed. "
641                              (PQerrorMessage conn)) conn str)))
642
643(define (escape-bytea conn str)
644  (define %escape-bytea-conn
645    ;; This must copy because libpq returns a malloced ptr...
646    (foreign-safe-lambda* scheme-object ((pointer conn)
647                                         ;; not copied/NUL interpreted:
648                                         ((const unsigned-c-string*) from)
649                                         (int fromlen))
650                     "size_t tolen=0; C_word res, *fin; unsigned char *esc;"
651                     "esc = PQescapeByteaConn(conn, from, (size_t)fromlen, &tolen);"
652                     "if (esc == NULL)"
653                     "        C_return(C_SCHEME_FALSE);"
654                     "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
655                     "/* tolen includes the resulting NUL byte */"
656                     "res = C_string(&fin, tolen - 1, (char *)esc);"
657                     "PQfreemem(esc);"
658                     "C_return(res);"))
659  (or (%escape-bytea-conn conn str (string-length str))
660      (postgresql-error 'escape-bytea
661                        (conc "Byte array escaping failed. "
662                              (PQerrorMessage conn)) conn str)))
663
664(define (unescape-bytea str)
665  (define %unescape-bytea
666    ;; This must copy because libpq returns a malloced ptr...
667    (foreign-safe-lambda* scheme-object (((const unsigned-c-string*) from))
668                     "size_t tolen=0; C_word res, *fin; unsigned char *unesc;"
669                     "unesc = PQunescapeBytea(from, &tolen);"
670                     "if (unesc == NULL)"
671                     "        C_return(C_SCHEME_FALSE);"
672                     "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
673                     "res = C_string(&fin, tolen, (char *)unesc);"
674                     "PQfreemem(unesc);"
675                     "C_return(res);"
676                     ))
677  (or (%unescape-bytea str)
678      (postgresql-error 'unescape-bytea
679                        "Byte array unescaping failed (out of memory?)" str)))
680
681
682;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
683;;;; High-level interface
684;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
685
686(define (%query-fold kons knil conn query params)
687  (let* ((result (exec-query conn query params))
688         (rows (result-row-count result)))
689    (let loop ((seed knil)
690               (row 0))
691      (if (= row rows)
692          seed
693          (loop (kons (result-row result row) seed) (add1 row))))))
694
695(define (%query-fold-right kons knil conn query params)
696  (let* ((result (exec-query conn query params))
697         (rows (result-row-count result)))
698    (let loop ((seed knil)
699               (row 0))
700      (if (= row rows)
701          seed
702          (kons (result-row result row) (loop seed (add1 row)))))))
703
704(define (query-fold kons knil conn query . params)
705  (%query-fold kons knil conn query params))
706(define (query-fold* kons knil conn query . params)
707  (%query-fold (lambda (values seed) (apply kons (append values (list seed))))
708               knil conn query params))
709(define (query-fold-right kons knil conn query . params)
710  (%query-fold-right kons knil conn query params))
711(define (query-fold-right* kons knil conn query . params)
712  (%query-fold-right (lambda (val seed) (apply kons (append val (list seed))))
713                     knil conn query params))
714
715(define (query-for-each proc conn query . params)
716  (%query-fold (lambda (values seed) (proc values)) #f conn query params)
717  (void))
718
719(define (query-for-each* proc conn query . params)
720  (%query-fold (lambda (values seed) (apply proc values)) #f conn query params)
721  (void))
722
723;; Like regular Scheme map, the order in which the procedure is applied is
724;; undefined.  We make good use of that by traversing the resultset from
725;; the end back to the beginning, thereby avoiding a reverse! on the result.
726(define (%query-map proc conn query params)
727  (let ((result (exec-query conn query params)))
728    (let loop ((ans '())
729               (row (result-row-count result)))
730      (if (= row 0)
731          ans
732          (loop (cons (proc (result-row result (sub1 row))) ans) (sub1 row))))))
733(define (query-map proc conn query . params)
734  (%query-map proc conn query params))
735
736(define (query-map* proc conn query . params)
737  (%query-map (lambda (values seed) (apply proc values)) conn query params))
738
739)
Note: See TracBrowser for help on using the repository browser.