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

Last change on this file since 15344 was 15344, checked in by Thomas Chust, 12 years ago

sqlite3: Merged local code cleanups and switch to sql-null for NULL handling.

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