(module sqlite mzscheme
(require (lib "etc.ss")
(lib "list.ss")
(lib "contract.ss")
(lib "sqlite-ffi.ss" "sqlite"))
(provide (all-defined))
(define-struct db (_db_ptr _errMsg_ptr _callback_ptr))
(define/contract db-handle
(db? . -> . cpointer?)
(lambda (db)
(ptr-ref (db-_db_ptr db) _sqlite3_ptr)))
(define-struct statement (_stmt_ptr))
(define/contract statement-handle
(statement? . -> . cpointer?)
(lambda (stmt)
(ptr-ref (statement-_stmt_ptr stmt) _sqlite3_stmt_ptr)))
(define/contract list->equal-sublists
(integer? list? . -> . (listof list?))
(lambda (n l)
(let loop ([l l] [i 0] [r `()])
(if (null? l)
(reverse r)
(loop (cdr l) (modulo (+ i 1) n)
(if (= i 0)
(append (list (list (car l)))
r)
(append (list (append (car r) (list (car l))))
(cdr r))))))))
(define/contract sqlite-ok?
(integer? . -> . boolean?)
(lambda (s)
(= s SQLITE_OK)))
(define/contract wrap-finalizer
(any/c (any/c . -> . any/c) . -> . any/c)
(lambda (o f)
(register-finalizer o f)
o))
(define/contract open
(string? . -> . db?)
(lambda (db-path)
(let ([r (wrap-finalizer (make-db (malloc _sqlite3_ptr_ptr)
(malloc _string_ptr)
(malloc _pointer))
close)])
(if (sqlite-ok? (sqlite3_open db-path (db-_db_ptr r)))
r
#f))))
(define/contract close
(db? . -> . integer?)
(lambda (db)
(let ([s #f])
(when (db-_db_ptr db)
(set! s (sqlite3_close (db-handle db)))
(free (db-_db_ptr db))
(set-db-_db_ptr! db #f))
(when (db-_errMsg_ptr db)
(free (db-_errMsg_ptr db))
(set-db-_errMsg_ptr! db #f))
(when (db-_callback_ptr db)
(free (db-_callback_ptr db))
(set-db-_callback_ptr! db #f))
s)))
(define/contract exec
(db? string? (list? list? . -> . integer?) . -> . integer?)
(lambda (db sql callback)
(sqlite3_exec (db-handle db)
sql
(contract
(cpointer? integer? cpointer? cpointer? . -> . integer?)
(lambda (arg_ptr column-count_int column-values_ptr column-names_ptr)
(callback
(cvector->list (make-cvector* column-names_ptr _string column-count_int))
(cvector->list (make-cvector* column-values_ptr _string column-count_int))))
'positive 'negative)
(db-_callback_ptr db)
(db-_errMsg_ptr db))))
(define/contract exec/ignore
(db? string? . -> . integer?)
(lambda (db sql)
(exec db sql (lambda (c v) 0))))
(define/contract select
(db? string? . -> . (listof list?))
(lambda (db sql)
(let ([result_ptr_ptr (wrap-finalizer (malloc _string_array_ptr)
(lambda (ptr)
(when ptr
(sqlite3_free_table (ptr-ref ptr _string_array)))
(free ptr)))]
[row-count_ptr (wrap-finalizer (malloc _int_ptr) free)]
[column-count_ptr (wrap-finalizer (malloc _int_ptr) free)])
(if (sqlite3_get_table (db-handle db)
sql
result_ptr_ptr
row-count_ptr
column-count_ptr
(db-_errMsg_ptr db))
(list->equal-sublists (ptr-ref column-count_ptr _int)
(cvector->list (make-cvector* (ptr-ref result_ptr_ptr _string_array) _string
(* (+ (ptr-ref row-count_ptr _int) 1)
(ptr-ref column-count_ptr _int)))))
#f))))
(define/contract prepare
(db? string? . -> . statement?)
(lambda (db sql)
(let ([stmt (wrap-finalizer (make-statement (malloc _sqlite3_stmt_ptr_ptr))
finalize)])
(if (sqlite-ok? (sqlite3_prepare (db-handle db)
sql
(string-length sql)
(statement-_stmt_ptr stmt)
(db-_errMsg_ptr db)))
stmt
(begin (finalize stmt)
#f)))))
(define/contract load-params
((statement?) (listof string?) . ->* . (integer?))
(lambda (stmt . params)
(when (sqlite-ok? (sqlite3_reset (statement-handle stmt)))
(let ([SQLITE_TRANSIENT/sleaziness -1])
(foldl
+ 0
(map
(lambda (i)
(sqlite3_bind_text (statement-handle stmt) (+ i 1)
(list-ref params i)
(string-length (list-ref params i))
SQLITE_TRANSIENT/sleaziness))
(build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity)))))))
(define/contract step
(statement? . -> . any/c)
(lambda (stmt)
(let ([s (sqlite3_step (statement-handle stmt))])
(if (= s SQLITE_ROW)
(map (lambda (i) (sqlite3_column_text (statement-handle stmt) i))
(build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))
(list)))))
(define/contract run
((statement?) (listof string?) . ->* . (integer?))
(lambda (stmt . params)
(when (apply load-params (append (list stmt) params))
(sqlite3_step (statement-handle stmt)))))
(define/contract finalize
(statement? . -> . integer?)
(lambda (stmt)
(let ([s 1])
(when (statement-_stmt_ptr stmt)
(set! s (sqlite3_finalize (statement-handle stmt)))
(free (statement-_stmt_ptr stmt))
(set-statement-_stmt_ptr! stmt #f))
s)))
(define/contract lock-type->string
((symbols 'none 'deferred 'immediate 'exclusive) . -> . string?)
(lambda (lock-type)
(case lock-type
[(none) ""]
[(deferred) "DEFERRED"]
[(immediate) "IMMEDIATE"]
[(exclusive) "EXCLUSIVE"])))
(define-syntax transaction/lock
(syntax-rules ()
[(_ db lock-type fail body ...)
(let ([end (lambda () (exec/ignore db "ROLLBACK TRANSACTION"))])
(exec/ignore db (format "BEGIN ~a TRANSACTION" (lock-type->string 'lock-type)))
(let/ec fail
body
...
(set! end (lambda () (exec/ignore db "COMMIT TRANSACTION"))))
(end)
(exec/ignore db "END TRANSACTION"))]))
(define-syntax transaction
(syntax-rules ()
[(_ db fail body ...)
(transaction/lock db none fail body ...)]))
(define/contract changes-count
(db? . -> . integer?)
(lambda (db)
(sqlite3_changes (db-handle db))))
(define/contract total-changes-count
(db? . -> . integer?)
(lambda (db)
(sqlite3_total_changes (db-handle db)))))