source: project/release/4/sqlite3/trunk/sqlite3.scm @ 15347

Last change on this file since 15347 was 15347, checked in by Thomas Chust, 10 years ago

sqlite3: Merged bindings of database memory statistics functions.

File size: 35.6 KB
Line 
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));
322EOS
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));
507EOS
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));
537EOS
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)
Note: See TracBrowser for help on using the repository browser.