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

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

Make row/column-fold-right tail recursive; use this improved fold-right in map to reduce total LOC

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