1 | ;;;; sqlite3.scm |
---|
2 | ;;;; :tabSize=2:indentSize=2:noTabs=true: |
---|
3 | ;;;; bindings to the SQLite3 database library |
---|
4 | |
---|
5 | ;; Notes |
---|
6 | ;; |
---|
7 | ;; - Due to 'usual-integrations' the 'string-length' procedure is rewritten |
---|
8 | ;; to the "core" implementation. So even if the utf-8 module is "imported" |
---|
9 | ;; into the top-level a byte length will result. |
---|
10 | |
---|
11 | (declare |
---|
12 | (usual-integrations) |
---|
13 | (fixnum-arithmetic) |
---|
14 | (no-procedure-checks-for-usual-bindings) |
---|
15 | (unused |
---|
16 | ; Stop annoying messages |
---|
17 | sqlite3#chicken_sqlite3_function_stub |
---|
18 | sqlite3#chicken_sqlite3_collation_stub |
---|
19 | sqlite3#chicken_sqlite3_final_stub |
---|
20 | sqlite3#chicken_sqlite3_step_stub |
---|
21 | ; These may have to be changed if definitions are added, |
---|
22 | ; removed or reordered: |
---|
23 | sqlite3#g166 sqlite3#g366 sqlite3#g484 sqlite3#g570) |
---|
24 | (bound-to-procedure |
---|
25 | ##sys#expand-home-path |
---|
26 | sqlite3#sqlite3_errmsg)) |
---|
27 | |
---|
28 | #>#include <sqlite3.h><# |
---|
29 | |
---|
30 | (module sqlite3 |
---|
31 | ( ;; type predicates and checks |
---|
32 | database? |
---|
33 | error-database |
---|
34 | check-database |
---|
35 | statement? |
---|
36 | error-statement |
---|
37 | check-statement |
---|
38 | ;; procedures |
---|
39 | open-database |
---|
40 | define-collation |
---|
41 | define-function |
---|
42 | set-busy-handler! |
---|
43 | make-busy-timeout |
---|
44 | interrupt! |
---|
45 | auto-committing? |
---|
46 | change-count |
---|
47 | last-insert-rowid |
---|
48 | finalize! |
---|
49 | prepare |
---|
50 | repair! |
---|
51 | reset! |
---|
52 | bind-parameter-count |
---|
53 | bind-parameter-index |
---|
54 | bind-parameter-name |
---|
55 | bind! |
---|
56 | bind-parameters! |
---|
57 | step! |
---|
58 | column-count |
---|
59 | column-type |
---|
60 | column-declared-type |
---|
61 | column-name |
---|
62 | column-data |
---|
63 | call-with-temporary-statements |
---|
64 | execute |
---|
65 | update |
---|
66 | first-result |
---|
67 | first-row |
---|
68 | fold-row |
---|
69 | for-each-row |
---|
70 | map-row |
---|
71 | with-transaction |
---|
72 | sql-complete? |
---|
73 | database-version |
---|
74 | database-memory-used |
---|
75 | database-memory-highwater |
---|
76 | enable-shared-cache! |
---|
77 | ) |
---|
78 | |
---|
79 | (import scheme chicken foreign) |
---|
80 | |
---|
81 | (use |
---|
82 | srfi-1 srfi-13 srfi-18 srfi-69 |
---|
83 | data-structures extras lolevel |
---|
84 | type-errors type-checks synch miscmacros matchable sql-null) |
---|
85 | |
---|
86 | ;;; Foreign types & values |
---|
87 | |
---|
88 | ;; Enumeration and constant definitions |
---|
89 | |
---|
90 | (define-syntax %define-enum-type |
---|
91 | (syntax-rules () |
---|
92 | [(%define-enum-type (sname cname) (sv cv) ...) |
---|
93 | (define-foreign-type sname |
---|
94 | (enum cname) |
---|
95 | (lambda (v) |
---|
96 | (case v |
---|
97 | [(sv) (foreign-value cv int)] |
---|
98 | ... |
---|
99 | [else |
---|
100 | (error-argument-type 'sname v "enumeration value")])) |
---|
101 | (lambda (v) |
---|
102 | (select v |
---|
103 | [((foreign-value cv int)) 'sv] |
---|
104 | ... |
---|
105 | [else |
---|
106 | (error-argument-type 'sname v "enumeration index")])))])) |
---|
107 | |
---|
108 | (%define-enum-type (sqlite3:status "sqlite3_status") |
---|
109 | (#f "SQLITE_OK") ; Successful result |
---|
110 | (error "SQLITE_ERROR") ; SQL error or missing database |
---|
111 | (internal "SQLITE_INTERNAL") ; NOT USED. Internal logic error in SQLite |
---|
112 | (permission "SQLITE_PERM") ; Access permission denied |
---|
113 | (abort "SQLITE_ABORT") ; Callback routine requested an abort |
---|
114 | (busy "SQLITE_BUSY") ; The database file is locked |
---|
115 | (locked "SQLITE_LOCKED") ; A table in the database is locked |
---|
116 | (no-memory "SQLITE_NOMEM") ; A malloc() failed |
---|
117 | (read-only "SQLITE_READONLY") ; Attempt to write a readonly database |
---|
118 | (interrupt "SQLITE_INTERRUPT") ; Operation terminated by sqlite3_interrupt() |
---|
119 | (io-error "SQLITE_IOERR") ; Some kind of disk I/O error occurred |
---|
120 | (corrupt "SQLITE_CORRUPT") ; The database disk image is malformed |
---|
121 | (not-found "SQLITE_NOTFOUND") ; NOT USED. Table or record not found |
---|
122 | (full "SQLITE_FULL") ; Insertion failed because database is full |
---|
123 | (cant-open "SQLITE_CANTOPEN") ; Unable to open the database file |
---|
124 | (protocol "SQLITE_PROTOCOL") ; NOT USED. Database lock protocol error |
---|
125 | (empty "SQLITE_EMPTY") ; Database is empty |
---|
126 | (schema "SQLITE_SCHEMA") ; The database schema changed |
---|
127 | (too-big "SQLITE_TOOBIG") ; String or BLOB exceeds size limit |
---|
128 | (constraint "SQLITE_CONSTRAINT") ; Abort due to contraint violation |
---|
129 | (mismatch "SQLITE_MISMATCH") ; Data type mismatch |
---|
130 | (misuse "SQLITE_MISUSE") ; Library used incorrectly |
---|
131 | (no-lfs "SQLITE_NOLFS") ; Uses OS features not supported on host |
---|
132 | (authorization "SQLITE_AUTH") ; Authorization denied |
---|
133 | (format "SQLITE_FORMAT") ; Auxiliary database format error |
---|
134 | (range "SQLITE_RANGE") ; 2nd parameter to sqlite3_bind out of range |
---|
135 | (not-a-database "SQLITE_NOTADB") ; File opened that is not a database file |
---|
136 | (row "SQLITE_ROW") ; sqlite3_step() has another row ready |
---|
137 | (done "SQLITE_DONE")) ; sqlite3_step() has finished executing |
---|
138 | |
---|
139 | (%define-enum-type (sqlite3:type "sqlite3_type") |
---|
140 | (integer "SQLITE_INTEGER") |
---|
141 | (float "SQLITE_FLOAT") |
---|
142 | (text "SQLITE_TEXT") |
---|
143 | (blob "SQLITE_BLOB") |
---|
144 | (null "SQLITE_NULL")) |
---|
145 | |
---|
146 | ;; Auxiliary types |
---|
147 | |
---|
148 | (define-foreign-type sqlite3:context |
---|
149 | (c-pointer "sqlite3_context")) |
---|
150 | |
---|
151 | (define-foreign-type sqlite3:value |
---|
152 | (c-pointer "sqlite3_value")) |
---|
153 | |
---|
154 | ;; Types for databases and statements |
---|
155 | |
---|
156 | (define-record-type sqlite3:database |
---|
157 | (make-database ptr busy-handler) |
---|
158 | database? |
---|
159 | (ptr database-ptr database-ptr-set!) |
---|
160 | (busy-handler database-busy-handler database-busy-handler-set!)) |
---|
161 | |
---|
162 | (define-record-printer (sqlite3:database db out) |
---|
163 | (display |
---|
164 | (if (database-ptr db) |
---|
165 | "#<sqlite3:database>" |
---|
166 | "#<sqlite3:database zombie>") |
---|
167 | out)) |
---|
168 | |
---|
169 | (define-check+error-type database) |
---|
170 | |
---|
171 | (define-foreign-type sqlite3:database |
---|
172 | (nonnull-c-pointer "sqlite3") |
---|
173 | database-ptr |
---|
174 | (cut make-database <> #f)) |
---|
175 | |
---|
176 | (define-record-type sqlite3:statement |
---|
177 | (make-statement ptr database sql) |
---|
178 | statement? |
---|
179 | (ptr statement-ptr statement-ptr-set!) |
---|
180 | (database statement-database) |
---|
181 | (sql statement-sql)) |
---|
182 | |
---|
183 | (define-record-printer (sqlite3:statement stmt out) |
---|
184 | (display |
---|
185 | (if (statement-ptr stmt) |
---|
186 | (sprintf "#<sqlite3:statement sql=~s>" (statement-sql stmt)) |
---|
187 | "#<sqlite3:statement zombie>") |
---|
188 | out)) |
---|
189 | |
---|
190 | (define-check+error-type statement) |
---|
191 | |
---|
192 | (define-foreign-type sqlite3:statement |
---|
193 | (nonnull-c-pointer "sqlite3_stmt") |
---|
194 | statement-ptr |
---|
195 | (cut make-statement <> #f #f)) |
---|
196 | |
---|
197 | ;;; Helpers |
---|
198 | |
---|
199 | ;; Conditions |
---|
200 | |
---|
201 | (define (make-exn-condition loc msg . args) |
---|
202 | (make-property-condition 'exn 'location loc 'message msg 'arguments args)) |
---|
203 | |
---|
204 | (define (make-sqlite3-condition sta) |
---|
205 | (make-property-condition 'sqlite3 'status sta)) |
---|
206 | |
---|
207 | (define (make-sqlite3-error-condition loc msg sta . args) |
---|
208 | (make-composite-condition |
---|
209 | (apply make-exn-condition loc msg args) |
---|
210 | (make-sqlite3-condition sta))) |
---|
211 | |
---|
212 | (define (make-no-data-condition loc stmt params) |
---|
213 | (make-sqlite3-error-condition loc |
---|
214 | "the statement returned no data" |
---|
215 | 'done |
---|
216 | stmt params)) |
---|
217 | |
---|
218 | ;; Errors |
---|
219 | (define ((abort-sqlite3-error loc db . args) sta) |
---|
220 | (abort |
---|
221 | (apply make-sqlite3-error-condition |
---|
222 | loc |
---|
223 | (if db (sqlite3_errmsg db) (symbol->string sta)) |
---|
224 | sta |
---|
225 | args))) |
---|
226 | |
---|
227 | (define (print-error msg obj) |
---|
228 | (print-error-message obj (current-error-port) (string-append "Error: " msg))) |
---|
229 | |
---|
230 | ;; Tree dictionary |
---|
231 | |
---|
232 | (define (make-hash-table-tree/synch id . args) |
---|
233 | (make-object/synch (apply make-hash-table args) id)) |
---|
234 | |
---|
235 | (define (hash-table-tree-set! ht-tree keys value) |
---|
236 | (if (null? (cdr keys)) |
---|
237 | (hash-table-set! ht-tree (car keys) value) |
---|
238 | (hash-table-update! ht-tree |
---|
239 | (car keys) |
---|
240 | (cute hash-table-tree-set! <> (cdr keys) value) |
---|
241 | (cut make-hash-table))) |
---|
242 | ht-tree) |
---|
243 | |
---|
244 | (define (hash-table-tree-delete! ht-tree keys) |
---|
245 | (if (null? (cdr keys)) |
---|
246 | (hash-table-delete! ht-tree (car keys)) |
---|
247 | (hash-table-update! ht-tree |
---|
248 | (car keys) |
---|
249 | (cute hash-table-tree-delete! <> (cdr keys)) |
---|
250 | (cut make-hash-table))) |
---|
251 | ht-tree) |
---|
252 | |
---|
253 | (define (hash-table-tree-ref |
---|
254 | ht-tree keys |
---|
255 | #!optional |
---|
256 | (thunk (cut abort |
---|
257 | (make-composite-condition |
---|
258 | (make-exn-condition 'hash-table-tree-ref |
---|
259 | "hash-table-tree does not contain path" |
---|
260 | ht-tree keys) |
---|
261 | (make-property-condition 'access))))) |
---|
262 | (let/cc return |
---|
263 | (let loop ([ht ht-tree] [keys keys]) |
---|
264 | (if (null? keys) |
---|
265 | ht |
---|
266 | (loop (hash-table-ref ht (car keys) (cut return (thunk))) |
---|
267 | (cdr keys)))))) |
---|
268 | |
---|
269 | (define (hash-table-tree-ref/default ht-tree keys default) |
---|
270 | (hash-table-tree-ref ht-tree keys (lambda () default))) |
---|
271 | |
---|
272 | (define (hash-table-tree-clear! htt id elt-clear) |
---|
273 | (cond [(hash-table-ref/default htt id #f) |
---|
274 | => (cute hash-table-walk <> elt-clear)]) |
---|
275 | (hash-table-delete! htt id)) |
---|
276 | |
---|
277 | ;; SQL collation sequence interface |
---|
278 | |
---|
279 | (define *collations* (make-hash-table-tree/synch 'sqlite3:collations)) |
---|
280 | |
---|
281 | (define-external (chicken_sqlite3_collation_stub |
---|
282 | (scheme-object qn) (int la) |
---|
283 | (c-pointer da) (int lb) |
---|
284 | (c-pointer db)) int |
---|
285 | (let/cc return |
---|
286 | (let ([r #f]) |
---|
287 | (dynamic-wind |
---|
288 | noop |
---|
289 | (lambda () |
---|
290 | (handle-exceptions exn |
---|
291 | (print-error "in collation function" exn) |
---|
292 | (let ([a (make-string la)] |
---|
293 | [b (make-string lb)]) |
---|
294 | (move-memory! da a la) |
---|
295 | (move-memory! db b lb) |
---|
296 | (set! r |
---|
297 | ((vector-ref |
---|
298 | (call-with/synch *collations* |
---|
299 | (cute hash-table-tree-ref <> qn)) |
---|
300 | 1) |
---|
301 | a b))))) |
---|
302 | (lambda () |
---|
303 | (if (fixnum? r) |
---|
304 | (return r) |
---|
305 | (begin |
---|
306 | (print-error "in collation function: invalid return value" (->string r)) |
---|
307 | (return 0)))))))) |
---|
308 | |
---|
309 | (define sqlite3_create_collation |
---|
310 | (foreign-lambda* sqlite3:status |
---|
311 | ((sqlite3:database db) (c-string name) (scheme-object qn)) |
---|
312 | #<<EOS |
---|
313 | if (qn == C_SCHEME_FALSE) |
---|
314 | return(sqlite3_create_collation(db, name, SQLITE_UTF8, NULL, NULL)); |
---|
315 | else |
---|
316 | return(sqlite3_create_collation(db, name, SQLITE_UTF8, |
---|
317 | (void *)qn, |
---|
318 | (int (*)(void *, |
---|
319 | int, const void *, |
---|
320 | int, const void *)) |
---|
321 | &chicken_sqlite3_collation_stub)); |
---|
322 | EOS |
---|
323 | )) |
---|
324 | |
---|
325 | (define (define-collation db name #!optional proc) |
---|
326 | (check-database 'define-collation db) |
---|
327 | (check-string 'define-collation name) |
---|
328 | (if proc |
---|
329 | (begin |
---|
330 | (check-procedure 'define-collation proc) |
---|
331 | (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))]) |
---|
332 | (cond |
---|
333 | [(sqlite3_create_collation db name qn) |
---|
334 | => (lambda (s) |
---|
335 | (object-release qn) |
---|
336 | ((abort-sqlite3-error 'define-collation db name proc) s))] |
---|
337 | [else |
---|
338 | (call-with/synch *collations* |
---|
339 | (cute hash-table-tree-set! <> qn (vector qn proc)))]))) |
---|
340 | (cond |
---|
341 | [(sqlite3_create_collation db name #f) |
---|
342 | => (abort-sqlite3-error 'define-collation db name)] |
---|
343 | [else |
---|
344 | (let ([qn (list (pointer->address (database-ptr db)) name)]) |
---|
345 | (call-with/synch *collations* |
---|
346 | (lambda (col) |
---|
347 | (cond [(hash-table-tree-ref/default col qn #f) |
---|
348 | => (lambda (info) |
---|
349 | (hash-table-tree-delete! col qn) |
---|
350 | (object-release (vector-ref info 0)))]))))]))) |
---|
351 | |
---|
352 | ;;; SQL function interface |
---|
353 | |
---|
354 | (define *functions* (make-hash-table-tree/synch 'sqlite3:functions)) |
---|
355 | |
---|
356 | (define *seeds* (make-hash-table-tree/synch 'sqlite3:seeds)) |
---|
357 | |
---|
358 | (define (parameter-data n args) |
---|
359 | (let loop ([i 0]) |
---|
360 | (if (<= n i) |
---|
361 | '() |
---|
362 | (cons (case ((foreign-lambda* sqlite3:type |
---|
363 | (((c-pointer sqlite3:value) args) (int i)) |
---|
364 | "return(sqlite3_value_type(args[i]));") |
---|
365 | args i) |
---|
366 | [(integer) |
---|
367 | ((foreign-lambda* integer |
---|
368 | (((c-pointer sqlite3:value) args) (int i)) |
---|
369 | "return(sqlite3_value_double(args[i]));") |
---|
370 | args i)] |
---|
371 | [(float) |
---|
372 | ((foreign-lambda* double |
---|
373 | (((c-pointer sqlite3:value) args) (int i)) |
---|
374 | "return(sqlite3_value_double(args[i]));") |
---|
375 | args i)] |
---|
376 | [(text) |
---|
377 | ((foreign-primitive scheme-object |
---|
378 | (((c-pointer sqlite3:value) args) (int i)) |
---|
379 | "int n = sqlite3_value_bytes(args[i]);" |
---|
380 | "C_word *s = C_alloc(C_SIZEOF_STRING(n));" |
---|
381 | "return(C_string(&s, n, (char *)sqlite3_value_text(args[i])));") |
---|
382 | args i)] |
---|
383 | [(blob) |
---|
384 | ((foreign-primitive scheme-object |
---|
385 | (((c-pointer sqlite3:value) args) (int i)) |
---|
386 | "int n = sqlite3_value_bytes(args[i]);" |
---|
387 | "C_word *s = C_alloc(C_SIZEOF_STRING(n));" |
---|
388 | "return(C_bytevector(&s, n, (char *)sqlite3_value_blob(args[i])));") |
---|
389 | args i)] |
---|
390 | [else |
---|
391 | (sql-null)]) |
---|
392 | (loop (add1 i)))))) |
---|
393 | |
---|
394 | (define (set-result! ctx v) |
---|
395 | (cond |
---|
396 | [(blob? v) |
---|
397 | ((foreign-lambda* void |
---|
398 | ((sqlite3:context ctx) (scheme-pointer v) (int n)) |
---|
399 | "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);") |
---|
400 | ctx v (blob-size v))] |
---|
401 | [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0))) |
---|
402 | => (lambda (v) |
---|
403 | ((foreign-lambda void "sqlite3_result_int" sqlite3:context int) |
---|
404 | ctx v))] |
---|
405 | [(real? v) |
---|
406 | ((foreign-lambda void "sqlite3_result_double" sqlite3:context double) |
---|
407 | ctx v)] |
---|
408 | [(string? v) |
---|
409 | ((foreign-lambda* void |
---|
410 | ((sqlite3:context ctx) (scheme-pointer v) (int n)) |
---|
411 | "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);") |
---|
412 | ctx v (string-length v))] |
---|
413 | [(sql-null? v) |
---|
414 | ((foreign-lambda void "sqlite3_result_null" sqlite3:context) |
---|
415 | ctx)] |
---|
416 | [else |
---|
417 | (error-argument-type 'set-result! v "blob, number, boolean, string or sql-null")])) |
---|
418 | |
---|
419 | (define sqlite3_user_data |
---|
420 | (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context)) |
---|
421 | |
---|
422 | (define-external (chicken_sqlite3_function_stub |
---|
423 | (c-pointer ctx) (int n) (c-pointer args)) void |
---|
424 | (let/cc return |
---|
425 | (dynamic-wind |
---|
426 | noop |
---|
427 | (lambda () |
---|
428 | (handle-exceptions exn |
---|
429 | (print-error "in SQL function" exn) |
---|
430 | (set-result! |
---|
431 | ctx |
---|
432 | (apply (vector-ref |
---|
433 | (call-with/synch *functions* |
---|
434 | (cute hash-table-tree-ref <> (sqlite3_user_data ctx))) |
---|
435 | 1) |
---|
436 | (parameter-data n args))))) |
---|
437 | (lambda () |
---|
438 | (return (void)))))) |
---|
439 | |
---|
440 | (define sqlite3_aggregate_context |
---|
441 | (foreign-lambda* integer ((sqlite3:context ctx)) |
---|
442 | "return((int)sqlite3_aggregate_context(ctx, 1));")) |
---|
443 | |
---|
444 | (define-external (chicken_sqlite3_step_stub |
---|
445 | (c-pointer ctx) (int n) (c-pointer args)) void |
---|
446 | (let/cc return |
---|
447 | (dynamic-wind |
---|
448 | noop |
---|
449 | (lambda () |
---|
450 | (handle-exceptions exn |
---|
451 | (print-error "in step of SQL function" exn) |
---|
452 | (let ([info (call-with/synch *functions* |
---|
453 | (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))]) |
---|
454 | (call-with/synch *seeds* |
---|
455 | (cute hash-table-update!/default |
---|
456 | <> |
---|
457 | (sqlite3_aggregate_context ctx) |
---|
458 | (lambda (seed) |
---|
459 | (apply (vector-ref info 1) seed (parameter-data n args))) |
---|
460 | (vector-ref info 2)))))) |
---|
461 | (lambda () |
---|
462 | (return (void)))))) |
---|
463 | |
---|
464 | (define-external (chicken_sqlite3_final_stub (c-pointer ctx)) |
---|
465 | void |
---|
466 | (let/cc return |
---|
467 | (let ([agc (sqlite3_aggregate_context ctx)]) |
---|
468 | (dynamic-wind |
---|
469 | noop |
---|
470 | (lambda () |
---|
471 | (handle-exceptions exn |
---|
472 | (print-error "in final of SQL function" exn) |
---|
473 | (let ([info (call-with/synch *functions* |
---|
474 | (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))]) |
---|
475 | (cond |
---|
476 | [((vector-ref info 3) |
---|
477 | (call-with/synch *seeds* |
---|
478 | (cute hash-table-ref/default <> agc (vector-ref info 2)))) |
---|
479 | => (cute set-result! ctx <>)] |
---|
480 | [else |
---|
481 | (set-result! ctx (sql-null))])))) |
---|
482 | (lambda () |
---|
483 | (call-with/synch *seeds* |
---|
484 | (cute hash-table-delete! <> agc)) |
---|
485 | (return (void))))))) |
---|
486 | |
---|
487 | (define define-function |
---|
488 | (case-lambda |
---|
489 | [(db name n proc) |
---|
490 | (check-database 'define-function db) |
---|
491 | (check-string 'define-function name) |
---|
492 | (check-cardinal-number 'define-function n) |
---|
493 | (check-procedure 'define-function proc) |
---|
494 | (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))]) |
---|
495 | (cond |
---|
496 | [((foreign-lambda* sqlite3:status |
---|
497 | ((sqlite3:database db) |
---|
498 | (c-string name) (int n) (scheme-object qn)) |
---|
499 | #<<EOS |
---|
500 | return(sqlite3_create_function(db, name, n, SQLITE_UTF8, |
---|
501 | (void *)qn, |
---|
502 | (void (*)(sqlite3_context *, int, |
---|
503 | sqlite3_value **)) |
---|
504 | &chicken_sqlite3_function_stub, |
---|
505 | NULL, |
---|
506 | NULL)); |
---|
507 | EOS |
---|
508 | ) |
---|
509 | db name n qn) |
---|
510 | => (lambda (s) |
---|
511 | (object-release qn) |
---|
512 | ((abort-sqlite3-error 'define-function db name n proc) s))] |
---|
513 | [else |
---|
514 | (call-with/synch *functions* |
---|
515 | (cute hash-table-tree-set! <> qn (vector qn proc)))]))] |
---|
516 | [(db name n step-proc seed . final-proc) |
---|
517 | (check-database 'define-function db) |
---|
518 | (check-string 'define-function name) |
---|
519 | (check-cardinal-number 'define-function n) |
---|
520 | (let ([final-proc (optional final-proc identity)]) |
---|
521 | (check-procedure 'define-function step-proc) |
---|
522 | (check-procedure 'define-function final-proc) |
---|
523 | (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))]) |
---|
524 | (cond |
---|
525 | [((foreign-lambda* sqlite3:status |
---|
526 | ((sqlite3:database db) |
---|
527 | (c-string name) (int n) (scheme-object qn)) |
---|
528 | #<<EOS |
---|
529 | return(sqlite3_create_function(db, name, n, SQLITE_UTF8, |
---|
530 | (void *)qn, |
---|
531 | NULL, |
---|
532 | (void (*)(sqlite3_context *, |
---|
533 | int, sqlite3_value **)) |
---|
534 | &chicken_sqlite3_step_stub, |
---|
535 | (void (*)(sqlite3_context *)) |
---|
536 | &chicken_sqlite3_final_stub)); |
---|
537 | EOS |
---|
538 | ) |
---|
539 | db name n qn) |
---|
540 | => (lambda (s) |
---|
541 | (object-release qn) |
---|
542 | ((abort-sqlite3-error |
---|
543 | 'define-function db name n step-proc seed final-proc) s))] |
---|
544 | [else |
---|
545 | (call-with/synch *functions* |
---|
546 | (cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))])))])) |
---|
547 | |
---|
548 | ;;; Database interface |
---|
549 | |
---|
550 | ;; Get any error message |
---|
551 | (define sqlite3_errmsg |
---|
552 | (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database)) |
---|
553 | |
---|
554 | ;; Open a database |
---|
555 | (define (open-database path) |
---|
556 | (check-string 'open-database path) |
---|
557 | (let-location ([db c-pointer]) |
---|
558 | (cond |
---|
559 | [((foreign-lambda sqlite3:status "sqlite3_open" |
---|
560 | nonnull-c-string (c-pointer sqlite3:database)) |
---|
561 | (##sys#expand-home-path path) #$db) |
---|
562 | => (abort-sqlite3-error 'open-database #f path)] |
---|
563 | [else |
---|
564 | (make-database db #f)]))) |
---|
565 | |
---|
566 | ;; Set application busy handler. Does not use a callback, so it is safe |
---|
567 | ;; to yield. Handler is called with DB, COUNT and LAST (the last value |
---|
568 | ;; it returned). Return true value to continue trying, or #f to stop. |
---|
569 | (define (set-busy-handler! db handler) |
---|
570 | (check-database 'set-busy-handler! db) |
---|
571 | (database-busy-handler-set! db handler)) |
---|
572 | |
---|
573 | ;; Returns a closure suitable for use with set-busy-handler!. Identical |
---|
574 | ;; to sqlite's default busy handler, but does not block. |
---|
575 | (define (make-busy-timeout timeout) |
---|
576 | (define (thread-sleep!/ms ms) |
---|
577 | (thread-sleep! |
---|
578 | (milliseconds->time (+ ms (current-milliseconds))))) |
---|
579 | (let* ([delays '#(1 2 5 10 15 20 25 25 25 50 50 100)] |
---|
580 | [totals '#(0 1 3 8 18 33 53 78 103 128 178 228)] |
---|
581 | [ndelay (vector-length delays)]) |
---|
582 | (lambda (db count) |
---|
583 | (let* ([delay (vector-ref delays (min count (- ndelay 1)))] |
---|
584 | [prior (if (< count ndelay) |
---|
585 | (vector-ref totals count) |
---|
586 | (+ (vector-ref totals (- ndelay 1)) |
---|
587 | (* delay (- count (- ndelay 1)))))]) |
---|
588 | (let ([delay (if (> (+ prior delay) timeout) |
---|
589 | (- timeout prior) |
---|
590 | delay)]) |
---|
591 | (cond |
---|
592 | [(<= delay 0) #f] |
---|
593 | [else |
---|
594 | (thread-sleep!/ms delay) |
---|
595 | #t])))))) |
---|
596 | |
---|
597 | ;; Cancel any running database operation as soon as possible |
---|
598 | (define (interrupt! db) |
---|
599 | (check-database 'interrupt! db) |
---|
600 | ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db)) |
---|
601 | |
---|
602 | ;; Check whether the database is in autocommit mode |
---|
603 | (define (auto-committing? db) |
---|
604 | (check-database 'auto-committing? db) |
---|
605 | ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db)) |
---|
606 | |
---|
607 | ;; Get the number of changes made to the database |
---|
608 | (define (change-count db #!optional (total #f)) |
---|
609 | (check-database 'change-count db) |
---|
610 | (if total |
---|
611 | ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db) |
---|
612 | ((foreign-lambda number "sqlite3_changes" sqlite3:database) db))) |
---|
613 | |
---|
614 | ;; Get the row ID of the last inserted row |
---|
615 | (define (last-insert-rowid db) |
---|
616 | (check-database 'last-insert-rowid db) |
---|
617 | ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db)) |
---|
618 | |
---|
619 | ;; Close a database or statement handle |
---|
620 | (define finalize! |
---|
621 | (match-lambda |
---|
622 | [(? database? db) |
---|
623 | (cond |
---|
624 | [(not (database-ptr db)) |
---|
625 | (void)] |
---|
626 | [((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db) |
---|
627 | => (abort-sqlite3-error 'finalize! db db)] |
---|
628 | [else |
---|
629 | (let ([id (pointer->address (database-ptr db))] |
---|
630 | [release-qns (lambda (_ info) (object-release (vector-ref info 0)))]) |
---|
631 | (call-with/synch *collations* |
---|
632 | (cute hash-table-tree-clear! <> id release-qns)) |
---|
633 | (call-with/synch *functions* |
---|
634 | (cute hash-table-tree-clear! <> id release-qns))) |
---|
635 | (database-ptr-set! db #f) |
---|
636 | (database-busy-handler-set! db #f)])] |
---|
637 | [(? statement? stmt) |
---|
638 | (cond |
---|
639 | [(not (statement-ptr stmt)) |
---|
640 | (void)] |
---|
641 | [((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt) |
---|
642 | => (abort-sqlite3-error 'finalize! (statement-database stmt) stmt)] |
---|
643 | [else |
---|
644 | (statement-ptr-set! stmt #f)])])) |
---|
645 | |
---|
646 | ;;; Statement interface |
---|
647 | |
---|
648 | ;; Create a new statement |
---|
649 | (define (prepare db sql) |
---|
650 | (check-database 'prepare db) |
---|
651 | (check-string 'prepare sql) |
---|
652 | (let retry ([retries 0]) |
---|
653 | (let-location ([stmt c-pointer] [tail c-string]) |
---|
654 | (cond |
---|
655 | [((foreign-safe-lambda sqlite3:status "sqlite3_prepare" |
---|
656 | sqlite3:database scheme-pointer int |
---|
657 | (c-pointer sqlite3:statement) |
---|
658 | (c-pointer (const c-string))) |
---|
659 | db (string-append sql "\x00") (string-length sql) #$stmt #$tail) |
---|
660 | => (lambda (err) |
---|
661 | (case err |
---|
662 | [(busy) |
---|
663 | (let ([h (database-busy-handler db)]) |
---|
664 | (cond |
---|
665 | [(and h (h db retries)) |
---|
666 | (retry (add1 retries))] |
---|
667 | [else |
---|
668 | ((abort-sqlite3-error 'prepare db db sql) err)]))] |
---|
669 | [else |
---|
670 | ((abort-sqlite3-error 'prepare db db sql) err)]))] |
---|
671 | [else |
---|
672 | (values |
---|
673 | (make-statement stmt db sql) |
---|
674 | tail)])))) |
---|
675 | |
---|
676 | ;; Recompile an existing statement and transfer all bindings |
---|
677 | (define (repair! stmt) |
---|
678 | (check-statement 'repair! stmt) |
---|
679 | (let ([fresh (prepare |
---|
680 | (statement-database stmt) |
---|
681 | (statement-sql stmt))]) |
---|
682 | (dynamic-wind |
---|
683 | noop |
---|
684 | (lambda () |
---|
685 | (let ([old (statement-ptr stmt)] |
---|
686 | [new (statement-ptr fresh)]) |
---|
687 | (cond |
---|
688 | [((foreign-lambda sqlite3:status "sqlite3_transfer_bindings" |
---|
689 | c-pointer c-pointer) |
---|
690 | old new) |
---|
691 | => (abort-sqlite3-error 'repair! (statement-database stmt) stmt)] |
---|
692 | [else |
---|
693 | (statement-ptr-set! stmt new) |
---|
694 | (statement-ptr-set! fresh old)]))) |
---|
695 | (lambda () |
---|
696 | (finalize! fresh))))) |
---|
697 | |
---|
698 | ;; Reset an existing statement to process it again |
---|
699 | (define sqlite3_reset |
---|
700 | (foreign-lambda sqlite3:status "sqlite3_reset" sqlite3:statement)) |
---|
701 | |
---|
702 | (define (reset! stmt) |
---|
703 | (check-statement 'reset! stmt) |
---|
704 | (cond [(sqlite3_reset stmt) |
---|
705 | => (abort-sqlite3-error 'reset! (statement-database stmt) stmt)])) |
---|
706 | |
---|
707 | ;; Get number of bindable parameters |
---|
708 | (define (bind-parameter-count stmt) |
---|
709 | (check-statement 'bind-parameter-count stmt) |
---|
710 | ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt)) |
---|
711 | |
---|
712 | ;; Get index of a bindable parameter or #f if no parameter with the |
---|
713 | ;; given name exists |
---|
714 | (define (bind-parameter-index stmt name) |
---|
715 | (check-statement 'bind-parameter-index stmt) |
---|
716 | (let ([i ((foreign-lambda int "sqlite3_bind_parameter_index" |
---|
717 | sqlite3:statement nonnull-c-string) |
---|
718 | stmt name)]) |
---|
719 | (if (zero? i) |
---|
720 | #f |
---|
721 | (sub1 i)))) |
---|
722 | |
---|
723 | ;; Get the name of a bindable parameter |
---|
724 | (define (bind-parameter-name stmt i) |
---|
725 | (check-statement 'bind-parameter-name stmt) |
---|
726 | ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int) |
---|
727 | stmt (add1 i))) |
---|
728 | |
---|
729 | ;; Bind data as parameters to an existing statement |
---|
730 | |
---|
731 | (define (bind! stmt i v) |
---|
732 | (check-statement 'bind! stmt) |
---|
733 | (check-cardinal-integer 'bind! i) |
---|
734 | (cond |
---|
735 | [(blob? v) |
---|
736 | (cond [((foreign-lambda* sqlite3:status |
---|
737 | ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n)) |
---|
738 | "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));") |
---|
739 | stmt (add1 i) v (blob-size v)) |
---|
740 | => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])] |
---|
741 | [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0))) |
---|
742 | => (lambda (v) |
---|
743 | (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int" |
---|
744 | sqlite3:statement int int) |
---|
745 | stmt (add1 i) v) |
---|
746 | => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))] |
---|
747 | [(real? v) |
---|
748 | (cond [((foreign-lambda sqlite3:status "sqlite3_bind_double" |
---|
749 | sqlite3:statement int double) |
---|
750 | stmt (add1 i) v) |
---|
751 | => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])] |
---|
752 | [(string? v) |
---|
753 | (cond [((foreign-lambda* sqlite3:status |
---|
754 | ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n)) |
---|
755 | "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));") |
---|
756 | stmt (add1 i) v (string-length v)) |
---|
757 | => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])] |
---|
758 | [(sql-null? v) |
---|
759 | (cond [((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) |
---|
760 | stmt (add1 i)) |
---|
761 | => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i)])] |
---|
762 | [else |
---|
763 | (error-argument-type 'bind! v "blob, number, boolean, string or sql-null")])) |
---|
764 | |
---|
765 | ; Helper |
---|
766 | |
---|
767 | (define (%bind-parameters! loc stmt params) |
---|
768 | (reset! stmt) |
---|
769 | (let ([cnt (bind-parameter-count stmt)] |
---|
770 | [vs (make-hash-table)]) |
---|
771 | (let loop ([i 0] [params params]) |
---|
772 | (match params |
---|
773 | [((? keyword? k) v . rest) |
---|
774 | (cond |
---|
775 | [(bind-parameter-index stmt (string-append ":" (keyword->string k))) |
---|
776 | => (lambda (j) |
---|
777 | (hash-table-set! vs j v) |
---|
778 | (loop i rest))] |
---|
779 | [else |
---|
780 | (error-argument-type loc k "value or keyword matching a bind parameter name")])] |
---|
781 | [(v . rest) |
---|
782 | (hash-table-set! vs i v) |
---|
783 | (loop (add1 i) rest)] |
---|
784 | [() |
---|
785 | (void)])) |
---|
786 | (if (= (hash-table-size vs) cnt) |
---|
787 | (unless (zero? cnt) |
---|
788 | (hash-table-walk vs (cut bind! stmt <> <>))) |
---|
789 | (abort |
---|
790 | (make-composite-condition |
---|
791 | (make-exn-condition |
---|
792 | loc |
---|
793 | (conc "bad parameter count - received " (hash-table-size vs) " but expected " cnt)) |
---|
794 | (make-property-condition 'arity) |
---|
795 | (make-sqlite3-condition 'error)))))) |
---|
796 | |
---|
797 | (define (bind-parameters! stmt . params) |
---|
798 | (%bind-parameters! 'bind-parameters! stmt params)) |
---|
799 | |
---|
800 | ;; Single-step a prepared statement, return #t if data is available, |
---|
801 | ;; #f otherwise |
---|
802 | (define sqlite3_step |
---|
803 | (foreign-safe-lambda sqlite3:status "sqlite3_step" sqlite3:statement)) |
---|
804 | (define (step! stmt) |
---|
805 | (check-statement 'step! stmt) |
---|
806 | (let ([db (statement-database stmt)]) |
---|
807 | (let retry ([retries 0]) |
---|
808 | (define (busy-retry s) |
---|
809 | (let ([h (database-busy-handler db)]) |
---|
810 | (cond |
---|
811 | [(and h (h db retries)) |
---|
812 | (retry (add1 retries))] |
---|
813 | [else |
---|
814 | ((abort-sqlite3-error 'step! db stmt) s)]))) |
---|
815 | (let ([s (sqlite3_step stmt)]) |
---|
816 | (case s |
---|
817 | [(row) |
---|
818 | #t] |
---|
819 | [(done) |
---|
820 | #f] |
---|
821 | [(error) |
---|
822 | (let ([s (sqlite3_reset stmt)]) |
---|
823 | (case s |
---|
824 | [(schema) |
---|
825 | (repair! stmt) |
---|
826 | (retry retries)] |
---|
827 | [(busy) ; Passed thru sometimes (e.g. ATTACH). |
---|
828 | (busy-retry s)] |
---|
829 | [else |
---|
830 | ((abort-sqlite3-error 'step! db stmt) s)]))] |
---|
831 | [(busy) |
---|
832 | (busy-retry s)] |
---|
833 | [else |
---|
834 | ((abort-sqlite3-error 'step! db stmt) s)]))))) |
---|
835 | |
---|
836 | ;; Retrieve information from a prepared/stepped statement |
---|
837 | (define (column-count stmt) |
---|
838 | (check-statement 'column-count stmt) |
---|
839 | ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt)) |
---|
840 | |
---|
841 | (define (column-type stmt i) |
---|
842 | (check-statement 'column-type stmt) |
---|
843 | ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i)) |
---|
844 | |
---|
845 | (define (column-declared-type stmt i) |
---|
846 | (check-statement 'column-declared-type stmt) |
---|
847 | ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i)) |
---|
848 | |
---|
849 | (define (column-name stmt i) |
---|
850 | (check-statement 'column-name stmt) |
---|
851 | ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i)) |
---|
852 | |
---|
853 | ;; Retrieve data from a stepped statement |
---|
854 | (define (column-data stmt i) |
---|
855 | (case (column-type stmt i) |
---|
856 | [(integer) |
---|
857 | (if (and-let* ([type (column-declared-type stmt i)]) |
---|
858 | (string-contains-ci type "bool")) |
---|
859 | ((foreign-lambda bool "sqlite3_column_int" sqlite3:statement int) stmt i) |
---|
860 | ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i))] |
---|
861 | [(float) |
---|
862 | ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i)] |
---|
863 | [(text) |
---|
864 | ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i)) |
---|
865 | "int n = sqlite3_column_bytes(stmt, i);" |
---|
866 | "C_word *s = C_alloc(C_SIZEOF_STRING(n));" |
---|
867 | "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));") |
---|
868 | stmt i)] |
---|
869 | [(blob) |
---|
870 | ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i)) |
---|
871 | "int n = sqlite3_column_bytes(stmt, i);" |
---|
872 | "C_word *s = C_alloc(C_SIZEOF_STRING(n));" |
---|
873 | "return(C_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));") |
---|
874 | stmt i)] |
---|
875 | [else |
---|
876 | (sql-null)])) |
---|
877 | |
---|
878 | ;;; Easy statement interface |
---|
879 | |
---|
880 | ;; Compile a statement and call a procedure on it, then finalize the |
---|
881 | ;; statement in a dynamic-wind exit block if it hasn't been finalized yet. |
---|
882 | (define (call-with-temporary-statements proc db . sqls) |
---|
883 | (check-database 'call-with-temporary-statements db) |
---|
884 | (let ([stmts #f] [exn #f]) |
---|
885 | (dynamic-wind |
---|
886 | (lambda () |
---|
887 | (unless stmts |
---|
888 | (set! stmts (map (cute prepare db <>) sqls)))) |
---|
889 | (lambda () |
---|
890 | (handle-exceptions e (set! exn e) |
---|
891 | (apply proc stmts))) |
---|
892 | (lambda () |
---|
893 | (and-let* ([s stmts]) |
---|
894 | (set! stmts #f) |
---|
895 | (for-each finalize! s)) ;; leaks if error occurs before last stmt |
---|
896 | (and-let* ([e exn]) |
---|
897 | (set! exn #f) |
---|
898 | (signal e)))))) |
---|
899 | |
---|
900 | (define-syntax %define/statement+params |
---|
901 | (syntax-rules () |
---|
902 | [(%define/statement+params ((name loc) (init ...) (stmt params)) |
---|
903 | body ...) |
---|
904 | (define name |
---|
905 | (let ([impl (lambda (init ... stmt params) body ...)]) |
---|
906 | (lambda (init ... db-or-stmt . params) |
---|
907 | (cond |
---|
908 | [(database? db-or-stmt) |
---|
909 | (call-with-temporary-statements |
---|
910 | (cute impl init ... <> (cdr params)) |
---|
911 | db-or-stmt (car params))] |
---|
912 | [(statement? db-or-stmt) |
---|
913 | (impl init ... db-or-stmt params)] |
---|
914 | [else |
---|
915 | (error-argument-type loc db-or-stmt "database or statement")]))))] |
---|
916 | [(%define/statement+params (name (init ...) (stmt params)) |
---|
917 | body ...) |
---|
918 | (%define/statement+params ((name 'name) (init ...) (stmt params)) |
---|
919 | body ...)] |
---|
920 | [(%define/statement+params (name stmt params) |
---|
921 | body ...) |
---|
922 | (%define/statement+params ((name 'name) () (stmt params)) |
---|
923 | body ...)])) |
---|
924 | |
---|
925 | ;; Step through a statement and ignore possible results |
---|
926 | (define (%execute loc stmt params) |
---|
927 | (%bind-parameters! loc stmt params) |
---|
928 | (while (step! stmt)) |
---|
929 | (void)) |
---|
930 | |
---|
931 | (%define/statement+params (execute stmt params) |
---|
932 | (%execute 'execute stmt params)) |
---|
933 | |
---|
934 | ;; Step through a statement, ignore possible results and return the |
---|
935 | ;; count of changes performed by this statement |
---|
936 | (%define/statement+params (update stmt params) |
---|
937 | (%execute 'update stmt params) |
---|
938 | (change-count (statement-database stmt))) |
---|
939 | |
---|
940 | ;; Return only the first column of the first result row produced by this |
---|
941 | ;; statement |
---|
942 | |
---|
943 | (%define/statement+params (first-result stmt params) |
---|
944 | (%bind-parameters! 'first-result stmt params) |
---|
945 | (if (step! stmt) |
---|
946 | (let ([r (column-data stmt 0)]) |
---|
947 | (reset! stmt) |
---|
948 | r) |
---|
949 | (abort (make-no-data-condition 'first-result stmt params)))) |
---|
950 | |
---|
951 | ;; Return only the first result row produced by this statement as a list |
---|
952 | |
---|
953 | (%define/statement+params (first-row stmt params) |
---|
954 | (%bind-parameters! 'first-row stmt params) |
---|
955 | (if (step! stmt) |
---|
956 | (map (cute column-data stmt <>) |
---|
957 | (iota (column-count stmt))) |
---|
958 | (abort (make-no-data-condition 'first-row stmt params)))) |
---|
959 | |
---|
960 | ;; Apply a procedure to the values of the result columns for each result row |
---|
961 | ;; while executing the statement and accumulating results. |
---|
962 | |
---|
963 | (%define/statement+params ((%fold-row loc) (loc proc init) (stmt params)) |
---|
964 | (%bind-parameters! loc stmt params) |
---|
965 | (let ([cl (iota (column-count stmt))]) |
---|
966 | (let loop ([acc init]) |
---|
967 | (if (step! stmt) |
---|
968 | (loop (apply proc acc (map (cute column-data stmt <>) cl))) |
---|
969 | acc)))) |
---|
970 | |
---|
971 | (define (fold-row proc init db-or-stmt . params) |
---|
972 | (check-procedure 'fold-row proc) |
---|
973 | (apply %fold-row 'fold-row proc init db-or-stmt params)) |
---|
974 | |
---|
975 | ;; Apply a procedure to the values of the result columns for each result row |
---|
976 | ;; while executing the statement and discard the results |
---|
977 | |
---|
978 | (define (for-each-row proc db-or-stmt . params) |
---|
979 | (check-procedure 'for-each-row proc) |
---|
980 | (apply %fold-row |
---|
981 | 'for-each-row |
---|
982 | (lambda (acc . columns) |
---|
983 | (apply proc columns)) |
---|
984 | (void) |
---|
985 | db-or-stmt params)) |
---|
986 | |
---|
987 | ;; Apply a procedure to the values of the result columns for each result row |
---|
988 | ;; while executing the statement and accumulate the results in a list |
---|
989 | |
---|
990 | (define (map-row proc db-or-stmt . params) |
---|
991 | (check-procedure 'map-row proc) |
---|
992 | (reverse! |
---|
993 | (apply %fold-row |
---|
994 | 'map-row |
---|
995 | (lambda (acc . columns) |
---|
996 | (cons (apply proc columns) acc)) |
---|
997 | '() |
---|
998 | db-or-stmt params))) |
---|
999 | |
---|
1000 | ;;; Utility procedures |
---|
1001 | |
---|
1002 | ;; Run a thunk within a database transaction, commit if return value is |
---|
1003 | ;; true, rollback if return value is false or the thunk is interrupted by |
---|
1004 | ;; an exception |
---|
1005 | (define (with-transaction db thunk #!optional (type 'deferred)) |
---|
1006 | (check-database 'with-transaction db) |
---|
1007 | (check-procedure 'with-transaction thunk) |
---|
1008 | (unless (memq type '(deferred immediate exclusive)) |
---|
1009 | (abort |
---|
1010 | (make-composite-condition |
---|
1011 | (make-exn-condition 'with-transaction |
---|
1012 | "bad argument: expected deferred, immediate or exclusive" |
---|
1013 | type) |
---|
1014 | (make-property-condition 'type)))) |
---|
1015 | (let ([success? #f] [exn #f]) |
---|
1016 | (dynamic-wind |
---|
1017 | (lambda () |
---|
1018 | (execute db |
---|
1019 | (string-append "BEGIN " (symbol->string type) " TRANSACTION;"))) |
---|
1020 | (lambda () |
---|
1021 | (handle-exceptions e (begin |
---|
1022 | (print-error "with-transaction" exn) |
---|
1023 | (set! exn e)) |
---|
1024 | (set! success? (thunk)) |
---|
1025 | success?)) |
---|
1026 | (lambda () |
---|
1027 | (execute db |
---|
1028 | (if success? |
---|
1029 | "COMMIT TRANSACTION;" |
---|
1030 | "ROLLBACK TRANSACTION;")) |
---|
1031 | (and-let* ([e exn]) |
---|
1032 | (set! exn #f) |
---|
1033 | (signal e)))))) |
---|
1034 | |
---|
1035 | ;; Check if the given string is a valid SQL statement |
---|
1036 | (define sql-complete? |
---|
1037 | (foreign-lambda bool "sqlite3_complete" nonnull-c-string)) |
---|
1038 | |
---|
1039 | ;; Return a descriptive version string |
---|
1040 | (define database-version |
---|
1041 | (foreign-lambda c-string "sqlite3_libversion")) |
---|
1042 | |
---|
1043 | ;; Return the amount of memory currently allocated by the database |
---|
1044 | (define database-memory-used |
---|
1045 | (foreign-lambda integer "sqlite3_memory_used")) |
---|
1046 | |
---|
1047 | ;; Return the maximum amount of memory allocated by the database since |
---|
1048 | ;; the counter was last reset |
---|
1049 | (define (database-memory-highwater #!optional reset?) |
---|
1050 | ((foreign-lambda integer "sqlite3_memory_highwater" bool) reset?)) |
---|
1051 | |
---|
1052 | ;; Enables (disables) the sharing of the database cache and schema data |
---|
1053 | ;; structures between connections to the same database. |
---|
1054 | (define (enable-shared-cache! enable?) |
---|
1055 | (cond |
---|
1056 | [((foreign-lambda sqlite3:status "sqlite3_enable_shared_cache" bool) enable?) |
---|
1057 | => (abort-sqlite3-error 'enable-shared-cache! #f)])) |
---|
1058 | |
---|
1059 | ) |
---|