source: project/release/3/sqlite3/tags/2.0.5/sqlite3.scm @ 8688

Last change on this file since 8688 was 8688, checked in by Kon Lovett, 14 years ago

Rel 2.0.5

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