Context Navigation

postgresql.scm @ 14761

Revision 14761, 32.8 KB (checked in by sjamaan, 16 months ago)
Fix the comment about simplified alist version

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

Note: See TracBrowser for help on using the browser.

Context Navigation

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

Download in other formats: