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

Last change on this file since 32060 was 32060, checked in by Thomas Chust, 6 years ago

[sqlite3] Added compilation option todisable shared cache functionality

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