sqlite.ss
#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBD-JSQLITE.plt
;;
;; DBD Wrapper over jaymccarty/sqlite.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sqlite.ss - defines and registers the jsqlite driver.
;; yc 9/9/2009 - first version
(require (prefix-in dbd: (planet jaymccarthy/sqlite:4:5))
         (planet bzlib/base)
         (planet bzlib/dbi)
         srfi/19
         )

(define (sqlite-connect driver path . attrs)
  (let-values (((loader attrs)
                (filter-file-loader/attrs attrs)))
  (let ((handle (make-handle driver (dbd:open path)
                             (make-immutable-hash-registry)
                             0)))
      (load-files! handle (if (list? loader) loader
                              (list loader)))
      handle)))

(define (sqlite-disconnect handle)
  ;; we need to free all of the values from the hash-registry...
  (hash-for-each (registry-table (handle-query handle))
                 (lambda (key prepared)
                   (dbd:finalize (prepared-inner prepared))))
  (dbd:close (handle-conn handle)))

(define (sqlite-query handle stmt (args '()))
  (convert-result
   (if (symbol? stmt) ;; check to see if it exists....
       (if-it (registry-ref (handle-query handle) stmt) ;; yes it exists!!!...
              (begin
                (let ((query (prepared-query it)) 
                      (stmt (prepared-inner it)))
                  (apply dbd:load-params stmt (map cell->sql-cell (phq-map-values query args)))
                  (begin0 
                    (dbd:step* stmt)
                    (dbd:reset stmt))))
              (error 'query "unknown prepared statement ~a" stmt))
       (let ((query (make-place-holder-query default-converter stmt)))
         (apply dbd:select 
                (handle-conn handle) 
                (phq-query query)
                (map cell->sql-cell (phq-map-values query args)))))))

(define (sqlite-prepare handle key stmt)
  (let ((query (make-place-holder-query default-converter stmt)))
    (registry-set! (handle-query handle)
                   key
                   (make-prepared query
                                  (dbd:prepare (handle-conn handle) (phq-query query))))))

(define (convert-result result)
  (if (null? result) (void)
      (map (lambda (rec)
             (map sql-cell->cell (vector->list rec)))
           result)))

(define (sql-cell->cell cell)
  (cond ((eq? #f cell) '())
        (else cell)))

(define (cell->sql-cell cell)
  (cond ((null? cell) #f)
        (else cell)))

(registry-set! drivers 'jsqlite
               (make-driver sqlite-connect
                            sqlite-disconnect
                            sqlite-query
                            sqlite-prepare
                            default-begin
                            default-commit
                            default-rollback))