source: project/release/5/sqlite3/trunk/sqlite3.scm

Last change on this file was 36672, checked in by Thomas Chust, 2 years ago

[sqlite3] Proper support for integers in the 64-bit range (thanks to wasamasa)

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