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

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

Improve binary mode result fetching by sticking it into a blob.
The user should figure out what the fuck to do with it :)
(the internal representation is used on the wire and this may change, especially for complex datatypes)

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