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

Last change on this file since 33349 was 33349, checked in by chust, 3 years ago

[sqlite3] Added enable-load-extension! procedure

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