source: project/release/3/sqlite3/trunk/sqlite3.scm @ 7981

Last change on this file since 7981 was 7981, checked in by Kon Lovett, 12 years ago

Made sqlite3 null column value Scheme value explicit. Added note about the sql-null egg. Collapsed some common code into shared procedures.

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