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

Last change on this file since 14726 was 14726, checked in by sjamaan, 10 years ago

Implement separate parameter passing and the option to explicitly request binary return values.
Old exec-query is now renamed to exec-simple-queries, as it only allows simple queries with no params and no return format, but does allow multiple queries in one string.

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