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

Last change on this file since 10528 was 10528, checked in by Jim Ursetto, 12 years ago

sqlite3: ensure with-transaction returns thunk result

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