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

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

Bug fix & new procs.

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