Context Navigation

postgresql.scm

Revision 19104, 53.8 KB (checked in by sjamaan, 4 weeks ago)
Apply patch to support Postgres 8.2 again, by Alaric Snell-Pym and Florian Zumbiehl

Line
1	;;; Bindings to the PostgreSQL C library
2	;;
3	;; Copyright (C) 2008-2010 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	(type-parsers update-type-parsers! default-type-parsers
23	char-parser bool-parser bytea-parser numeric-parser
24	make-array-parser make-composite-parser
25	scheme-value->db-value type-unparsers update-type-unparsers!
26	default-type-unparsers bool-unparser vector-unparser list-unparser
27
28	connect reset-connection disconnect connection?
29
30	query query* with-transaction in-transaction?
31
32	result? clear-result! row-count column-count
33	column-index column-name column-names column-format
34	column-type column-type-modifier table-oid table-column-index
35	value-at row-values row-alist column-values affected-rows inserted-oid
36
37	invalid-oid
38
39	escape-string escape-bytea unescape-bytea
40
41	put-copy-data put-copy-end get-copy-data
42
43	row-fold row-fold* row-fold-right row-fold-right*
44	row-for-each row-for-each* row-map row-map*
45	column-fold column-fold* column-fold-right column-fold-right*
46	column-for-each column-for-each* column-map column-map*
47	copy-query-fold copy-query-fold copy-query-fold-right copy-query-fold-right
48	copy-query-for-each copy-query-for-each copy-query-map copy-query-map
49	call-with-output-copy-query call-with-output-copy-query*
50	with-output-to-copy-query with-output-to-copy-query*)
51
52	(import chicken scheme foreign)
53
54	(require-extension srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
55	extras data-structures ports sql-null)
56
57	(foreign-declare "#include <libpq-fe.h>")
58
59	(define-foreign-type pg-polling-status (enum "PostgresPollingStatusType"))
60	(define-foreign-variable PGRES_POLLING_FAILED pg-polling-status)
61	(define-foreign-variable PGRES_POLLING_READING pg-polling-status)
62	(define-foreign-variable PGRES_POLLING_WRITING pg-polling-status)
63	(define-foreign-variable PGRES_POLLING_OK pg-polling-status)
64
65	(define-foreign-type pg-exec-status (enum "ExecStatusType"))
66	(define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status)
67	(define-foreign-variable PGRES_COMMAND_OK pg-exec-status)
68	(define-foreign-variable PGRES_TUPLES_OK pg-exec-status)
69	(define-foreign-variable PGRES_COPY_OUT pg-exec-status)
70	(define-foreign-variable PGRES_COPY_IN pg-exec-status)
71	(define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status)
72	(define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status)
73	(define-foreign-variable PGRES_FATAL_ERROR pg-exec-status)
74
75	;(define-foreign-type pgconn* (c-pointer "PGconn"))
76	(define-foreign-type pgconn* c-pointer)
77
78	(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string)))
79	(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*))
80	(define PQresetStart (foreign-lambda bool PQresetStart pgconn*))
81	(define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*))
82	(define PQfinish (foreign-lambda void PQfinish pgconn*))
83	(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
84	(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
85
86	;(define-foreign-type oid "Oid")
87	(define-foreign-type oid unsigned-int)
88
89	(define invalid-oid (foreign-value "InvalidOid" oid))
90
91	(define PQisBusy (foreign-lambda bool PQisBusy pgconn*))
92	(define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*))
93
94	(define-foreign-type pgresult* (c-pointer "PGresult"))
95
96	(define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*))
97	(define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*)))
98	(define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*)))
99	(define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int))
100
101	(define PQclear (foreign-lambda void PQclear pgresult*))
102	(define PQntuples (foreign-lambda int PQntuples (const pgresult*)))
103	(define PQnfields (foreign-lambda int PQnfields (const pgresult*)))
104	(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int))
105	(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string)))
106	(define PQftable (foreign-lambda oid PQftable (const pgresult*) int))
107	(define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int))
108	(define PQfformat (foreign-lambda int PQfformat (const pgresult*) int))
109	(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
110	(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int))
111	(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
112	(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
113	(define PQoidValue (foreign-lambda oid PQoidValue pgresult*))
114
115	(define PQputCopyData (foreign-lambda int PQputCopyData pgconn* blob int))
116	(define PQputCopyEnd (foreign-lambda int PQputCopyEnd pgconn* (const c-string)))
117
118	;; TODO: Create a real callback system?
119	(foreign-declare "static void nullNoticeReceiver(void arg, const PGresult res){ }")
120
121	(define-syntax define-foreign-int
122	(er-macro-transformer
123	(lambda (e r c)
124	;; cannot rename define-foreign-variable; it's a really special form
125	`(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
126
127	(define-foreign-int PG_DIAG_SEVERITY)
128	(define-foreign-int PG_DIAG_SQLSTATE)
129	(define-foreign-int PG_DIAG_MESSAGE_PRIMARY)
130	(define-foreign-int PG_DIAG_MESSAGE_DETAIL)
131	(define-foreign-int PG_DIAG_MESSAGE_HINT)
132	(define-foreign-int PG_DIAG_STATEMENT_POSITION)
133	(define-foreign-int PG_DIAG_CONTEXT)
134	(define-foreign-int PG_DIAG_SOURCE_FILE)
135	(define-foreign-int PG_DIAG_SOURCE_LINE)
136	(define-foreign-int PG_DIAG_SOURCE_FUNCTION)
137
138	;; Helper procedure for lists (TODO: use ANY instead of IN with an array?)
139	(define (in-list len)
140	(string-intersperse
141	(list-tabulate len (lambda (p) (conc "$" (add1 p)))) ","))
142
143	(define (postgresql-error loc message . args)
144	(signal (make-pg-condition loc message args: args)))
145
146	(define (make-pg-condition loc message #!key (args '()) severity
147	error-class error-code message-detail
148	message-hint statement-position context
149	source-file source-line
150	source-function)
151	(make-composite-condition
152	(make-property-condition
153	'exn 'location loc 'message message 'arguments args)
154	(make-property-condition
155	'postgresql 'severity severity 'error-class error-class
156	'error-code error-code 'message-detail message-detail
157	'message-hint message-hint 'statement-position statement-position
158	'context context 'source-file source-file 'source-line source-line
159	;; Might break not-terribly-old versions of postgresql
160	;;'internal-position internal-position 'internal-query internal-query
161	'source-function source-function)))
162
163	;;;;;;;;;;;;;;;;;;;;;;;;
164	;;;; Type parsers
165	;;;;;;;;;;;;;;;;;;;;;;;;
166
167	(define (char-parser str) (string-ref str 0))
168
169	(define (bool-parser str) (string=? str "t"))
170
171	(define (numeric-parser str)
172	(or (string->number str)
173	(postgresql-error 'numeric-parser "Unable to parse number" str)))
174
175	(define (bytea-parser str)
176	(blob->u8vector/shared (string->blob (unescape-bytea str))))
177
178	;; Here be dragons
179	(define (make-array-parser element-parser #!optional (delim #\,))
180	(define (parse str)
181	(if (string-ci=? "NULL" str)
182	(sql-null)
183	(element-parser str)))
184	(lambda (str)
185	(let loop ((chars (let ignore-bounds ((chars (string->list str)))
186	(if (char=? (car chars) #\{)
187	chars
188	(ignore-bounds (cdr chars)))))
189	(result (list)))
190	(if (null? chars)
191	(car result) ; Should contain only one vector
192	(case (car chars)
193	((#\{) (receive (value rest-chars)
194	(loop (cdr chars) (list))
195	(loop rest-chars (cons value result))))
196	((#\}) (values (list->vector (reverse! result)) (cdr chars)))
197	((#\") (let consume-string ((chars (cdr chars))
198	(consumed (list)))
199	(case (car chars)
200	((#\\) (consume-string ; Don't interpret, just add it
201	(cddr chars) (cons (cadr chars) consumed)))
202	((#\") (loop (cdr chars)
203	(cons (element-parser
204	(reverse-list->string consumed))
205	result)))
206	(else (consume-string (cdr chars)
207	(cons (car chars) consumed))))))
208	((#\tab #\newline #\space) (loop (cdr chars) result))
209	(else
210	(if (char=? (car chars) delim)
211	(loop (cdr chars) result)
212	(let consume-string ((chars chars)
213	(consumed (list)))
214	(cond
215	((char=? (car chars) delim)
216	(loop (cdr chars)
217	(cons (parse (reverse-list->string consumed))
218	result)))
219	((or (char=? (car chars) #\})
220	(char=? (car chars) #\}))
221	(loop chars
222	(cons (parse (reverse-list->string consumed))
223	result)))
224	(else (consume-string (cdr chars)
225	(cons (car chars) consumed))))))))))))
226
227	(define (make-composite-parser element-parsers)
228	(define (parse str element-parser)
229	(if (string=? "" str)
230	(sql-null)
231	(element-parser str)))
232	(lambda (str)
233	(let loop ((chars (cdr (string->list (string-trim str)))) ; skip leading (
234	(result (list))
235	(parsers element-parsers))
236	(case (car chars)
237	((#\)) (reverse! result)) ; Done
238	((#\") (let consume-string ((chars (cdr chars))
239	(consumed (list)))
240	(case (car chars)
241	((#\\) (consume-string ; Don't interpret, just add it
242	(cddr chars) (cons (cadr chars) consumed)))
243	((#\") (if (char=? #\" (cadr chars)) ; double escapes
244	(consume-string (cddr chars)
245	(cons #\" consumed))
246	(let skip-spaces ((chars (cdr chars)))
247	(case (car chars)
248	((#\space #\newline #\tab)
249	(skip-spaces (cdr chars)))
250	((#\,)
251	(loop (cdr chars)
252	(cons ((car parsers)
253	(reverse-list->string consumed))
254	result)
255	(cdr parsers)))
256	((#\)) (loop chars
257	(cons ((car parsers)
258	(reverse-list->string consumed))
259	result)
260	(cdr parsers)))
261	(else
262	(postgresql-error 'make-composite-parser
263	"Bogus trailing characters"
264	str))))))
265	(else (consume-string (cdr chars)
266	(cons (car chars) consumed))))))
267	(else (let consume-string ((chars chars)
268	(consumed (list)))
269	(case (car chars)
270	((#\,) (loop (cdr chars)
271	(cons (parse (reverse-list->string consumed)
272	(car parsers))
273	result)
274	(cdr parsers)))
275	;; Nothing should precede this one
276	((#\)) (loop chars
277	(cons (parse (reverse-list->string consumed)
278	(car parsers))
279	result)
280	(cdr parsers)))
281	(else (consume-string (cdr chars)
282	(cons (car chars) consumed))))))))))
283
284	;; Array parsers and composite parsers are automatically cached when such
285	;; a value is requested.
286	(define default-type-parsers
287	(make-parameter
288	`(("text" . ,identity)
289	("bytea" . ,bytea-parser)
290	("char" . ,char-parser)
291	("bpchar" . ,identity)
292	("bool" . ,bool-parser)
293	("int8" . ,numeric-parser)
294	("int4" . ,numeric-parser)
295	("int2" . ,numeric-parser)
296	("float4" . ,numeric-parser)
297	("float8" . ,numeric-parser)
298	("numeric" . ,numeric-parser)
299	("oid" . ,numeric-parser)
300	;; Nasty hack, or clever hack? :)
301	("record" . ,(make-composite-parser (circular-list identity))))))
302
303	;;;;;;;;;;;;;;;;;;;;;;;
304	;;;; Type unparsers
305	;;;;;;;;;;;;;;;;;;;;;;;
306
307	(define (scheme-value->db-value conn value)
308	(cond ((find (lambda (parse?)
309	((car parse?) value))
310	(pg-connection-type-unparsers conn)) =>
311	(lambda (parse)
312	((cdr parse) conn value)))
313	(else value)))
314
315	(define (bool-unparser conn b)
316	(if b "TRUE" "FALSE"))
317
318	(define (vector-unparser conn v)
319	(let loop ((result (list))
320	(pos 0)
321	(len (vector-length v)))
322	(if (= pos len)
323	(string-append "{" (string-intersperse (reverse! result) ",") "}")
324	(let* ((value (vector-ref v pos))
325	(unparsed-value (scheme-value->db-value conn value))
326	(serialized (cond
327	((sql-null? unparsed-value) "NULL")
328	((not (string? unparsed-value))
329	(postgresql-error
330	'vector-unparser
331	(sprintf "Param value is not string: ~S"
332	unparsed-value)))
333	((vector? value) unparsed-value) ;; don't quote!
334	(else
335	(sprintf "\"~A\""
336	(string-translate*
337	unparsed-value
338	'(("\\" . "\\\\") ("\"" . "\\\""))))))))
339	(loop (cons serialized result) (add1 pos) len)))))
340
341	(define (list-unparser conn l)
342	(let loop ((result (list))
343	(items l))
344	(if (null? items)
345	(string-append "(" (string-intersperse (reverse! result) ",") ")")
346	(let* ((unparsed-value (scheme-value->db-value conn (car items)))
347	(serialized (cond
348	((sql-null? unparsed-value) "")
349	((not (string? unparsed-value))
350	(postgresql-error
351	'list-unparser
352	(sprintf "Param value is not string: ~S"
353	unparsed-value)))
354	(else
355	(sprintf "\"~A\""
356	(string-translate*
357	unparsed-value
358	'(("\\" . "\\\\") ("\"" . "\\\""))))))))
359	(loop (cons serialized result) (cdr items))))))
360
361	(define default-type-unparsers
362	(make-parameter
363	`((,string? . ,(lambda (conn s) s))
364	(,u8vector? . ,(lambda (conn v) (u8vector->blob/shared v)))
365	(,char? . ,(lambda (conn c) (string c)))
366	(,boolean? . ,bool-unparser)
367	(,number? . ,(lambda (conn n) (number->string n)))
368	(,vector? . ,vector-unparser)
369	(,pair? . ,list-unparser))))
370
371	;; Retrieve type-oids from PostgreSQL:
372	(define (update-type-parsers! conn #!optional new-type-parsers)
373	(let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
374	(ht (make-hash-table))
375	(result '()))
376	(pg-connection-oid-parsers-set! conn ht)
377	(pg-connection-type-parsers-set! conn type-parsers)
378	(unless (null? type-parsers) ; empty IN () clause is not allowed
379	(row-for-each*
380	(lambda (oid typname)
381	(and-let* ((procedure (assoc typname type-parsers)))
382	(hash-table-set! ht (string->number oid) (cdr procedure))))
383	(query* conn (sprintf
384	"SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
385	(in-list (length type-parsers)))
386	(map car type-parsers) raw: #t)))))
387
388	(define (update-type-unparsers! conn new-type-unparsers)
389	(pg-connection-type-unparsers-set! conn new-type-unparsers))
390
391	;;;;;;;;;;;;;;;;;;;;
392	;;;; Connections
393	;;;;;;;;;;;;;;;;;;;;
394
395	(define-record
396	pg-connection ptr
397	type-parsers oid-parsers type-unparsers
398	transaction-depth)
399	(define connection? pg-connection?)
400	(define type-parsers pg-connection-type-parsers)
401	(define type-unparsers pg-connection-type-unparsers)
402
403	(define (pgsql-connection->fd conn)
404	((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
405
406	(define (wait-for-connection! conn poll-function)
407	(let ((conn-fd (pgsql-connection->fd conn))
408	(conn-ptr (pg-connection-ptr conn)))
409	(let loop ((result (poll-function conn-ptr)))
410	(cond ((= result PGRES_POLLING_OK) (void))
411	((= result PGRES_POLLING_FAILED)
412	(let ((error-message (PQerrorMessage conn-ptr)))
413	(disconnect conn)
414	(postgresql-error 'connect
415	(conc "Polling Postgres database failed. "
416	error-message) conn)))
417	((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
418	(thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
419	#:input
420	#:output))
421	(loop (poll-function conn-ptr)))
422	(else
423	(postgresql-error 'connect (conc "Unknown status code!") conn))))))
424
425	(define (alist->connection-spec alist)
426	(string-join
427	(map (lambda (subspec)
428	(sprintf "~A='~A'"
429	(car subspec) ;; this had better not contain [ =\']
430	(string-translate* (->string (cdr subspec))
431	'(("\\" . "\\\\") ("'" . "\\'")))))
432	alist)))
433
434	(define (connect connection-spec
435	#!optional
436	(type-parsers (default-type-parsers))
437	(type-unparsers (default-type-unparsers)))
438	(let* ((connection-spec (if (string? connection-spec)
439	connection-spec
440	(alist->connection-spec connection-spec)))
441	(conn-ptr (PQconnectStart connection-spec)))
442	(cond
443	((not conn-ptr)
444	(postgresql-error 'connect
445	"Unable to allocate a Postgres connection structure."
446	connection-spec))
447	((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
448	(let ((error-message (PQerrorMessage conn-ptr)))
449	(PQfinish conn-ptr)
450	(postgresql-error 'connect
451	(conc "Connection to Postgres database failed: "
452	error-message)
453	connection-spec)))
454	(else
455	(let ((conn (make-pg-connection conn-ptr type-parsers
456	(make-hash-table) type-unparsers 0)))
457	;; We don't want libpq to piss in our stderr stream
458	((foreign-lambda* void ((pgconn* conn))
459	"PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
460	(wait-for-connection! conn PQconnectPoll)
461	(set-finalizer! conn disconnect)
462	;; Retrieve type-information from PostgreSQL metadata for use by
463	;; the various value-parsers.
464	(update-type-parsers! conn)
465	conn)))))
466
467	(define (reset-connection connection)
468	(let ((conn-ptr (pg-connection-ptr connection)))
469	(if (PQresetStart conn-ptr) ;; Update oid-parsers?
470	(wait-for-connection! connection PQresetPoll)
471	(let ((error-message (PQerrorMessage conn-ptr)))
472	(disconnect connection)
473	(postgresql-error 'reset-connection
474	(conc "Reset of connection failed " error-message)
475	connection)))))
476
477	(define (disconnect connection)
478	(and-let* ((conn-ptr (pg-connection-ptr connection)))
479	(pg-connection-ptr-set! connection #f)
480	(pg-connection-type-parsers-set! connection #f)
481	(pg-connection-oid-parsers-set! connection #f)
482	(PQfinish conn-ptr))
483	(void))
484
485	;;;;;;;;;;;;;;;
486	;;;; Results
487	;;;;;;;;;;;;;;;
488
489	(define-record pg-result ptr value-parsers)
490	(define result? pg-result?)
491
492	(define (clear-result! result)
493	(and-let* ((result-ptr (pg-result-ptr result)))
494	(pg-result-ptr-set! result #f)
495	(PQclear result-ptr)))
496
497	(define (row-count result)
498	(PQntuples (pg-result-ptr result)))
499
500	(define (column-count result)
501	(PQnfields (pg-result-ptr result)))
502
503	;; Helper procedures for bounds checking; so we can distinguish between
504	;; out of bounds and nonexistant columns, and signal it.
505	(define (check-column-index! result index location)
506	(when (>= index (column-count result))
507	(postgresql-error
508	location (sprintf "Result column ~A out of bounds" index) result index)))
509
510	(define (check-row-index! result index location)
511	(when (>= index (row-count result))
512	(postgresql-error
513	location (sprintf "Result row ~A out of bounds" index) result index)))
514
515	(define (column-name result index)
516	(check-column-index! result index 'column-name)
517	(string->symbol (PQfname (pg-result-ptr result) index)))
518
519	(define (column-names result)
520	(let ((ptr (pg-result-ptr result)))
521	(let loop ((names '())
522	(column (column-count result)))
523	(if (= column 0)
524	names
525	(loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
526	(sub1 column))))))
527
528	(define (column-index result name)
529	(let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name))))
530	(and (>= idx 0) idx)))
531
532	(define (table-oid result index)
533	(check-column-index! result index 'table-oid)
534	(let ((oid (PQftable (pg-result-ptr result) index)))
535	(and (not (= oid invalid-oid)) oid)))
536
537	;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
538	;; consistent with the rest of Scheme. However, this is inconsistent with
539	;; almost all other PostgreSQL interfaces...
540	(define (table-column-index result index)
541	(check-column-index! result index 'table-column-index)
542	(let ((idx (PQftablecol (pg-result-ptr result) index)))
543	(and (> idx 0) (sub1 idx))))
544
545	(define format-table
546	'((0 . text) (1 . binary)))
547
548	(define (format->symbol format)
549	(or (alist-ref format format-table eq?)
550	(postgresql-error 'format->symbol "Unknown format" format)))
551
552	(define (symbol->format symbol)
553	(or (and-let* ((res (rassoc symbol format-table eq?)))
554	(car res))
555	(postgresql-error 'format->symbol "Unknown format" symbol)))
556
557	(define (column-format result index)
558	(check-column-index! result index 'column-format)
559	(format->symbol (PQfformat (pg-result-ptr result) index)))
560
561	(define (column-type result index)
562	(check-column-index! result index 'column-type)
563	(PQftype (pg-result-ptr result) index))
564
565	;; This is really not super-useful as it requires intimate knowledge
566	;; about the internal implementations of types in PostgreSQL.
567	(define (column-type-modifier result index)
568	(check-column-index! result index 'column-type)
569	(let ((mod (PQfmod (pg-result-ptr result) index)))
570	(and (>= mod 0) mod)))
571
572	;; Unchecked version, for speed
573	(define (value-at* result column row #!key raw)
574	(if (PQgetisnull (pg-result-ptr result) row column)
575	(sql-null)
576	(let ((value ((foreign-safe-lambda*
577	scheme-object ((c-pointer res) (int row) (int col))
578	"C_word fin, str; char val; int len;"
579	"len = PQgetlength(res, row, col);"
580	"str = C_alloc(C_bytestowords(len + sizeof(C_header)));"
581	"val = PQgetvalue(res, row, col);"
582	"fin = C_string(&str, len, val);"
583	"if (PQfformat(res, col) == 1) /* binary? */"
584	" C_string_to_bytevector(fin);"
585	"C_return(fin);")
586	(pg-result-ptr result) row column)))
587	(if (or raw (blob? value))
588	value
589	((vector-ref (pg-result-value-parsers result) column) value)))))
590
591	(define (value-at result #!optional (column 0) (row 0) #!key raw)
592	(check-row-index! result row 'value)
593	(check-column-index! result column 'value)
594	(value-at* result column row raw: raw))
595
596	(define (row-values result #!optional (row 0) #!key raw)
597	(check-row-index! result row 'row)
598	(let loop ((list '())
599	(column (column-count result)))
600	(if (= column 0)
601	list
602	(loop (cons (value-at* result (sub1 column) row raw: raw) list)
603	(sub1 column)))))
604
605	(define (column-values result #!optional (column 0) #!key raw)
606	(check-column-index! result column 'column)
607	(let loop ((list '())
608	(row (row-count result)))
609	(if (= row 0)
610	list
611	(loop (cons (value-at* result column (sub1 row) raw: raw) list)
612	(sub1 row)))))
613
614	;; (define (row-alist result #!optional (row 0) #!key raw)
615	;; (map cons (column-names result) (row-values result row raw: raw)))
616	(define (row-alist result #!optional (row 0) #!key raw)
617	(check-row-index! result row 'row-alist)
618	(let loop ((alist '())
619	(column (column-count result)))
620	(if (= column 0)
621	alist
622	(loop (cons (cons (string->symbol
623	(PQfname (pg-result-ptr result) (sub1 column)))
624	(value-at* result (sub1 column) row raw: raw)) alist)
625	(sub1 column)))))
626
627	;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
628
629	(define (affected-rows result)
630	(string->number (PQcmdTuples (pg-result-ptr result))))
631
632	(define (inserted-oid result)
633	(let ((oid (PQoidValue (pg-result-ptr result))))
634	(and (not (= oid invalid-oid)) oid)))
635
636
637	;;;;;;;;;;;;;;;;;;;;;;;;
638	;;;; Query procedures
639	;;;;;;;;;;;;;;;;;;;;;;;;
640
641	;; Buffer all available input, yielding if nothing is available:
642	(define (buffer-available-input! conn)
643	(let ((conn-ptr (pg-connection-ptr conn))
644	(conn-fd (pgsql-connection->fd conn)))
645	(let loop ()
646	(if (PQconsumeInput conn-ptr)
647	(when (PQisBusy conn-ptr)
648	(thread-wait-for-i/o! conn-fd #:input)
649	(loop))
650	(postgresql-error 'buffer-available-input!
651	(conc "Error reading reply from server. "
652	(PQerrorMessage conn-ptr))
653	conn)))))
654
655	;; Here be more dragons
656	(define (resolve-unknown-types! conn oids)
657	(unless (null? oids)
658	(let* ((parsers (pg-connection-oid-parsers conn))
659	(q (conc "SELECT t.oid, t.typtype, t.typelem, t.typdelim, "
660	" t.typbasetype, a.attrelid, a.atttypid "
661	"FROM pg_type t "
662	" LEFT JOIN pg_attribute a "
663	" ON t.typrelid = a.attrelid AND a.attnum > 0 "
664	"WHERE t.oid IN (~A) "
665	"ORDER BY COALESCE(t.typrelid,-1) ASC, a.attnum ASC"))
666	(result (query* conn (sprintf q (in-list (length oids)))
667	(map number->string oids) raw: #t))
668	(count (row-count result)))
669	(let dissect-types ((unknown-oids (list))
670	(pos 0)
671	(domains (list))
672	(arrays (list))
673	(classes (list))
674	(last-class 0))
675	(cond
676	((>= pos count) ; Done scanning rows?
677	;; Keep going until all oids are resolved
678	(resolve-unknown-types! conn unknown-oids)
679	;; Postprocessing step: resolve all nested types
680	(for-each (lambda (d)
681	(and-let* ((p (hash-table-ref/default parsers (cdr d) #f)))
682	(hash-table-set! parsers (car d) p)))
683	domains)
684	(for-each (lambda (a)
685	(and-let* ((p (hash-table-ref/default parsers (cddr a) #f)))
686	(hash-table-set! parsers (car a)
687	(make-array-parser p (cadr a)))))
688	arrays)
689	(for-each
690	(lambda (c)
691	(and-let* ((p-list
692	(fold
693	(lambda (att l)
694	(and-let* ((l)
695	(p (hash-table-ref/default parsers att #f)))
696	(cons p l)))
697	'()
698	(cdr c))))
699	(hash-table-set! parsers (car c)
700	(make-composite-parser p-list))))
701	classes))
702	((not (string=? (value-at* result 4 pos) "0")) ; Domain type?
703	(let* ((basetype-oid (string->number (value-at* result 4 pos)))
704	(parser (hash-table-ref/default parsers basetype-oid #f))
705	(oid (string->number (value-at* result 0 pos))))
706	(dissect-types (if parser
707	unknown-oids
708	(cons basetype-oid unknown-oids))
709	(add1 pos) (cons (cons oid basetype-oid) domains)
710	arrays classes last-class)))
711	((not (string=? (value-at* result 2 pos) "0")) ; Array value?
712	(let* ((elem (string->number (value-at* result 2 pos)))
713	(delim (string-ref (value-at* result 3 pos) 0))
714	(parser (hash-table-ref/default parsers elem #f))
715	(oid (string->number (value-at* result 0 pos))))
716	(dissect-types (if parser
717	unknown-oids
718	(cons elem unknown-oids))
719	(add1 pos) domains
720	(cons (cons oid (cons delim elem)) arrays)
721	classes last-class)))
722	((string=? (value-at* result 1 pos) "c") ; Class? (i.e., table or type)
723	(let* ((classid (string->number (value-at* result 5 pos)))
724	(attrid (string->number (value-at* result 6 pos)))
725	(parser (hash-table-ref/default parsers attrid #f)))
726	(dissect-types (if parser
727	unknown-oids
728	(cons attrid unknown-oids))
729	(add1 pos) domains arrays
730	;; Keep oid at the front of the list, insert this
731	;; attr after it, before the other attrs, if any.
732	(if (= last-class classid)
733	(cons (cons (caar classes)
734	(cons attrid (cdar classes)))
735	(cdr classes))
736	(cons (cons (string->number
737	(value-at* result 0 pos))
738	(list attrid)) classes))
739	classid)))
740	(else
741	(dissect-types unknown-oids (add1 pos)
742	domains arrays classes last-class)))))))
743
744	(define (make-value-parsers conn pqresult #!key raw)
745	(let* ((nfields (PQnfields pqresult))
746	(parsers (make-vector nfields))
747	(ht (pg-connection-oid-parsers conn)))
748	(let loop ((col 0)
749	(unknowns (list)))
750	(if (= col nfields)
751	(begin
752	(resolve-unknown-types! conn (map cdr unknowns))
753	(for-each (lambda (unknown)
754	(let* ((col (car unknown))
755	(oid (cdr unknown))
756	(parser (hash-table-ref/default ht oid identity)))
757	(vector-set! parsers col parser)))
758	unknowns)
759	parsers)
760	(let* ((oid (PQftype pqresult col))
761	(parser (if raw identity (hash-table-ref/default ht oid #f))))
762	(vector-set! parsers col parser)
763	(loop (add1 col) (if parser
764	unknowns
765	(cons (cons col oid) unknowns))))))))
766
767	;; Collect the result pointers from the last query.
768	;;
769	;; A pgresult represents an entire resultset and is always read into memory
770	;; all at once.
771	(define (get-last-result conn #!key raw)
772	(buffer-available-input! conn)
773	(let* ((conn-ptr (pg-connection-ptr conn))
774	;; Read out all remaining results (including the current one).
775	;; TODO: Is this really needed? libpq does it (in pqExecFinish),
776	;; but ostensibly only to concatenate the error messages for
777	;; each query. OTOH, maybe we want to do that, too.
778	(clean-results! (lambda (result)
779	(let loop ((result result))
780	(when result
781	(PQclear result)
782	(loop (PQgetResult conn-ptr))))))
783	(result (PQgetResult conn-ptr))
784	(status (PQresultStatus result)))
785	(cond
786	((not result) (postgresql-error
787	'get-last-result
788	"Internal error! No result object available from server"
789	conn))
790	((member status (list PGRES_BAD_RESPONSE PGRES_FATAL_ERROR
791	PGRES_NONFATAL_ERROR))
792	(let* ((get-error-field (lambda (d) (PQresultErrorField result d)))
793	(sqlstate (get-error-field PG_DIAG_SQLSTATE))
794	(maybe-severity (get-error-field PG_DIAG_SEVERITY))
795	(maybe-statement-position
796	(get-error-field PG_DIAG_STATEMENT_POSITION))
797	(condition
798	(make-pg-condition
799	'get-last-result
800	(PQresultErrorMessage result)
801	severity: (and maybe-severity
802	(string->symbol
803	(string-downcase maybe-severity)))
804	error-class: (and sqlstate (string-take sqlstate 2))
805	error-code: sqlstate
806	message-detail: (get-error-field PG_DIAG_MESSAGE_DETAIL)
807	message-hint: (get-error-field PG_DIAG_MESSAGE_HINT)
808	statement-position: (and maybe-statement-position
809	(string->number
810	maybe-statement-position))
811	context: (get-error-field PG_DIAG_CONTEXT)
812	source-file: (get-error-field PG_DIAG_SOURCE_FILE)
813	source-line: (get-error-field PG_DIAG_SOURCE_LINE)
814	source-function: (get-error-field PG_DIAG_SOURCE_FUNCTION))))
815	(clean-results! result)
816	(signal condition)))
817	((member status (list PGRES_COPY_OUT PGRES_COPY_IN))
818	;; These are weird; A COPY puts the connection in "copy mode".
819	;; As long as it's in "copy mode", pqgetresult will return the
820	;; same result every time you call it, so don't try to call
821	;; clean-results!
822	(let ((result-obj (make-pg-result result #f)))
823	(set-finalizer! result-obj clear-result!)
824	result-obj))
825	((member status (list PGRES_EMPTY_QUERY PGRES_COMMAND_OK
826	PGRES_TUPLES_OK))
827	(let ((result-obj (make-pg-result result #f)))
828	(set-finalizer! result-obj clear-result!)
829	(let ((trailing-result (PQgetResult conn-ptr)))
830	(when trailing-result
831	(clean-results! trailing-result)
832	(postgresql-error 'get-last-result
833	(conc "Internal error! Unexpected extra "
834	"results after first query result")
835	conn)))
836	(pg-result-value-parsers-set!
837	result-obj (make-value-parsers conn result raw: raw))
838	result-obj))
839	(else (postgresql-error 'get-last-result
840	(conc "Internal error! Unknown status code: "
841	status)
842	conn)))))
843
844	(define (query conn query . params)
845	(query* conn query params))
846
847	(define (query* conn query #!optional (params '()) #!key (format 'text) raw)
848	(let* ((params ;; Check all params and ensure they are proper pairs
849	(map ;; See if this can be moved into C
850	(lambda (p)
851	(let ((obj (if raw p (scheme-value->db-value conn p))))
852	(when (and (not (string? obj))
853	(not (blob? obj))
854	(not (sql-null? obj)))
855	(postgresql-error
856	'query*
857	(sprintf "Param value is not string, sql-null or blob: ~S" p)
858	conn query params format))
859	(if (sql-null? obj) #f obj))) params))
860	(send-query
861	(foreign-lambda*
862	bool ((pgconn* conn) (nonnull-c-string query)
863	(int num) (scheme-object params) (int resfmt))
864	"int res = 0, i = 0, *lens = NULL;"
865	"char **vals = NULL;"
866	"int *fmts = NULL;"
867	"C_word obj, cons;"
868	"if (num > 0) {"
869	" vals = C_malloc(num * sizeof(char *));"
870	" lens = C_malloc(num * sizeof(int));"
871	" fmts = C_malloc(num * sizeof(int));"
872	"}"
873	"for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
874	" obj = C_u_i_car(cons);"
875	" if (obj == C_SCHEME_FALSE) {"
876	" fmts[i] = 0; /* don't care */"
877	" lens[i] = 0;"
878	" vals[i] = NULL;"
879	" } else if (C_header_bits(obj) == C_BYTEVECTOR_TYPE) {"
880	" fmts[i] = 1; /* binary */"
881	" lens[i] = C_header_size(obj);"
882	" vals[i] = C_c_string(obj);"
883	" } else {"
884	" /* text needs to be copied; it expects ASCIIZ */"
885	" fmts[i] = 0; /* text */"
886	" lens[i] = C_header_size(obj);"
887	" vals[i] = malloc(lens[i] + 1);"
888	" memcpy(vals[i], C_c_string(obj), lens[i]);"
889	" vals[i][lens[i]] = '\\0';"
890	" }"
891	"}"
892	"res = PQsendQueryParams((PGconn *)conn, query, num, NULL,"
893	" (const char * const *)vals, lens, fmts, resfmt);"
894	"for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
895	" obj = C_u_i_car(cons);"
896	" if (!C_immediatep(obj) && C_header_bits(obj) == C_STRING_TYPE)"
897	" free(vals[i]); /* Clear copied strings only */"
898	"}"
899	"if (num > 0) {"
900	" free(fmts);"
901	" free(lens);"
902	" free(vals);"
903	"}"
904	"C_return(res);")))
905	(if (send-query (pg-connection-ptr conn) query
906	(length params) params (symbol->format format))
907	(get-last-result conn raw: raw)
908	(postgresql-error 'query*
909	(conc "Unable to send query to server. "
910	(PQerrorMessage (pg-connection-ptr conn)))
911	conn query params format))))
912
913	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
914	;;;; Transaction management
915	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
916
917	(define (with-transaction conn thunk)
918	(let* ((old-depth (pg-connection-transaction-depth conn))
919	(rollback!
920	(lambda ()
921	(if (= old-depth 0)
922	(query conn "ROLLBACK")
923	;; We do not need to give savepoints unique names,
924	;; but it aids debugging and we know the depth anyway.
925	(query conn (conc "ROLLBACK TO SAVEPOINT s_" old-depth)))))
926	(commit!
927	(lambda ()
928	(if (= old-depth 0)
929	(query conn "COMMIT")
930	(query conn (conc "RELEASE SAVEPOINT s_" old-depth))))))
931	(if (= old-depth 0)
932	(query conn "BEGIN")
933	(query conn (conc "SAVEPOINT s_" old-depth)))
934	(pg-connection-transaction-depth-set! conn (add1 old-depth))
935	;; TODO: Add a warning mechanism (using dynamic-wind) for when the
936	;; user tries to jump into/out of transactions with continuations?
937	(handle-exceptions exn
938	(begin
939	(pg-connection-transaction-depth-set! conn old-depth)
940	(rollback!)
941	(raise exn))
942	(let ((res (thunk)))
943	(pg-connection-transaction-depth-set! conn old-depth)
944	(if res (commit!) (rollback!))
945	res))))
946
947	(define (in-transaction? conn)
948	(> (pg-connection-transaction-depth conn) 0))
949
950	;;;;;;;;;;;;;;;;;;;;
951	;;;; COPY support
952	;;;;;;;;;;;;;;;;;;;;
953
954	(define (put-copy-data conn data)
955	(let* ((data (cond
956	((blob? data) data)
957	((string? data) (string->blob data))
958	((u8vector? data) (u8vector->blob/shared data))
959	(else (postgresql-error
960	'put-copy-data "Expected a blob, string or u8vector"
961	conn data))))
962	(len (blob-size data))
963	(conn-ptr (pg-connection-ptr conn))
964	(conn-fd (pgsql-connection->fd conn)))
965	(let loop ((res (PQputCopyData conn-ptr data len)))
966	(cond
967	((= res 0)
968	(thread-wait-for-i/o! conn-fd #:output)
969	(loop (PQputCopyData conn-ptr data len)))
970	((= res 1) (void))
971	((= res -1) (postgresql-error 'put-copy-data
972	(conc "Error putting COPY data. "
973	(PQerrorMessage conn-ptr))
974	conn))
975	(else (postgresql-error
976	'put-copy-data
977	(conc "Internal error! Unexpected return value: " res)
978	conn))))))
979
980	(define (put-copy-end conn #!optional error-message)
981	(let ((conn-ptr (pg-connection-ptr conn))
982	(conn-fd (pgsql-connection->fd conn)))
983	(let loop ((res (PQputCopyEnd conn-ptr error-message)))
984	(cond
985	((= res 0)
986	(thread-wait-for-i/o! conn-fd #:output)
987	(loop (PQputCopyEnd conn-ptr error-message)))
988	((= res 1) (get-last-result conn))
989	((= res -1) (postgresql-error 'put-copy-end
990	(conc "Error ending put COPY data. "
991	(PQerrorMessage conn-ptr))
992	conn error-message))
993	(else
994	(postgresql-error 'put-copy-end
995	(conc "Internal error! Unexpected return value: " res)
996	conn))))))
997
998	(define (get-copy-data conn #!key (format 'text))
999	(let* ((conn-ptr (pg-connection-ptr conn))
1000	(conn-fd (pgsql-connection->fd conn)))
1001	(let loop ()
1002	(let-location ((res int))
1003	(let ((data ((foreign-safe-lambda*
1004	scheme-object ((pgconn* conn) ((c-pointer int) res)
1005	(int format))
1006	"C_word fin = C_SCHEME_FALSE, str; char buf; "
1007	"*res = PQgetCopyData(conn, &buf, 1); "
1008	"if (buf != NULL) { /* res is length */ "
1009	" str = C_alloc(C_bytestowords(*res + sizeof(C_header))); "
1010	" fin = C_string(&str, *res, buf); "
1011	" if (format == 1) "
1012	" C_string_to_bytevector(fin);"
1013	" PQfreemem(buf); "
1014	"} "
1015	"C_return(fin);")
1016	conn-ptr (location res) (symbol->format format))))
1017	(cond
1018	((> res 0) data)
1019	((= res 0) (thread-wait-for-i/o! conn-fd #:input) (loop))
1020	((= res -1) (get-last-result conn))
1021	((= res -2) (postgresql-error 'put-copy-data
1022	(conc "Error putting COPY data. "
1023	(PQerrorMessage conn-ptr))
1024	conn))
1025	(else (postgresql-error
1026	'get-copy-data
1027	(conc "Internal error! Unexpected return value: " res)
1028	conn))))))))
1029
1030	;;;;;;;;;;;;;;;;;;;;;;
1031	;;;; Value escaping
1032	;;;;;;;;;;;;;;;;;;;;;;
1033
1034	(define (escape-string conn str)
1035	(define %escape-string-conn
1036	;; This could be more efficient by copying straight into a Scheme object.
1037	;; Now it's being copied by PQescapeStringConn, and Chicken copies it again.
1038	;; This can allocate up to twice as much memory than the string actually
1039	;; uses; in extreme cases this could be a problem.
1040	(foreign-lambda* c-string* ((pgconn* conn) (c-string from) (int flen))
1041	"int err = 0; char *to;"
1042	"to = malloc(sizeof(char) * (flen * 2 + 1));"
1043	"PQescapeStringConn((PGconn *)conn, to, from, (size_t)flen, &err);"
1044	"if (err) {"
1045	" free(to);"
1046	" C_return(NULL);"
1047	"}"
1048	"C_return(to);"))
1049	(or (%escape-string-conn (pg-connection-ptr conn) str (string-length str))
1050	(postgresql-error 'escape-string
1051	(conc "String escaping failed. "
1052	(PQerrorMessage conn)) conn str)))
1053
1054	(define (escape-bytea conn str)
1055	(define %escape-bytea-conn
1056	;; This must copy because libpq returns a malloced ptr...
1057	(foreign-safe-lambda* scheme-object ((pgconn* conn)
1058	;; not copied/NUL interpreted:
1059	((const unsigned-c-string*) from)
1060	(int flen))
1061	"size_t tolen=0; C_word res, fin; unsigned char esc;"
1062	"esc = PQescapeByteaConn((PGconn *)conn, from, (size_t)flen, &tolen);"
1063	"if (esc == NULL)"
1064	" C_return(C_SCHEME_FALSE);"
1065	"fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
1066	"/* tolen includes the resulting NUL byte */"
1067	"res = C_string(&fin, tolen - 1, (char *)esc);"
1068	"PQfreemem(esc);"
1069	"C_return(res);"))
1070	(or (%escape-bytea-conn (pg-connection-ptr conn) str (string-length str))
1071	(postgresql-error 'escape-bytea
1072	(conc "Byte array escaping failed. "
1073	(PQerrorMessage conn)) conn str)))
1074
1075	(define (unescape-bytea str)
1076	(define %unescape-bytea
1077	;; This must copy because libpq returns a malloced ptr...
1078	(foreign-safe-lambda* scheme-object (((const unsigned-c-string*) from))
1079	"size_t tolen=0; C_word res, fin; unsigned char unesc;"
1080	"unesc = PQunescapeBytea(from, &tolen);"
1081	"if (unesc == NULL)"
1082	" C_return(C_SCHEME_FALSE);"
1083	"fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));"
1084	"res = C_string(&fin, tolen, (char *)unesc);"
1085	"PQfreemem(unesc);"
1086	"C_return(res);"
1087	))
1088	(or (%unescape-bytea str)
1089	(postgresql-error 'unescape-bytea
1090	"Byte array unescaping failed (out of memory?)" str)))
1091
1092
1093	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1094	;;;; High-level interface
1095	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1096
1097	(define (make-result-fold item-count extract-item)
1098	(lambda (kons knil result)
1099	(let ((items (item-count result)))
1100	(let loop ((seed knil)
1101	(item 0))
1102	(if (= item items)
1103	seed
1104	(loop (kons (extract-item result item) seed) (add1 item)))))))
1105
1106	(define row-fold (make-result-fold row-count row-values))
1107	(define (row-fold* kons knil result)
1108	(row-fold (lambda (values seed)
1109	(apply kons (append values (list seed)))) knil result))
1110
1111	(define column-fold (make-result-fold column-count column-values))
1112	(define (column-fold* kons knil result)
1113	(column-fold (lambda (values seed)
1114	(apply kons (append values (list seed)))) knil result))
1115
1116
1117	(define (make-result-fold-right item-count extract-item)
1118	(lambda (kons knil result)
1119	(let loop ((seed knil)
1120	(item (item-count result)))
1121	(if (= item 0)
1122	seed
1123	(loop (kons (extract-item result (sub1 item)) seed) (sub1 item))))))
1124
1125	(define row-fold-right (make-result-fold-right row-count row-values))
1126	(define (row-fold-right* kons knil result)
1127	(row-fold-right (lambda (values seed)
1128	(apply kons (append values (list seed)))) knil result))
1129
1130	(define column-fold-right (make-result-fold-right column-count column-values))
1131	(define (column-fold-right* kons knil result)
1132	(column-fold-right (lambda (values seed)
1133	(apply kons (append values (list seed)))) knil result))
1134
1135
1136	(define (row-for-each proc result)
1137	(row-fold (lambda (values seed) (proc values)) #f result)
1138	(void))
1139	(define (row-for-each* proc result)
1140	(row-fold (lambda (values seed) (apply proc values)) #f result)
1141	(void))
1142
1143	(define (column-for-each proc result)
1144	(column-fold (lambda (values seed) (proc values)) #f result)
1145	(void))
1146	(define (column-for-each* proc result)
1147	(column-fold (lambda (values seed) (apply proc values)) #f result)
1148	(void))
1149
1150	;; Like regular Scheme map, the order in which the procedure is applied is
1151	;; undefined. We make good use of that by traversing the resultset from
1152	;; the end back to the beginning, thereby avoiding a reverse! on the result.
1153	(define (row-map proc res)
1154	(row-fold-right (lambda (row lst) (cons (proc row) lst)) '() res))
1155	(define (row-map* proc res)
1156	(row-fold-right (lambda (row lst) (cons (apply proc row) lst)) '() res))
1157	(define (column-map proc res)
1158	(column-fold-right (lambda (col lst) (cons (proc col) lst)) '() res))
1159	(define (column-map* proc res)
1160	(column-fold-right (lambda (col lst) (cons (apply proc col) lst)) '() res))
1161
1162	(define (result-format result)
1163	(if (and result ((foreign-lambda bool PQbinaryTuples pgresult*)
1164	(pg-result-ptr result)))
1165	'binary 'text))
1166
1167	(define (copy-query*-fold kons knil conn query
1168	#!optional (params '()) #!key (format 'text) raw)
1169	(let* ((result (query* conn query params format: format raw: raw))
1170	(data-format (result-format result)))
1171	(handle-exceptions exn
1172	(let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1173	(let loop ((data (get-copy-data conn format: data-format))
1174	(seed knil))
1175	(if (result? data)
1176	seed
1177	;; Explicit ordering; data could be _very_ big, allow one to be GCed
1178	(let ((next (kons data seed)))
1179	(loop (get-copy-data conn format: data-format) next)))))))
1180
1181	(define (copy-query-fold kons knil conn query . params)
1182	(copy-query*-fold kons knil conn query params))
1183
1184
1185	;; This is slow and memory-intensive if data is big. Provided for completeness
1186	(define (copy-query*-fold-right kons knil conn query
1187	#!optional (params '()) #!key (format 'text) raw)
1188	(let* ((result (query* conn query params format: format raw: raw))
1189	(data-format (result-format result)))
1190	(handle-exceptions exn
1191	(let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
1192	(let loop ((data (get-copy-data conn format: data-format)))
1193	(if (result? data)
1194	knil
1195	(kons data (loop (get-copy-data conn format: data-format))))))))
1196
1197	(define (copy-query-fold-right kons knil conn query . params)
1198	(copy-query*-fold-right kons knil conn query params))
1199
1200
1201	(define (copy-query*-map proc conn query
1202	#!optional (params '()) #!key (format 'text) raw)
1203	(reverse! (copy-query*-fold (lambda (data seed) (cons (proc data) seed))
1204	'() conn query params format: format raw: raw)))
1205
1206	(define (copy-query-map proc conn query . params)
1207	(copy-query*-map proc conn query params))
1208
1209
1210	(define (copy-query*-for-each proc conn query
1211	#!optional (params '()) #!key (format 'text) raw)
1212	(copy-query*-fold (lambda (data seed) (proc data))
1213	#f conn query params format: format raw: raw)
1214	(void))
1215
1216	(define (copy-query-for-each proc conn query . params)
1217	(copy-query*-for-each proc conn query params))
1218
1219	;; A bit of a weird name but consistent
1220	(define (call-with-output-copy-query*
1221	proc conn query #!optional (params '()) #!key (format 'text) raw)
1222	(query* conn query params format: format raw: raw)
1223	(let* ((closed? #f)
1224	(output-port (make-output-port
1225	(lambda (data) (put-copy-data conn data))
1226	(lambda () (put-copy-end conn) (set! closed? #t)))))
1227	(handle-exceptions exn
1228	(if closed?
1229	(raise exn)
1230	(handle-exceptions _
1231	(raise exn)
1232	;; Previously written data will be discarded to guarantee atomicity
1233	(put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
1234	(call-with-values (lambda () (proc output-port))
1235	(lambda args
1236	(unless closed? (put-copy-end conn))
1237	(apply values args))))))
1238
1239	(define (call-with-output-copy-query proc conn query . params)
1240	(call-with-output-copy-query* proc conn query params))
1241
1242	(define (with-output-to-copy-query*
1243	thunk conn query #!optional (params '()) #!key (format 'text) raw)
1244	(call-with-output-copy-query* (lambda (x) (with-output-to-port x thunk))
1245	conn query params format: format raw: raw))
1246
1247	(define (with-output-to-copy-query thunk conn query . params)
1248	(with-output-to-copy-query* thunk conn query params))
1249
1250	)

Note: See TracBrowser for help on using the browser.

Context Navigation

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

Download in other formats: