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

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

Implement transaction support (including nested transactions)

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