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

Last change on this file since 36618 was 36618, checked in by chust, 10 months ago

[sqlite3] Ported CHICKEN 4 code to CHICKEN 5, thanks to Vasilij for patches

File size: 38.1 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    [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0)))
436      => (lambda (v)
437          ((foreign-lambda void "sqlite3_result_int" sqlite3:context int)
438            ctx v))]
439    [(real? v)
440      ((foreign-lambda void "sqlite3_result_double" sqlite3:context double)
441        ctx v)]
442    [(string? v)
443      ((foreign-lambda* void
444          ((sqlite3:context ctx) (scheme-pointer v) (int n))
445          "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);")
446        ctx v (string-length v))]
447    [(sql-null? v)
448      ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
449        ctx)]
450    [else
451      (error-argument-type 'set-result! v "blob, number, boolean, string or sql-null")]))
452
453(define sqlite3_user_data
454  (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context))
455
456(define-external (chicken_sqlite3_function_stub
457      (c-pointer ctx) (int n) (c-pointer args)) void
458  (let/cc return
459    (dynamic-wind
460      void
461      (lambda ()
462        (handle-exceptions exn
463          (print-error "in SQL function" exn)
464          (set-result!
465            ctx
466            (apply (vector-ref
467                      (call-synch-with *functions*
468                        (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))
469                      1)
470              (parameter-data n args)))))
471      (lambda ()
472        (return (void))))))
473
474(define sqlite3_aggregate_context
475  (foreign-lambda* integer ((sqlite3:context ctx))
476    "return((intptr_t)sqlite3_aggregate_context(ctx, 1));"))
477
478(define-external (chicken_sqlite3_step_stub
479      (c-pointer ctx) (int n) (c-pointer args)) void
480  (let/cc return
481    (dynamic-wind
482      void
483      (lambda ()
484        (handle-exceptions exn
485          (print-error "in step of SQL function" exn)
486          (let ([info (call-synch-with *functions*
487                        (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
488            (call-synch-with *seeds*
489              (cute hash-table-update!/default
490                <>
491                (sqlite3_aggregate_context ctx)
492                (lambda (seed)
493                  (apply (vector-ref info 1) seed (parameter-data n args)))
494                (vector-ref info 2))))))
495      (lambda ()
496        (return (void))))))
497
498(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
499  void
500  (let/cc return
501    (let ([agc (sqlite3_aggregate_context ctx)])
502      (dynamic-wind
503        void
504        (lambda ()
505          (handle-exceptions exn
506            (print-error "in final of SQL function" exn)
507            (let ([info (call-synch-with *functions*
508            (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
509              (cond
510          [((vector-ref info 3)
511            (call-synch-with *seeds*
512              (cute hash-table-ref/default <> agc (vector-ref info 2))))
513            => (cute set-result! ctx <>)]
514          [else
515            (set-result! ctx (sql-null))]))))
516        (lambda ()
517          (call-synch-with *seeds*
518            (cute hash-table-delete! <> agc))
519          (return (void)))))))
520
521(define define-function
522  (case-lambda
523    [(db name n proc)
524      (check-database 'define-function db)
525      (check-string 'define-function name)
526      (check-natural-number 'define-function (fx+ n 1))
527      (check-procedure 'define-function proc)
528      (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))])
529        (cond
530          [((foreign-lambda* sqlite3:status
531              ((sqlite3:database db)
532                (c-string name) (int n) (scheme-object qn))
533#<<EOS
534            return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
535                    (void *)qn,
536                    (void (*)(sqlite3_context *, int,
537                        sqlite3_value **))
538                    &chicken_sqlite3_function_stub,
539                    NULL,
540                    NULL));
541EOS
542      )
543      db name n qn)
544      => (lambda (s)
545          (object-release qn)
546          ((abort-sqlite3-error 'define-function db name n proc) s))]
547    [else
548      (call-synch-with *functions*
549        (cute hash-table-tree-set! <> qn (vector qn proc)))]))]
550    [(db name n step-proc seed . final-proc)
551      (check-database 'define-function db)
552      (check-string 'define-function name)
553      (check-natural-number 'define-function (fx+ n 1))
554      (let ([final-proc (optional final-proc identity)])
555        (check-procedure 'define-function step-proc)
556        (check-procedure 'define-function final-proc)
557        (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))])
558          (cond
559            [((foreign-lambda* sqlite3:status
560                ((sqlite3:database db)
561                  (c-string name) (int n) (scheme-object qn))
562#<<EOS
563                return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
564                          (void *)qn,
565                          NULL,
566                          (void (*)(sqlite3_context *,
567                              int, sqlite3_value **))
568                          &chicken_sqlite3_step_stub,
569                          (void (*)(sqlite3_context *))
570                          &chicken_sqlite3_final_stub));
571EOS
572              )
573              db name n qn)
574              => (lambda (s)
575                  (object-release qn)
576                  ((abort-sqlite3-error
577                      'define-function db name n step-proc seed final-proc) s))]
578            [else
579              (call-synch-with *functions*
580                (cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))])))]))
581
582;;; Database interface
583
584;; Get any error message
585(define sqlite3_errmsg
586  (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database))
587
588;; Open a database
589(define (open-database path)
590  (check-string 'open-database path)
591  (let-location ([db sqlite3:database])
592    (cond
593      [((foreign-lambda sqlite3:status "sqlite3_open"
594          nonnull-c-string (c-pointer sqlite3:database))
595        path #$db)
596        => (abort-sqlite3-error 'open-database #f path)]
597      [else
598        db])))
599
600;; Set application busy handler.  Does not use a callback, so it is safe
601;; to yield.  Handler is called with DB, COUNT and LAST (the last value
602;; it returned).  Return true value to continue trying, or #f to stop.
603(define (set-busy-handler! db handler)
604  (check-database 'set-busy-handler! db)
605  (database-busy-handler-set! db handler))
606
607;; Returns a closure suitable for use with set-busy-handler!.  Identical
608;; to sqlite's default busy handler, but does not block.
609(define (make-busy-timeout timeout)
610  (define (thread-sleep!/ms ms)
611    (thread-sleep! (/ ms 1000)))
612  (let* ([delays '#(1 2 5 10 15 20 25 25 25 50 50 100)]
613         [totals '#(0 1 3  8 18 33 53 78 103 128 178 228)]
614         [ndelay (vector-length delays)])
615    (lambda (db count)
616      (let* ([delay (vector-ref delays (fxmin count (fx- ndelay 1)))]
617             [prior (if (fx< count ndelay)
618                        (vector-ref totals count)
619                        (fx+ (vector-ref totals (fx- ndelay 1))
620                             (fx* delay (fx- count (fx- ndelay 1)))))])
621        (let ([delay (if (fx> (fx+ prior delay) timeout)
622                         (fx- timeout prior)
623                         delay)])
624          (cond
625           [(fx<= delay 0) #f]
626           [else
627            (thread-sleep!/ms delay)
628            #t]))))))
629
630;; Cancel any running database operation as soon as possible
631(define (interrupt! db)
632  (check-database 'interrupt! db)
633  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db))
634
635;; Check whether the database is in autocommit mode
636(define (auto-committing? db)
637  (check-database 'auto-committing? db)
638  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db))
639
640;; Get the number of changes made to the database
641(define (change-count db #!optional (total #f))
642  (check-database 'change-count db)
643  (if total
644    ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
645    ((foreign-lambda number "sqlite3_changes" sqlite3:database) db)))
646
647;; Get the row ID of the last inserted row
648(define (last-insert-rowid db)
649  (check-database 'last-insert-rowid db)
650  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db))
651
652;; Close a database or statement handle
653(define sqlite3_finalize
654  (foreign-lambda sqlite3:status "sqlite3_finalize" nonnull-c-pointer))
655
656(define sqlite3_next_stmt
657  (foreign-lambda c-pointer "sqlite3_next_stmt" sqlite3:database c-pointer))
658
659(define finalize!
660  (match-lambda*
661    [((? database? db) . finalize-statements?)
662      (cond
663        [(not (database-ptr db))
664          (void)]
665        [(let loop ([stmt
666                      (and
667                        (optional finalize-statements? #f)
668                        (sqlite3_next_stmt db #f))])
669           (if stmt
670             (or (sqlite3_finalize stmt) (loop (sqlite3_next_stmt db stmt)))
671             ((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)))
672          => (abort-sqlite3-error 'finalize! db db)]
673        [else
674          (let ([id (pointer->address (database-ptr db))]
675                [release-qns (lambda (_ info) (object-release (vector-ref info 0)))])
676            (call-synch-with *collations*
677              (cute hash-table-tree-clear! <> id release-qns))
678            (call-synch-with *functions*
679              (cute hash-table-tree-clear! <> id release-qns))
680            (database-ptr-set! db #f)
681            (database-busy-handler-set! db #f))])]
682    [((? statement? stmt))
683      (cond
684        [(not (statement-ptr stmt))
685          (void)]
686        [(sqlite3_finalize (statement-ptr stmt))
687          => (abort-sqlite3-error 'finalize! (statement-database stmt) stmt)]
688        [else
689          (statement-ptr-set! stmt #f)])]
690    [(v . _)
691      (error-argument-type 'finalize! v "database or statement")]))
692
693;;; Statement interface
694
695;; Create a new statement
696(define (prepare db sql)
697  (check-database 'prepare db)
698  (check-string 'prepare sql)
699  (let retry ([retries 0])
700    (let-location ([stmt c-pointer] [tail c-string])
701      (cond
702        [((foreign-safe-lambda sqlite3:status "sqlite3_prepare_v2"
703            sqlite3:database scheme-pointer int
704            (c-pointer sqlite3:statement)
705            (c-pointer (const c-string)))
706          db (string-append sql "\x00") (string-length sql) #$stmt #$tail)
707          => (lambda (err)
708              (case err
709                [(busy)
710                  (let ([h (database-busy-handler db)])
711                    (cond
712                      [(and h (h db retries))
713                        (retry (fx+ retries 1))]
714                      [else
715                        ((abort-sqlite3-error 'prepare db db sql) err)]))]
716                [else
717                  ((abort-sqlite3-error 'prepare db db sql) err)]))]
718        [else
719          (values (make-statement stmt db) tail)]))))
720
721;; Retrieve the SQL source code of a statement
722(define (source-sql stmt)
723  (check-statement 'source-sql stmt)
724  ((foreign-lambda c-string "sqlite3_sql" sqlite3:statement) stmt))
725
726;; Reset an existing statement to process it again
727(define (reset! stmt)
728  (check-statement 'reset! stmt)
729  (cond [((foreign-lambda sqlite3:status "sqlite3_reset" sqlite3:statement) stmt)
730    => (abort-sqlite3-error 'reset! (statement-database stmt) stmt)]))
731
732;; Get number of bindable parameters
733(define (bind-parameter-count stmt)
734  (check-statement 'bind-parameter-count stmt)
735  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt))
736
737;; Get index of a bindable parameter or #f if no parameter with the
738;; given name exists
739(define (bind-parameter-index stmt name)
740  (check-statement 'bind-parameter-index stmt)
741  (let ([i ((foreign-lambda int "sqlite3_bind_parameter_index"
742              sqlite3:statement nonnull-c-string)
743            stmt name)])
744    (if (zero? i)
745      #f
746      (fx- i 1))))
747
748;; Get the name of a bindable parameter
749(define (bind-parameter-name stmt i)
750  (check-statement 'bind-parameter-name stmt)
751  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int)
752    stmt (fx+ i 1)))
753
754;; Bind data as parameters to an existing statement
755
756(define (bind! stmt i v)
757  (check-statement 'bind! stmt)
758  (check-natural-integer 'bind! i)
759  (cond
760    [(blob? v)
761      (cond [((foreign-lambda* sqlite3:status
762                ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
763                "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
764              stmt (fx+ i 1) v (blob-size v))
765        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
766    [(or (and (fixnum? v) v) (and (boolean? v) (if v 1 0)))
767      => (lambda (v)
768          (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
769                    sqlite3:statement int int)
770                  stmt (fx+ i 1) v)
771            => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)]))]
772    [(real? v)
773      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_double"
774                sqlite3:statement int double)
775              stmt (fx+ i 1) v)
776        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
777    [(string? v)
778      (cond [((foreign-lambda* sqlite3:status
779                ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
780                "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
781              stmt (fx+ i 1) v (string-length v))
782        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
783    [(sql-null? v)
784      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int)
785              stmt (fx+ i 1))
786        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i)])]
787    [else
788      (error-argument-type 'bind! v "blob, number, boolean, string or sql-null")]))
789
790; Helper
791
792(define (%bind-parameters! loc stmt params)
793  (reset! stmt)
794  (let ([cnt (bind-parameter-count stmt)]
795  [vs (make-hash-table)])
796    (let loop ([i 0] [params params])
797      (match params
798        [((? keyword? k) v . rest)
799          (cond
800            [(bind-parameter-index stmt (string-append ":" (keyword->string k)))
801              => (lambda (j)
802             (hash-table-set! vs j v)
803             (loop i rest))]
804            [else
805              (error-argument-type loc k "value or keyword matching a bind parameter name")])]
806        [(v . rest)
807          (hash-table-set! vs i v)
808          (loop (fx+ i 1) rest)]
809        [()
810          (void)]))
811    (if (= (hash-table-size vs) cnt)
812      (unless (zero? cnt)
813        (hash-table-walk vs (cut bind! stmt <> <>)))
814      (abort
815        (make-composite-condition
816          (make-exn-condition
817            loc
818            (conc "bad parameter count - received " (hash-table-size vs) " but expected " cnt))
819          (make-property-condition 'arity)
820          (make-sqlite3-condition 'error))))))
821
822(define (bind-parameters! stmt . params)
823  (%bind-parameters! 'bind-parameters! stmt params))
824
825;; Single-step a prepared statement, return #t if data is available,
826;; #f otherwise
827(define (step! stmt)
828  (check-statement 'step! stmt)
829  (let ([db (statement-database stmt)])
830    (let retry ([retries 0])
831      (let ([s ((foreign-safe-lambda
832                  sqlite3:status "sqlite3_step" sqlite3:statement) stmt)])
833        (case s
834          [(row)
835            #t]
836          [(done)
837            #f]
838          [(busy)
839            (let ([h (database-busy-handler db)])
840              (cond
841                [(and h (h db retries))
842                  (retry (fx+ retries 1))]
843                [else
844                  ((abort-sqlite3-error 'step! db stmt) s)]))]
845          [else
846            ((abort-sqlite3-error 'step! db stmt) s)])))))
847
848;; Retrieve information from a prepared/stepped statement
849(define (column-count stmt)
850  (check-statement 'column-count stmt)
851  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt))
852
853(define (column-type stmt i)
854  (check-statement 'column-type stmt)
855  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i))
856
857(define (column-declared-type stmt i)
858  (check-statement 'column-declared-type stmt)
859  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i))
860
861(define (column-name stmt i)
862  (check-statement 'column-name stmt)
863  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i))
864
865;; Retrieve data from a stepped statement
866(define (column-data stmt i)
867  (case (column-type stmt i)
868    [(integer)
869      (if (and-let* ([type (column-declared-type stmt i)])
870            (string-contains-ci type "bool"))
871        ((foreign-lambda bool "sqlite3_column_int" sqlite3:statement int) stmt i)
872        ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i))]
873    [(float)
874      ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i)]
875    [(text)
876      ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
877          "int n = sqlite3_column_bytes(stmt, i);"
878          "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
879          "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));")
880        stmt i)]
881    [(blob)
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_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));")
886        stmt i)]
887    [else
888      (sql-null)]))
889
890;;; Easy statement interface
891
892;; Compile a statement and call a procedure on it, then finalize the
893;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
894(define (call-with-temporary-statements proc db . sqls)
895  (check-database 'call-with-temporary-statements db)
896  (let ([stmts #f] [exn #f])
897    (dynamic-wind
898      (lambda ()
899        (unless stmts
900          (set! stmts (map (cute prepare db <>) sqls))))
901      (lambda ()
902        (handle-exceptions e (set! exn e)
903          (apply proc stmts)))
904      (lambda ()
905        (and-let* ([s stmts])
906          (set! stmts #f)
907          (for-each finalize! s)) ;; leaks if error occurs before last stmt
908        (and-let* ([e exn])
909          (set! exn #f)
910          (signal e))))))
911
912(define-syntax %define/statement+params
913  (syntax-rules ()
914    [(%define/statement+params ((name loc) (init ...) (stmt params))
915       body ...)
916      (define name
917        (let ([impl (lambda (init ... stmt params) body ...)])
918          (lambda (init ... db-or-stmt . params)
919            (cond
920              [(database? db-or-stmt)
921                (call-with-temporary-statements
922                  (cute impl init ... <> (cdr params))
923                  db-or-stmt (car params))]
924              [(statement? db-or-stmt)
925                (impl init ... db-or-stmt params)]
926              [else
927                (error-argument-type loc db-or-stmt "database or statement")]))))]
928    [(%define/statement+params (name (init ...) (stmt params))
929       body ...)
930      (%define/statement+params ((name 'name) (init ...) (stmt params))
931        body ...)]
932    [(%define/statement+params (name stmt params)
933       body ...)
934      (%define/statement+params ((name 'name) () (stmt params))
935        body ...)]))
936
937;; Step through a statement and ignore possible results
938(define (%execute loc stmt params)
939  (%bind-parameters! loc stmt params)
940  (while (step! stmt))
941  (void))
942
943(%define/statement+params (execute stmt params)
944  (%execute 'execute stmt params))
945
946;; Step through a statement, ignore possible results and return the
947;; count of changes performed by this statement
948(%define/statement+params (update stmt params)
949  (%execute 'update stmt params)
950  (change-count (statement-database stmt)))
951
952;; Return only the first column of the first result row produced by this
953;; statement
954
955(%define/statement+params (first-result stmt params)
956  (%bind-parameters! 'first-result stmt params)
957  (if (step! stmt)
958    (let ([r (column-data stmt 0)])
959      (reset! stmt)
960      r)
961    (abort (make-no-data-condition 'first-result stmt params))))
962
963;; Return only the first result row produced by this statement as a list
964
965(%define/statement+params (first-row stmt params)
966  (%bind-parameters! 'first-row stmt params)
967  (if (step! stmt)
968    (map (cute column-data stmt <>)
969      (iota (column-count stmt)))
970    (abort (make-no-data-condition 'first-row stmt params))))
971
972;; Apply a procedure to the values of the result columns for each result row
973;; while executing the statement and accumulating results.
974
975(%define/statement+params ((%fold-row loc) (loc proc init) (stmt params))
976  (%bind-parameters! loc stmt params)
977  (let ([cl (iota (column-count stmt))])
978    (let loop ([acc init])
979      (if (step! stmt)
980  (loop (apply proc acc (map (cute column-data stmt <>) cl)))
981  acc))))
982
983(define (fold-row proc init db-or-stmt . params)
984  (check-procedure 'fold-row proc)
985  (apply %fold-row 'fold-row proc init db-or-stmt params))
986
987;; Apply a procedure to the values of the result columns for each result row
988;; while executing the statement and discard the results
989
990(define (for-each-row proc db-or-stmt . params)
991  (check-procedure 'for-each-row proc)
992  (apply %fold-row
993    'for-each-row
994    (lambda (acc . columns)
995      (apply proc columns))
996    (void)
997    db-or-stmt params))
998
999;; Apply a procedure to the values of the result columns for each result row
1000;; while executing the statement and accumulate the results in a list
1001
1002(define (map-row proc db-or-stmt . params)
1003  (check-procedure 'map-row proc)
1004  (reverse!
1005    (apply %fold-row
1006      'map-row
1007      (lambda (acc . columns)
1008        (cons (apply proc columns) acc))
1009      '()
1010      db-or-stmt params)))
1011
1012;;; Utility procedures
1013
1014;; Run a thunk within a database transaction, commit if return value is
1015;; true, rollback if return value is false or the thunk is interrupted by
1016;; an exception
1017(define (with-transaction db thunk #!optional (type 'deferred))
1018  (check-database 'with-transaction db)
1019  (check-procedure 'with-transaction thunk)
1020  (unless (memq type '(deferred immediate exclusive))
1021    (abort
1022      (make-composite-condition
1023        (make-exn-condition 'with-transaction
1024          "bad argument: expected deferred, immediate or exclusive"
1025          type)
1026        (make-property-condition 'type))))
1027  (let ([success? #f] [exn #f])
1028    (dynamic-wind
1029      (lambda ()
1030        (execute db
1031          (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
1032      (lambda ()
1033        (handle-exceptions e (begin
1034                               (print-error "with-transaction" exn)
1035                               (set! exn e))
1036          (set! success? (thunk))
1037          success?))
1038      (lambda ()
1039        (execute db
1040          (if success?
1041            "COMMIT TRANSACTION;"
1042            "ROLLBACK TRANSACTION;"))
1043        (and-let* ([e exn])
1044          (set! exn #f)
1045          (signal e))))))
1046
1047;; Check if the given string is a valid SQL statement
1048(define sql-complete?
1049  (foreign-lambda bool "sqlite3_complete" nonnull-c-string))
1050
1051;; Return a descriptive version string
1052(define database-version
1053  (foreign-lambda c-string "sqlite3_libversion"))
1054
1055;; Return the amount of memory currently allocated by the database
1056(define database-memory-used
1057  (foreign-lambda integer "sqlite3_memory_used"))
1058
1059;; Return the maximum amount of memory allocated by the database since
1060;; the counter was last reset
1061(define (database-memory-highwater #!optional reset?)
1062  ((foreign-lambda integer "sqlite3_memory_highwater" bool) reset?))
1063
1064;; Enables (disables) the sharing of the database cache and schema data
1065;; structures between connections to the same database.
1066(define (enable-shared-cache! enable?)
1067  (cond-expand
1068   [disable-shared-cache
1069    #f]
1070   [else
1071    (cond
1072     [((foreign-lambda sqlite3:status "sqlite3_enable_shared_cache" bool) enable?)
1073      => (abort-sqlite3-error 'enable-shared-cache! #f)]
1074     [else
1075      enable?])]))
1076
1077;; Enables (disables) the loading of native extensions using SQL statements.
1078(define (enable-load-extension! db enable?)
1079  (cond-expand
1080   [disable-load-extension
1081    #f]
1082   [else
1083    (cond
1084     [((foreign-lambda sqlite3:status "sqlite3_enable_load_extension" sqlite3:database bool) db enable?)
1085      => (abort-sqlite3-error 'enable-load-extension! db)]
1086     [else
1087      enable?])]))
1088
1089)
1090
1091;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;
Note: See TracBrowser for help on using the repository browser.