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

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

* empty log message *

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