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

Last change on this file since 15334 was 15334, checked in by Thomas Chust, 11 years ago

[sqlite3] Merged CHICKEN 4 specific local changes back into Subversion.

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