Context Navigation

postgresql.scm @ 16895

Revision 16895, 32.5 KB (checked in by sjamaan, 9 months ago)
Also add raw to the example

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/release/4/postgresql/trunk/postgresql.scm @ 16895

Download in other formats: