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

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

[sqlite3] More fixnum arithmetic tweaks

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  (no-procedure-checks-for-usual-bindings)
14  (unused
15    ; Stop annoying messages
16    sqlite3#chicken_sqlite3_function_stub
17    sqlite3#chicken_sqlite3_collation_stub
18    sqlite3#chicken_sqlite3_final_stub
19    sqlite3#chicken_sqlite3_step_stub
20    ; These may have to be changed if definitions are added,
21    ; removed or reordered:
22    sqlite3#g166 sqlite3#g366 sqlite3#g484 sqlite3#g566)
23  (bound-to-procedure
24    ##sys#expand-home-path
25    sqlite3#sqlite3_errmsg))
26
27#>#include <sqlite3.h><#
28
29(module sqlite3
30  ( ;; type predicates and checks
31    database?
32    error-database
33    check-database
34    statement?
35    error-statement
36    check-statement
37    ;; procedures
38    open-database
39    define-collation
40    define-function
41    set-busy-handler!
42    make-busy-timeout
43    interrupt!
44    auto-committing?
45    change-count
46    last-insert-rowid
47    finalize!
48    prepare
49    source-sql
50    reset!
51    bind-parameter-count
52    bind-parameter-index
53    bind-parameter-name
54    bind!
55    bind-parameters!
56    step!
57    column-count
58    column-type
59    column-declared-type
60    column-name
61    column-data
62    call-with-temporary-statements
63    execute
64    update
65    first-result
66    first-row
67    fold-row
68    for-each-row
69    map-row
70    with-transaction
71    sql-complete?
72    database-version
73    database-memory-used
74    database-memory-highwater
75    enable-shared-cache!
76  )
77
78(import scheme chicken foreign)
79
80(use
81  srfi-1 srfi-13 srfi-18 srfi-69
82  data-structures extras lolevel
83  type-errors type-checks synch miscmacros matchable sql-null)
84
85;;; Foreign types & values
86
87;; Enumeration and constant definitions
88
89(define-syntax %define-enum-type
90  (syntax-rules ()
91    [(%define-enum-type (sname cname) (sv cv) ...)
92    (define-foreign-type sname
93      (enum cname)
94      (lambda (v)
95        (case v
96          [(sv) (foreign-value cv int)]
97          ...
98          [else
99            (error-argument-type 'sname v "enumeration value")]))
100            (lambda (v)
101        (select v
102          [((foreign-value cv int)) 'sv]
103          ...
104          [else
105            (error-argument-type 'sname v "enumeration index")])))]))
106
107(%define-enum-type (sqlite3:status "sqlite3_status")
108  (#f                                                           "SQLITE_OK")      ; Successful result
109  (error                                "SQLITE_ERROR")   ; SQL error or missing database
110  (internal                                     "SQLITE_INTERNAL")        ; NOT USED. Internal logic error in SQLite
111  (permission                           "SQLITE_PERM")    ; Access permission denied
112  (abort                                "SQLITE_ABORT")   ; Callback routine requested an abort
113  (busy                                 "SQLITE_BUSY")    ; The database file is locked
114  (locked                               "SQLITE_LOCKED")          ; A table in the database is locked
115  (no-memory                    "SQLITE_NOMEM")   ; A malloc() failed
116  (read-only                    "SQLITE_READONLY")        ; Attempt to write a readonly database
117  (interrupt                    "SQLITE_INTERRUPT")       ; Operation terminated by sqlite3_interrupt()
118  (io-error                     "SQLITE_IOERR")   ; Some kind of disk I/O error occurred
119  (corrupt                      "SQLITE_CORRUPT")         ; The database disk image is malformed
120  (not-found                    "SQLITE_NOTFOUND")        ; NOT USED. Table or record not found
121  (full                                 "SQLITE_FULL")    ; Insertion failed because database is full
122  (cant-open                    "SQLITE_CANTOPEN")        ; Unable to open the database file
123  (protocol                     "SQLITE_PROTOCOL")        ; NOT USED. Database lock protocol error
124  (empty                                "SQLITE_EMPTY")   ; Database is empty
125  (schema                               "SQLITE_SCHEMA")          ; The database schema changed
126  (too-big                      "SQLITE_TOOBIG")          ; String or BLOB exceeds size limit
127  (constraint                   "SQLITE_CONSTRAINT")      ; Abort due to contraint violation
128  (mismatch                     "SQLITE_MISMATCH")        ; Data type mismatch
129  (misuse                               "SQLITE_MISUSE")          ; Library used incorrectly
130  (no-lfs                               "SQLITE_NOLFS")   ; Uses OS features not supported on host
131  (authorization                "SQLITE_AUTH")    ; Authorization denied
132  (format                               "SQLITE_FORMAT")          ; Auxiliary database format error
133  (range                                "SQLITE_RANGE")   ; 2nd parameter to sqlite3_bind out of range
134  (not-a-database               "SQLITE_NOTADB")          ; File opened that is not a database file
135  (row                                  "SQLITE_ROW")             ; sqlite3_step() has another row ready
136  (done                                 "SQLITE_DONE"))   ; sqlite3_step() has finished executing
137
138(%define-enum-type (sqlite3:type "sqlite3_type")
139  (integer      "SQLITE_INTEGER")
140  (float                "SQLITE_FLOAT")
141  (text                 "SQLITE_TEXT")
142  (blob                 "SQLITE_BLOB")
143  (null                 "SQLITE_NULL"))
144
145;; Auxiliary types
146
147(define-foreign-type sqlite3:context
148  (c-pointer "sqlite3_context"))
149
150(define-foreign-type sqlite3:value
151  (c-pointer "sqlite3_value"))
152
153;; Types for databases and statements
154
155(define-record-type sqlite3:database
156  (make-database ptr busy-handler)
157  database?
158  (ptr database-ptr database-ptr-set!)
159  (busy-handler database-busy-handler database-busy-handler-set!))
160
161(define-record-printer (sqlite3:database db out)
162  (display
163    (if (database-ptr db)
164      "#<sqlite3:database>"
165      "#<sqlite3:database zombie>")
166    out))
167
168(define-check+error-type database)
169
170(define-foreign-type sqlite3:database
171  (nonnull-c-pointer "sqlite3")
172  database-ptr
173  (cut make-database <> #f))
174
175(define-record-type sqlite3:statement
176  (make-statement ptr database)
177  statement?
178  (ptr statement-ptr statement-ptr-set!)
179  (database statement-database))
180
181(define-record-printer (sqlite3:statement stmt out)
182  (display
183    (if (statement-ptr stmt)
184      (sprintf "#<sqlite3:statement sql=~s>" (source-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))
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        void
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 (fx<= 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 (fx+ i 1))))))
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      void
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      void
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        void
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 (fx+ n 1))
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 (fx+ n 1))
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 sqlite3:database])
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        db])))
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! (/ ms 1000)))
576  (let* ([delays '#(1 2 5 10 15 20 25 25 25 50 50 100)]
577         [totals '#(0 1 3  8 18 33 53 78 103 128 178 228)]
578         [ndelay (vector-length delays)])
579    (lambda (db count)
580      (let* ([delay (vector-ref delays (fxmin count (fx- ndelay 1)))]
581             [prior (if (fx< count ndelay)
582                        (vector-ref totals count)
583                        (fx+ (vector-ref totals (fx- ndelay 1))
584                             (fx* delay (fx- count (fx- ndelay 1)))))])
585        (let ([delay (if (fx> (fx+ prior delay) timeout)
586                         (fx- timeout prior)
587                         delay)])
588          (cond
589           [(fx<= delay 0) #f]
590           [else
591            (thread-sleep!/ms delay)
592            #t]))))))
593
594;; Cancel any running database operation as soon as possible
595(define (interrupt! db)
596  (check-database 'interrupt! db)
597  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db))
598
599;; Check whether the database is in autocommit mode
600(define (auto-committing? db)
601  (check-database 'auto-committing? db)
602  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db))
603
604;; Get the number of changes made to the database
605(define (change-count db #!optional (total #f))
606  (check-database 'change-count db)
607  (if total
608    ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
609    ((foreign-lambda number "sqlite3_changes" sqlite3:database) db)))
610
611;; Get the row ID of the last inserted row
612(define (last-insert-rowid db)
613  (check-database 'last-insert-rowid db)
614  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db))
615
616;; Close a database or statement handle
617(define sqlite3_finalize
618  (foreign-lambda sqlite3:status "sqlite3_finalize" nonnull-c-pointer))
619
620(define sqlite3_next_stmt
621  (foreign-lambda c-pointer "sqlite3_next_stmt" sqlite3:database c-pointer))
622
623(define finalize!
624  (match-lambda*
625    [((? database? db) . finalize-statements?)
626      (cond
627        [(not (database-ptr db))
628          (void)]
629        [(let loop ([stmt
630                      (and
631                        (optional finalize-statements? #f)
632                        (sqlite3_next_stmt db #f))])
633           (if stmt
634             (or (sqlite3_finalize stmt) (loop (sqlite3_next_stmt db stmt)))
635             ((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)))
636          => (abort-sqlite3-error 'finalize! db db)]
637        [else
638          (let ([id (pointer->address (database-ptr db))]
639                [release-qns (lambda (_ info) (object-release (vector-ref info 0)))])
640            (call-with/synch *collations*
641              (cute hash-table-tree-clear! <> id release-qns))
642            (call-with/synch *functions*
643              (cute hash-table-tree-clear! <> id release-qns))
644            (database-ptr-set! db #f)
645            (database-busy-handler-set! db #f))])]
646    [((? statement? stmt))
647      (cond
648        [(not (statement-ptr stmt))
649          (void)]
650        [(sqlite3_finalize (statement-ptr stmt))
651          => (abort-sqlite3-error 'finalize! (statement-database stmt) stmt)]
652        [else
653          (statement-ptr-set! stmt #f)])]
654    [(v . _)
655      (error-argument-type 'finalize! v "database or statement")]))
656
657;;; Statement interface
658
659;; Create a new statement
660(define (prepare db sql)
661  (check-database 'prepare db)
662  (check-string 'prepare sql)
663  (let retry ([retries 0])
664    (let-location ([stmt c-pointer] [tail c-string])
665      (cond
666        [((foreign-safe-lambda sqlite3:status "sqlite3_prepare_v2"
667            sqlite3:database scheme-pointer int
668            (c-pointer sqlite3:statement)
669            (c-pointer (const c-string)))
670          db (string-append sql "\x00") (string-length sql) #$stmt #$tail)
671          => (lambda (err)
672              (case err
673                [(busy)
674                  (let ([h (database-busy-handler db)])
675                    (cond
676                      [(and h (h db retries))
677                        (retry (fx+ retries 1))]
678                      [else
679                        ((abort-sqlite3-error 'prepare db db sql) err)]))]
680                [else
681                  ((abort-sqlite3-error 'prepare db db sql) err)]))]
682        [else
683          (values (make-statement stmt db) tail)]))))
684
685;; Retrieve the SQL source code of a statement
686(define (source-sql stmt)
687  (check-statement 'source-sql stmt)
688  ((foreign-lambda c-string "sqlite3_sql" sqlite3:statement) stmt))
689
690;; Reset an existing statement to process it again
691(define (reset! stmt)
692  (check-statement 'reset! stmt)
693  (cond [((foreign-lambda sqlite3:status "sqlite3_reset" sqlite3:statement) stmt)
694    => (abort-sqlite3-error 'reset! (statement-database stmt) stmt)]))
695
696;; Get number of bindable parameters
697(define (bind-parameter-count stmt)
698  (check-statement 'bind-parameter-count stmt)
699  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt))
700
701;; Get index of a bindable parameter or #f if no parameter with the
702;; given name exists
703(define (bind-parameter-index stmt name)
704  (check-statement 'bind-parameter-index stmt)
705  (let ([i ((foreign-lambda int "sqlite3_bind_parameter_index"
706              sqlite3:statement nonnull-c-string)
707            stmt name)])
708    (if (zero? i)
709      #f
710      (fx- i 1))))
711
712;; Get the name of a bindable parameter
713(define (bind-parameter-name stmt i)
714  (check-statement 'bind-parameter-name stmt)
715  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int)
716    stmt (fx+ i 1)))
717
718;; Bind data as parameters to an existing statement
719
720(define (bind! stmt i v)
721  (check-statement 'bind! stmt)
722  (check-cardinal-integer 'bind! i)
723  (cond
724    [(blob? v)
725      (cond [((foreign-lambda* sqlite3:status
726                ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
727                "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
728              stmt (fx+ i 1) v (blob-size v))
729        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
730    [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0)))
731      => (lambda (v)
732          (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
733                    sqlite3:statement int int)
734                  stmt (fx+ i 1) v)
735            => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))]
736    [(real? v)
737      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_double"
738                sqlite3:statement int double)
739              stmt (fx+ i 1) v)
740        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
741    [(string? v)
742      (cond [((foreign-lambda* sqlite3:status
743                ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
744                "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
745              stmt (fx+ i 1) v (string-length v))
746        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
747    [(sql-null? v)
748      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int)
749              stmt (fx+ i 1))
750        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i)])]
751    [else
752      (error-argument-type 'bind! v "blob, number, boolean, string or sql-null")]))
753
754; Helper
755
756(define (%bind-parameters! loc stmt params)
757  (reset! stmt)
758  (let ([cnt (bind-parameter-count stmt)]
759  [vs (make-hash-table)])
760    (let loop ([i 0] [params params])
761      (match params
762        [((? keyword? k) v . rest)
763          (cond
764            [(bind-parameter-index stmt (string-append ":" (keyword->string k)))
765              => (lambda (j)
766             (hash-table-set! vs j v)
767             (loop i rest))]
768            [else
769              (error-argument-type loc k "value or keyword matching a bind parameter name")])]
770        [(v . rest)
771          (hash-table-set! vs i v)
772          (loop (fx+ i 1) rest)]
773        [()
774          (void)]))
775    (if (= (hash-table-size vs) cnt)
776      (unless (zero? cnt)
777        (hash-table-walk vs (cut bind! stmt <> <>)))
778      (abort
779        (make-composite-condition
780          (make-exn-condition
781            loc
782            (conc "bad parameter count - received " (hash-table-size vs) " but expected " cnt))
783          (make-property-condition 'arity)
784          (make-sqlite3-condition 'error))))))
785
786(define (bind-parameters! stmt . params)
787  (%bind-parameters! 'bind-parameters! stmt params))
788
789;; Single-step a prepared statement, return #t if data is available,
790;; #f otherwise
791(define (step! stmt)
792  (check-statement 'step! stmt)
793  (let ([db (statement-database stmt)])
794    (let retry ([retries 0])
795      (let ([s ((foreign-safe-lambda
796                  sqlite3:status "sqlite3_step" sqlite3:statement) stmt)])
797        (case s
798          [(row)
799            #t]
800          [(done)
801            #f]
802          [(busy)
803            (let ([h (database-busy-handler db)])
804              (cond
805                [(and h (h db retries))
806                  (retry (fx+ retries 1))]
807                [else
808                  ((abort-sqlite3-error 'step! db stmt) s)]))]
809          [else
810            ((abort-sqlite3-error 'step! db stmt) s)])))))
811
812;; Retrieve information from a prepared/stepped statement
813(define (column-count stmt)
814  (check-statement 'column-count stmt)
815  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt))
816
817(define (column-type stmt i)
818  (check-statement 'column-type stmt)
819  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i))
820
821(define (column-declared-type stmt i)
822  (check-statement 'column-declared-type stmt)
823  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i))
824
825(define (column-name stmt i)
826  (check-statement 'column-name stmt)
827  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i))
828
829;; Retrieve data from a stepped statement
830(define (column-data stmt i)
831  (case (column-type stmt i)
832    [(integer)
833      (if (and-let* ([type (column-declared-type stmt i)])
834            (string-contains-ci type "bool"))
835        ((foreign-lambda bool "sqlite3_column_int" sqlite3:statement int) stmt i)
836        ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i))]
837    [(float)
838      ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i)]
839    [(text)
840      ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
841          "int n = sqlite3_column_bytes(stmt, i);"
842          "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
843          "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));")
844        stmt i)]
845    [(blob)
846      ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
847          "int n = sqlite3_column_bytes(stmt, i);"
848          "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
849          "return(C_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));")
850        stmt i)]
851    [else
852      (sql-null)]))
853
854;;; Easy statement interface
855
856;; Compile a statement and call a procedure on it, then finalize the
857;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
858(define (call-with-temporary-statements proc db . sqls)
859  (check-database 'call-with-temporary-statements db)
860  (let ([stmts #f] [exn #f])
861    (dynamic-wind
862      (lambda ()
863        (unless stmts
864          (set! stmts (map (cute prepare db <>) sqls))))
865      (lambda ()
866        (handle-exceptions e (set! exn e)
867          (apply proc stmts)))
868      (lambda ()
869        (and-let* ([s stmts])
870          (set! stmts #f)
871          (for-each finalize! s)) ;; leaks if error occurs before last stmt
872        (and-let* ([e exn])
873          (set! exn #f)
874          (signal e))))))
875
876(define-syntax %define/statement+params
877  (syntax-rules ()
878    [(%define/statement+params ((name loc) (init ...) (stmt params))
879       body ...)
880      (define name
881        (let ([impl (lambda (init ... stmt params) body ...)])
882          (lambda (init ... db-or-stmt . params)
883            (cond
884              [(database? db-or-stmt)
885                (call-with-temporary-statements
886                  (cute impl init ... <> (cdr params))
887                  db-or-stmt (car params))]
888              [(statement? db-or-stmt)
889                (impl init ... db-or-stmt params)]
890              [else
891                (error-argument-type loc db-or-stmt "database or statement")]))))]
892    [(%define/statement+params (name (init ...) (stmt params))
893       body ...)
894      (%define/statement+params ((name 'name) (init ...) (stmt params))
895        body ...)]
896    [(%define/statement+params (name stmt params)
897       body ...)
898      (%define/statement+params ((name 'name) () (stmt params))
899        body ...)]))
900
901;; Step through a statement and ignore possible results
902(define (%execute loc stmt params)
903  (%bind-parameters! loc stmt params)
904  (while (step! stmt))
905  (void))
906
907(%define/statement+params (execute stmt params)
908  (%execute 'execute stmt params))
909
910;; Step through a statement, ignore possible results and return the
911;; count of changes performed by this statement
912(%define/statement+params (update stmt params)
913  (%execute 'update stmt params)
914  (change-count (statement-database stmt)))
915
916;; Return only the first column of the first result row produced by this
917;; statement
918
919(%define/statement+params (first-result stmt params)
920  (%bind-parameters! 'first-result stmt params)
921  (if (step! stmt)
922    (let ([r (column-data stmt 0)])
923      (reset! stmt)
924      r)
925    (abort (make-no-data-condition 'first-result stmt params))))
926
927;; Return only the first result row produced by this statement as a list
928
929(%define/statement+params (first-row stmt params)
930  (%bind-parameters! 'first-row stmt params)
931  (if (step! stmt)
932    (map (cute column-data stmt <>)
933      (iota (column-count stmt)))
934    (abort (make-no-data-condition 'first-row stmt params))))
935
936;; Apply a procedure to the values of the result columns for each result row
937;; while executing the statement and accumulating results.
938
939(%define/statement+params ((%fold-row loc) (loc proc init) (stmt params))
940  (%bind-parameters! loc stmt params)
941  (let ([cl (iota (column-count stmt))])
942    (let loop ([acc init])
943      (if (step! stmt)
944  (loop (apply proc acc (map (cute column-data stmt <>) cl)))
945  acc))))
946
947(define (fold-row proc init db-or-stmt . params)
948  (check-procedure 'fold-row proc)
949  (apply %fold-row 'fold-row proc init db-or-stmt params))
950
951;; Apply a procedure to the values of the result columns for each result row
952;; while executing the statement and discard the results
953
954(define (for-each-row proc db-or-stmt . params)
955  (check-procedure 'for-each-row proc)
956  (apply %fold-row
957    'for-each-row
958    (lambda (acc . columns)
959      (apply proc columns))
960    (void)
961    db-or-stmt params))
962
963;; Apply a procedure to the values of the result columns for each result row
964;; while executing the statement and accumulate the results in a list
965
966(define (map-row proc db-or-stmt . params)
967  (check-procedure 'map-row proc)
968  (reverse!
969    (apply %fold-row
970      'map-row
971      (lambda (acc . columns)
972        (cons (apply proc columns) acc))
973      '()
974      db-or-stmt params)))
975
976;;; Utility procedures
977
978;; Run a thunk within a database transaction, commit if return value is
979;; true, rollback if return value is false or the thunk is interrupted by
980;; an exception
981(define (with-transaction db thunk #!optional (type 'deferred))
982  (check-database 'with-transaction db)
983  (check-procedure 'with-transaction thunk)
984  (unless (memq type '(deferred immediate exclusive))
985    (abort
986      (make-composite-condition
987        (make-exn-condition 'with-transaction
988          "bad argument: expected deferred, immediate or exclusive"
989          type)
990        (make-property-condition 'type))))
991  (let ([success? #f] [exn #f])
992    (dynamic-wind
993      (lambda ()
994        (execute db
995          (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
996      (lambda ()
997        (handle-exceptions e (begin
998                               (print-error "with-transaction" exn)
999                               (set! exn e))
1000          (set! success? (thunk))
1001          success?))
1002      (lambda ()
1003        (execute db
1004          (if success?
1005            "COMMIT TRANSACTION;"
1006            "ROLLBACK TRANSACTION;"))
1007        (and-let* ([e exn])
1008          (set! exn #f)
1009          (signal e))))))
1010
1011;; Check if the given string is a valid SQL statement
1012(define sql-complete?
1013  (foreign-lambda bool "sqlite3_complete" nonnull-c-string))
1014
1015;; Return a descriptive version string
1016(define database-version
1017  (foreign-lambda c-string "sqlite3_libversion"))
1018
1019;; Return the amount of memory currently allocated by the database
1020(define database-memory-used
1021  (foreign-lambda integer "sqlite3_memory_used"))
1022
1023;; Return the maximum amount of memory allocated by the database since
1024;; the counter was last reset
1025(define (database-memory-highwater #!optional reset?)
1026  ((foreign-lambda integer "sqlite3_memory_highwater" bool) reset?))
1027
1028;; Enables (disables) the sharing of the database cache and schema data
1029;; structures between connections to the same database.
1030(define (enable-shared-cache! enable?)
1031  (cond
1032    [((foreign-lambda sqlite3:status "sqlite3_enable_shared_cache" bool) enable?)
1033      => (abort-sqlite3-error 'enable-shared-cache! #f)]))
1034
1035)
Note: See TracBrowser for help on using the repository browser.