Context Navigation

postgresql.scm @ 14766

Revision 14766, 29.8 KB (checked in by sjamaan, 16 months ago)
Change interface so it's more sql-de-lite-like, because it's more flexible (now one can map high-level style through a result even while obtaining other data from the same result)

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

Note: See TracBrowser for help on using the browser.

Context Navigation

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

Download in other formats: