(module sqld-i-sqlite mzscheme
(require (lib "foreign.ss")) (unsafe!)
(provide c-sqlite-open
c-sqlite-close
c-sqlite-query
c-sqlite-cell
c-sqlite-nrows
c-sqlite-ncols
c-sqlite-lasterr
c-sqlite-version)
(define libsqlite
(letrec ((trylibs (lambda (lib libs)
(if (null? lib)
(error (format "Cannot load C library: none of:\n~aworked"
(apply string-append
(map (lambda (l)
(format " ~a\n" l))
libs))))
(let ((L (with-handlers ((exn:fail? (lambda (exn) #f)))
(ffi-lib (car lib)))))
(if (eq? L #f)
(trylibs (cdr lib) libs)
L))))))
(let ((L '("sqlite3" "libsqlite3"
"/usr/lib/sqlite3" "/usr/lib/libsqlite3"
"/usr/local/lib/sqlite3" "/usr/local/lib/libsqlite3")))
(if (not (eq? (getenv "LIBSQLITE") #f))
(set! L (cons (format "~a/sqlite3" (getenv "LIBSQLITE"))
(cons (format "~a/libsqlite3" (getenv "LIBSQLITE"))
L))))
(trylibs L L))))
(define _sqlite_callback (_fun _scheme _int _pointer _pointer -> _int))
(define _busy_callback (_fun _scheme _int -> _int))
(define sqlite3-open (get-ffi-obj "sqlite3_open"
libsqlite
(_fun (file : _string)
(handle : (_ptr o _pointer))
-> (result : _int)
-> (values handle result))))
(define sqlite3-close (get-ffi-obj "sqlite3_close"
libsqlite
(_fun (handle : _pointer)
-> (result : _int)
-> result)))
(define sqlite3-exec (get-ffi-obj "sqlite3_exec"
libsqlite
(_fun (handle : _pointer)
(sql : _string)
(callback : _sqlite_callback)
(context : _scheme)
(errmsg : (_ptr o _string))
-> (result : _int)
-> (values result errmsg))))
(define sqlite3-errmsg (get-ffi-obj "sqlite3_errmsg"
libsqlite
(_fun (handle : _pointer)
-> _string)))
(define sqlite3-libversion (get-ffi-obj "sqlite3_libversion"
libsqlite
(_fun -> _string)))
(define sqlite3-busy-handler (get-ffi-obj "sqlite3_busy_handler"
libsqlite
(_fun (handle : _pointer)
(callback : _busy_callback)
(context : _scheme)
-> _int)))
(define sqlite3-busy-timeout (get-ffi-obj "sqlite3_busy_timeout"
libsqlite
(_fun (handle : _pointer)
(millisec : _int)
-> _int)))
(define-struct sqlite-handle (handle err-message err))
(define-struct sqlite-result (strings ncols nrows handle))
(define (sqlite-i-callback adder columns pvalues names)
(let ((values (cvector->list (make-cvector* pvalues _string columns))))
(adder columns values))
0)
(define (sqlite-i-busy-callback obj times) (sleep 0.1)
1)
(define (c-sqlite-open file . busytimeout)
(if (null? busytimeout) (set! busytimeout 30000)) (call-with-values (lambda () (sqlite3-open file))
(lambda (handle r)
(register-finalizer handle sqlite3-finalize-handle)
(sqlite3-busy-handler handle sqlite-i-busy-callback #f)
(if (= r 0)
(make-sqlite-handle handle "" #f)
(make-sqlite-handle #f (sqlite3-errmsg handle) #t)))))
(define (sqlite3-finalize-handle handle)
(sqlite3-close handle))
(define (c-sqlite-close handle)
(set-sqlite-handle-handle! handle #f)
#t)
(define (c-sqlite-query handle query)
(let ((R (list))
(ncols #f))
(let ((adder (lambda (colcount values)
(set! R (cons values R))
(set! ncols colcount))))
(call-with-values
(lambda ()
(sqlite3-exec (sqlite-handle-handle handle) query sqlite-i-callback adder))
(lambda (result errmsg)
(if (= result 0)
(begin
(set-sqlite-handle-err-message! handle "")
(set-sqlite-handle-err! handle #f)
(make-sqlite-result (list->vector (reverse R))
ncols
(length R)
handle))
(begin
(set-sqlite-handle-err-message! handle errmsg)
(set-sqlite-handle-err! handle #t)
(make-sqlite-result (vector) ncols 0 handle))))))))
(define (c-sqlite-nrows result)
(sqlite-result-nrows result))
(define (c-sqlite-ncols result)
(sqlite-result-ncols result))
(define (c-sqlite-lasterr handle-or-result)
(if (sqlite-result? handle-or-result)
(c-sqlite-lasterr (sqlite-result-handle handle-or-result))
(sqlite-handle-err-message handle-or-result)))
(define (c-sqlite-cell result row col)
(list-ref (vector-ref (sqlite-result-strings result) row) col))
(define (c-sqlite-version)
(let ((S (sqlite3-libversion)))
S))
)