;; This file is part of SQLite3 for CHICKEN
;; Copyright (c) 2005-2018, Thomas Chust <chust@web.de>.  All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;;   Redistributions of source code must retain the above copyright notice,
;;   this list of conditions and the following disclaimer. Redistributions in
;;   binary form must reproduce the above copyright notice, this list of
;;   conditions and the following disclaimer in the documentation and/or
;;   other materials provided with the distribution. Neither the name of the
;;   author nor the names of its contributors may be used to endorse or
;;   promote products derived from this software without specific prior
;;   written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(declare
  (usual-integrations)
  (no-procedure-checks-for-usual-bindings)
  (unused
    ; Stop annoying messages
    sqlite3#chicken_sqlite3_function_stub
    sqlite3#chicken_sqlite3_collation_stub
    sqlite3#chicken_sqlite3_final_stub
    sqlite3#chicken_sqlite3_step_stub
    ; These may have to be changed if definitions are added,
    ; removed or reordered:
    sqlite3#g166 sqlite3#g366 sqlite3#g484 sqlite3#g566)
  (bound-to-procedure
    sqlite3#sqlite3_errmsg))

#>
#include <stdint.h>
#include <sqlite3.h>
<#

(module sqlite3
  ( ;; type predicates and checks
    database?
    error-database
    check-database
    statement?
    error-statement
    check-statement
    ;; procedures
    open-database
    define-collation
    define-function
    set-busy-handler!
    make-busy-timeout
    interrupt!
    auto-committing?
    change-count
    last-insert-rowid
    finalize!
    prepare
    source-sql
    reset!
    bind-parameter-count
    bind-parameter-index
    bind-parameter-name
    bind!
    bind-parameters!
    step!
    column-count
    column-type
    column-declared-type
    column-name
    column-data
    call-with-temporary-statements
    execute
    update
    first-result
    first-row
    fold-row
    for-each-row
    map-row
    with-transaction
    sql-complete?
    database-version
    database-memory-used
    database-memory-highwater
    enable-shared-cache!
    enable-load-extension!
  )

(import
  scheme
  (chicken base)
  (chicken foreign)
  (chicken condition)
  (chicken string)
  (chicken keyword)
  (chicken fixnum)
  (chicken blob)
  (chicken memory)
  (chicken format)
  (srfi 1)
  (srfi 13)
  (srfi 18)
  (srfi 69)
  object-evict
  type-errors
  type-checks
  synch
  miscmacros
  matchable
  sql-null)

;;; Foreign types & values

;; Enumeration and constant definitions

(define-syntax %define-enum-type
  (syntax-rules ()
    [(%define-enum-type (sname cname) (sv cv) ...)
    (define-foreign-type sname
      (enum cname)
      (lambda (v)
        (case v
          [(sv) (foreign-value cv int)]
          ...
          [else
            (error-argument-type 'sname v "enumeration value")]))
            (lambda (v)
        (select v
          [((foreign-value cv int)) 'sv]
          ...
          [else
            (error-argument-type 'sname v "enumeration index")])))]))

(%define-enum-type (sqlite3:status "sqlite3_status")
  (#f                                                           "SQLITE_OK")      ; Successful result
  (error                                "SQLITE_ERROR")   ; SQL error or missing database
  (internal                                     "SQLITE_INTERNAL")        ; NOT USED. Internal logic error in SQLite
  (permission                           "SQLITE_PERM")    ; Access permission denied
  (abort                                "SQLITE_ABORT")   ; Callback routine requested an abort
  (busy                                 "SQLITE_BUSY")    ; The database file is locked
  (locked                               "SQLITE_LOCKED")          ; A table in the database is locked
  (no-memory                    "SQLITE_NOMEM")   ; A malloc() failed
  (read-only                    "SQLITE_READONLY")        ; Attempt to write a readonly database
  (interrupt                    "SQLITE_INTERRUPT")       ; Operation terminated by sqlite3_interrupt()
  (io-error                     "SQLITE_IOERR")   ; Some kind of disk I/O error occurred
  (corrupt                      "SQLITE_CORRUPT")         ; The database disk image is malformed
  (not-found                    "SQLITE_NOTFOUND")        ; NOT USED. Table or record not found
  (full                                 "SQLITE_FULL")    ; Insertion failed because database is full
  (cant-open                    "SQLITE_CANTOPEN")        ; Unable to open the database file
  (protocol                     "SQLITE_PROTOCOL")        ; NOT USED. Database lock protocol error
  (empty                                "SQLITE_EMPTY")   ; Database is empty
  (schema                               "SQLITE_SCHEMA")          ; The database schema changed
  (too-big                      "SQLITE_TOOBIG")          ; String or BLOB exceeds size limit
  (constraint                   "SQLITE_CONSTRAINT")      ; Abort due to contraint violation
  (mismatch                     "SQLITE_MISMATCH")        ; Data type mismatch
  (misuse                               "SQLITE_MISUSE")          ; Library used incorrectly
  (no-lfs                               "SQLITE_NOLFS")   ; Uses OS features not supported on host
  (authorization                "SQLITE_AUTH")    ; Authorization denied
  (format                               "SQLITE_FORMAT")          ; Auxiliary database format error
  (range                                "SQLITE_RANGE")   ; 2nd parameter to sqlite3_bind out of range
  (not-a-database               "SQLITE_NOTADB")          ; File opened that is not a database file
  (row                                  "SQLITE_ROW")             ; sqlite3_step() has another row ready
  (done                                 "SQLITE_DONE"))   ; sqlite3_step() has finished executing

(%define-enum-type (sqlite3:type "sqlite3_type")
  (integer      "SQLITE_INTEGER")
  (float                "SQLITE_FLOAT")
  (text                 "SQLITE_TEXT")
  (blob                 "SQLITE_BLOB")
  (null                 "SQLITE_NULL"))

;; Auxiliary types

(define-foreign-type sqlite3:context
  (c-pointer "sqlite3_context"))

(define-foreign-type sqlite3:value
  (c-pointer "sqlite3_value"))

;; Types for databases and statements

(define-record-type sqlite3:database
  (make-database ptr busy-handler)
  database?
  (ptr database-ptr database-ptr-set!)
  (busy-handler database-busy-handler database-busy-handler-set!))

(define-record-printer (sqlite3:database db out)
  (display
    (if (database-ptr db)
      "#<sqlite3:database>"
      "#<sqlite3:database zombie>")
    out))

(define-check+error-type database)

(define-foreign-type sqlite3:database
  (nonnull-c-pointer "sqlite3")
  database-ptr
  (cut make-database <> #f))

(define-record-type sqlite3:statement
  (make-statement ptr database)
  statement?
  (ptr statement-ptr statement-ptr-set!)
  (database statement-database))

(define-record-printer (sqlite3:statement stmt out)
  (display
    (if (statement-ptr stmt)
      (sprintf "#<sqlite3:statement sql=~s>" (source-sql stmt))
      "#<sqlite3:statement zombie>")
    out))

(define-check+error-type statement)

(define-foreign-type sqlite3:statement
  (nonnull-c-pointer "sqlite3_stmt")
  statement-ptr
  (cut make-statement <> #f))

;;; Helpers

;; Conditions

(define (make-exn-condition loc msg . args)
  (make-property-condition 'exn 'location loc 'message msg 'arguments args))

(define (make-sqlite3-condition sta)
  (make-property-condition 'sqlite3 'status sta))

(define (make-sqlite3-error-condition loc msg sta . args)
  (make-composite-condition
    (apply make-exn-condition loc msg args)
    (make-sqlite3-condition sta)))

(define (make-no-data-condition loc stmt params)
  (make-sqlite3-error-condition loc
    "the statement returned no data"
    'done
    stmt params))

;; Errors
(define ((abort-sqlite3-error loc db . args) sta)
  (abort
    (apply make-sqlite3-error-condition
      loc
      (if db (sqlite3_errmsg db) (symbol->string sta))
      sta
      args)))

(define (print-error msg obj)
  (print-error-message obj (current-error-port) (string-append "Error: " msg)))

;; Tree dictionary

(define (make-synch-hash-table-tree id . args)
  (make-synch-with-object (apply make-hash-table args) id))

(define (hash-table-tree-set! ht-tree keys value)
  (if (null? (cdr keys))
    (hash-table-set! ht-tree (car keys) value)
    (hash-table-update! ht-tree
      (car keys)
      (cute hash-table-tree-set! <> (cdr keys) value)
      (cut make-hash-table)))
  ht-tree)

(define (hash-table-tree-delete! ht-tree keys)
  (if (null? (cdr keys))
    (hash-table-delete! ht-tree (car keys))
    (hash-table-update! ht-tree
      (car keys)
      (cute hash-table-tree-delete! <> (cdr keys))
      (cut make-hash-table)))
  ht-tree)

(define (hash-table-tree-ref
          ht-tree keys
          #!optional
          (thunk (cut abort
            (make-composite-condition
              (make-exn-condition 'hash-table-tree-ref
                "hash-table-tree does not contain path"
                ht-tree keys)
              (make-property-condition 'access)))))
  (let/cc return
    (let loop ([ht ht-tree] [keys keys])
      (if (null? keys)
  ht
  (loop (hash-table-ref ht (car keys) (cut return (thunk)))
    (cdr keys))))))

(define (hash-table-tree-ref/default ht-tree keys default)
  (hash-table-tree-ref ht-tree keys (lambda () default)))

(define (hash-table-tree-clear! htt id elt-clear)
  (cond [(hash-table-ref/default htt id #f)
    => (cute hash-table-walk <> elt-clear)])
  (hash-table-delete! htt id))

;; SQL collation sequence interface

(define *collations* (make-synch-hash-table-tree 'sqlite3:collations))

(define-external (chicken_sqlite3_collation_stub
                  (scheme-object qn) (int la)
                  (c-pointer da) (int lb)
                  (c-pointer db)) int
  (let/cc return
    (let ([r #f])
      (dynamic-wind
        void
        (lambda ()
          (handle-exceptions exn
            (print-error "in collation function" exn)
            (let ([a (make-string la)]
                  [b (make-string lb)])
              (move-memory! da a la)
              (move-memory! db b lb)
              (set! r
                ((vector-ref
                  (call-synch-with *collations*
                    (cute hash-table-tree-ref <> qn))
                  1)
                  a b)))))
        (lambda ()
          (if (fixnum? r)
            (return r)
            (begin
              (print-error "in collation function: invalid return value" (->string r))
              (return 0))))))))

(define sqlite3_create_collation
  (foreign-lambda* sqlite3:status
    ((sqlite3:database db) (c-string name) (scheme-object qn))
#<<EOS
    if (qn == C_SCHEME_FALSE)
    return(sqlite3_create_collation(db, name, SQLITE_UTF8, NULL, NULL));
    else
    return(sqlite3_create_collation(db, name, SQLITE_UTF8,
            (void *)qn,
            (int (*)(void *,
                int, const void *,
                int, const void *))
            &chicken_sqlite3_collation_stub));
EOS
    ))

(define (define-collation db name #!optional proc)
  (check-database 'define-collation db)
  (check-string 'define-collation name)
  (if proc
    (begin
      (check-procedure 'define-collation proc)
      (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))])
  (cond
    [(sqlite3_create_collation db name qn)
      => (lambda (s)
    (object-release qn)
    ((abort-sqlite3-error 'define-collation db name proc) s))]
    [else
      (call-synch-with *collations*
        (cute hash-table-tree-set! <> qn (vector qn proc)))])))
    (cond
      [(sqlite3_create_collation db name #f)
        => (abort-sqlite3-error 'define-collation db name)]
      [else
        (let ([qn (list (pointer->address (database-ptr db)) name)])
          (call-synch-with *collations*
            (lambda (col)
              (cond [(hash-table-tree-ref/default col qn #f)
                => (lambda (info)
                    (hash-table-tree-delete! col qn)
                    (object-release (vector-ref info 0)))]))))])))

;;; SQL function interface

(define *functions* (make-synch-hash-table-tree 'sqlite3:functions))

(define *seeds* (make-synch-hash-table-tree 'sqlite3:seeds))

(define (parameter-data n args)
  (let loop ([i 0])
    (if (fx<= n i)
      '()
      (cons (case ((foreign-lambda* sqlite3:type
          (((c-pointer sqlite3:value) args) (int i))
          "return(sqlite3_value_type(args[i]));")
        args i)
        [(integer)
          ((foreign-lambda* integer
              (((c-pointer sqlite3:value) args) (int i))
              "return(sqlite3_value_double(args[i]));")
            args i)]
        [(float)
          ((foreign-lambda* double
              (((c-pointer sqlite3:value) args) (int i))
              "return(sqlite3_value_double(args[i]));")
            args i)]
        [(text)
          ((foreign-primitive scheme-object
              (((c-pointer sqlite3:value) args) (int i))
              "int n = sqlite3_value_bytes(args[i]);"
              "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
              "return(C_string(&s, n, (char *)sqlite3_value_text(args[i])));")
            args i)]
        [(blob)
          ((foreign-primitive scheme-object
              (((c-pointer sqlite3:value) args) (int i))
              "int n = sqlite3_value_bytes(args[i]);"
              "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
              "return(C_bytevector(&s, n, (char *)sqlite3_value_blob(args[i])));")
            args i)]
        [else
          (sql-null)])
  (loop (fx+ i 1))))))

(define (set-result! ctx v)
  (cond
    [(blob? v)
      ((foreign-lambda* void
          ((sqlite3:context ctx) (scheme-pointer v) (int n))
          "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
        ctx v (blob-size v))]
    [(boolean? v)
      ((foreign-lambda void "sqlite3_result_int" sqlite3:context bool)
        ctx v)]
    [(exact-integer? v)
      ((foreign-lambda void "sqlite3_result_int64" sqlite3:context integer64)
        ctx v)]
    [(real? v)
      ((foreign-lambda void "sqlite3_result_double" sqlite3:context double)
        ctx v)]
    [(string? v)
      ((foreign-lambda* void
          ((sqlite3:context ctx) (scheme-pointer v) (int n))
          "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);")
        ctx v (string-length v))]
    [(sql-null? v)
      ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
        ctx)]
    [else
      (error-argument-type 'set-result! v "blob, number, boolean, string or sql-null")]))

(define sqlite3_user_data
  (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context))

(define-external (chicken_sqlite3_function_stub
      (c-pointer ctx) (int n) (c-pointer args)) void
  (let/cc return
    (dynamic-wind
      void
      (lambda ()
        (handle-exceptions exn
          (print-error "in SQL function" exn)
          (set-result!
            ctx
            (apply (vector-ref
                      (call-synch-with *functions*
                        (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))
                      1)
              (parameter-data n args)))))
      (lambda ()
        (return (void))))))

(define sqlite3_aggregate_context
  (foreign-lambda* integer ((sqlite3:context ctx))
    "return((intptr_t)sqlite3_aggregate_context(ctx, 1));"))

(define-external (chicken_sqlite3_step_stub
      (c-pointer ctx) (int n) (c-pointer args)) void
  (let/cc return
    (dynamic-wind
      void
      (lambda ()
        (handle-exceptions exn
          (print-error "in step of SQL function" exn)
          (let ([info (call-synch-with *functions*
                        (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
            (call-synch-with *seeds*
              (cute hash-table-update!/default
                <>
                (sqlite3_aggregate_context ctx)
                (lambda (seed)
                  (apply (vector-ref info 1) seed (parameter-data n args)))
                (vector-ref info 2))))))
      (lambda ()
        (return (void))))))

(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
  void
  (let/cc return
    (let ([agc (sqlite3_aggregate_context ctx)])
      (dynamic-wind
        void
        (lambda ()
          (handle-exceptions exn
            (print-error "in final of SQL function" exn)
            (let ([info (call-synch-with *functions*
            (cute hash-table-tree-ref <> (sqlite3_user_data ctx)))])
              (cond
          [((vector-ref info 3)
            (call-synch-with *seeds*
              (cute hash-table-ref/default <> agc (vector-ref info 2))))
            => (cute set-result! ctx <>)]
          [else
            (set-result! ctx (sql-null))]))))
        (lambda ()
          (call-synch-with *seeds*
            (cute hash-table-delete! <> agc))
          (return (void)))))))

(define define-function
  (case-lambda
    [(db name n proc)
      (check-database 'define-function db)
      (check-string 'define-function name)
      (check-natural-number 'define-function (fx+ n 1))
      (check-procedure 'define-function proc)
      (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))])
        (cond
          [((foreign-lambda* sqlite3:status
              ((sqlite3:database db)
                (c-string name) (int n) (scheme-object qn))
#<<EOS
            return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
                    (void *)qn,
                    (void (*)(sqlite3_context *, int,
                        sqlite3_value **))
                    &chicken_sqlite3_function_stub,
                    NULL,
                    NULL));
EOS
      )
      db name n qn)
      => (lambda (s)
          (object-release qn)
          ((abort-sqlite3-error 'define-function db name n proc) s))]
    [else
      (call-synch-with *functions*
        (cute hash-table-tree-set! <> qn (vector qn proc)))]))]
    [(db name n step-proc seed . final-proc)
      (check-database 'define-function db)
      (check-string 'define-function name)
      (check-natural-number 'define-function (fx+ n 1))
      (let ([final-proc (optional final-proc identity)])
        (check-procedure 'define-function step-proc)
        (check-procedure 'define-function final-proc)
        (let ([qn (object-evict (list (pointer->address (database-ptr db)) name))])
          (cond
            [((foreign-lambda* sqlite3:status
                ((sqlite3:database db)
                  (c-string name) (int n) (scheme-object qn))
#<<EOS
                return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
                          (void *)qn,
                          NULL,
                          (void (*)(sqlite3_context *,
                              int, sqlite3_value **))
                          &chicken_sqlite3_step_stub,
                          (void (*)(sqlite3_context *))
                          &chicken_sqlite3_final_stub));
EOS
              )
              db name n qn)
              => (lambda (s)
                  (object-release qn)
                  ((abort-sqlite3-error
                      'define-function db name n step-proc seed final-proc) s))]
            [else
              (call-synch-with *functions*
                (cute hash-table-tree-set! <> qn (vector qn step-proc seed final-proc)))])))]))

;;; Database interface

;; Get any error message
(define sqlite3_errmsg
  (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database))

;; Open a database
(define (open-database path)
  (check-string 'open-database path)
  (let-location ([db sqlite3:database])
    (cond
      [((foreign-lambda sqlite3:status "sqlite3_open"
          nonnull-c-string (c-pointer sqlite3:database))
        path #$db)
        => (abort-sqlite3-error 'open-database #f path)]
      [else
        db])))

;; Set application busy handler.  Does not use a callback, so it is safe
;; to yield.  Handler is called with DB, COUNT and LAST (the last value
;; it returned).  Return true value to continue trying, or #f to stop.
(define (set-busy-handler! db handler)
  (check-database 'set-busy-handler! db)
  (database-busy-handler-set! db handler))

;; Returns a closure suitable for use with set-busy-handler!.  Identical
;; to sqlite's default busy handler, but does not block.
(define (make-busy-timeout timeout)
  (define (thread-sleep!/ms ms)
    (thread-sleep! (/ ms 1000)))
  (let* ([delays '#(1 2 5 10 15 20 25 25 25 50 50 100)]
         [totals '#(0 1 3  8 18 33 53 78 103 128 178 228)]
         [ndelay (vector-length delays)])
    (lambda (db count)
      (let* ([delay (vector-ref delays (fxmin count (fx- ndelay 1)))]
             [prior (if (fx< count ndelay)
                        (vector-ref totals count)
                        (fx+ (vector-ref totals (fx- ndelay 1))
                             (fx* delay (fx- count (fx- ndelay 1)))))])
        (let ([delay (if (fx> (fx+ prior delay) timeout)
                         (fx- timeout prior)
                         delay)])
          (cond
           [(fx<= delay 0) #f]
           [else
            (thread-sleep!/ms delay)
            #t]))))))

;; Cancel any running database operation as soon as possible
(define (interrupt! db)
  (check-database 'interrupt! db)
  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db))

;; Check whether the database is in autocommit mode
(define (auto-committing? db)
  (check-database 'auto-committing? db)
  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db))

;; Get the number of changes made to the database
(define (change-count db #!optional (total #f))
  (check-database 'change-count db)
  (if total
    ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
    ((foreign-lambda number "sqlite3_changes" sqlite3:database) db)))

;; Get the row ID of the last inserted row
(define (last-insert-rowid db)
  (check-database 'last-insert-rowid db)
  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db))

;; Close a database or statement handle
(define sqlite3_finalize
  (foreign-lambda sqlite3:status "sqlite3_finalize" nonnull-c-pointer))

(define sqlite3_next_stmt
  (foreign-lambda c-pointer "sqlite3_next_stmt" sqlite3:database c-pointer))

(define finalize!
  (match-lambda*
    [((? database? db) . finalize-statements?)
      (cond
        [(not (database-ptr db))
          (void)]
        [(let loop ([stmt
                      (and
                        (optional finalize-statements? #f)
                        (sqlite3_next_stmt db #f))])
           (if stmt
             (or (sqlite3_finalize stmt) (loop (sqlite3_next_stmt db stmt)))
             ((foreign-safe-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)))
          => (abort-sqlite3-error 'finalize! db db)]
        [else
          (let ([id (pointer->address (database-ptr db))]
                [release-qns (lambda (_ info) (object-release (vector-ref info 0)))])
            (call-synch-with *collations*
              (cute hash-table-tree-clear! <> id release-qns))
            (call-synch-with *functions*
              (cute hash-table-tree-clear! <> id release-qns))
            (database-ptr-set! db #f)
            (database-busy-handler-set! db #f))])]
    [((? statement? stmt))
      (cond
        [(not (statement-ptr stmt))
          (void)]
        [(sqlite3_finalize (statement-ptr stmt))
          => (abort-sqlite3-error 'finalize! (statement-database stmt) stmt)]
        [else
          (statement-ptr-set! stmt #f)])]
    [(v . _)
      (error-argument-type 'finalize! v "database or statement")]))

;;; Statement interface

;; Create a new statement
(define (prepare db sql)
  (check-database 'prepare db)
  (check-string 'prepare sql)
  (let retry ([retries 0])
    (let-location ([stmt c-pointer] [tail c-string])
      (cond
        [((foreign-safe-lambda sqlite3:status "sqlite3_prepare_v2"
            sqlite3:database scheme-pointer int
            (c-pointer sqlite3:statement)
            (c-pointer (const c-string)))
          db (string-append sql "\x00") (string-length sql) #$stmt #$tail)
          => (lambda (err)
              (case err
                [(busy)
                  (let ([h (database-busy-handler db)])
                    (cond
                      [(and h (h db retries))
                        (retry (fx+ retries 1))]
                      [else
                        ((abort-sqlite3-error 'prepare db db sql) err)]))]
                [else
                  ((abort-sqlite3-error 'prepare db db sql) err)]))]
        [else
          (values (make-statement stmt db) tail)]))))

;; Retrieve the SQL source code of a statement
(define (source-sql stmt)
  (check-statement 'source-sql stmt)
  ((foreign-lambda c-string "sqlite3_sql" sqlite3:statement) stmt))

;; Reset an existing statement to process it again
(define (reset! stmt)
  (check-statement 'reset! stmt)
  (cond [((foreign-lambda sqlite3:status "sqlite3_reset" sqlite3:statement) stmt)
    => (abort-sqlite3-error 'reset! (statement-database stmt) stmt)]))

;; Get number of bindable parameters
(define (bind-parameter-count stmt)
  (check-statement 'bind-parameter-count stmt)
  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt))

;; Get index of a bindable parameter or #f if no parameter with the
;; given name exists
(define (bind-parameter-index stmt name)
  (check-statement 'bind-parameter-index stmt)
  (let ([i ((foreign-lambda int "sqlite3_bind_parameter_index"
              sqlite3:statement nonnull-c-string)
            stmt name)])
    (if (zero? i)
      #f
      (fx- i 1))))

;; Get the name of a bindable parameter
(define (bind-parameter-name stmt i)
  (check-statement 'bind-parameter-name stmt)
  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int)
    stmt (fx+ i 1)))

;; Bind data as parameters to an existing statement

(define (bind! stmt i v)
  (check-statement 'bind! stmt)
  (check-natural-integer 'bind! i)
  (cond
    [(blob? v)
      (cond [((foreign-lambda* sqlite3:status
                ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
                "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
              stmt (fx+ i 1) v (blob-size v))
        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(boolean? v)
      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int"
                sqlite3:statement int bool)
              stmt (fx+ i 1) v)
        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(exact-integer? v)
      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_int64"
                sqlite3:statement int integer64)
              stmt (fx+ i 1) v)
        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(real? v)
      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_double"
                sqlite3:statement int double)
              stmt (fx+ i 1) v)
        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(string? v)
      (cond [((foreign-lambda* sqlite3:status
                ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
                "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
              stmt (fx+ i 1) v (string-length v))
        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i v)])]
    [(sql-null? v)
      (cond [((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int)
              stmt (fx+ i 1))
        => (abort-sqlite3-error 'bind! (statement-database stmt) stmt i)])]
    [else
      (error-argument-type 'bind! v "blob, number, boolean, string or sql-null")]))

; Helper

(define (%bind-parameters! loc stmt params)
  (reset! stmt)
  (let ([cnt (bind-parameter-count stmt)]
  [vs (make-hash-table)])
    (let loop ([i 0] [params params])
      (match params
        [((? keyword? k) v . rest)
          (cond
            [(bind-parameter-index stmt (string-append ":" (keyword->string k)))
              => (lambda (j)
             (hash-table-set! vs j v)
             (loop i rest))]
            [else
              (error-argument-type loc k "value or keyword matching a bind parameter name")])]
        [(v . rest)
          (hash-table-set! vs i v)
          (loop (fx+ i 1) rest)]
        [()
          (void)]))
    (if (= (hash-table-size vs) cnt)
      (unless (zero? cnt)
        (hash-table-walk vs (cut bind! stmt <> <>)))
      (abort
        (make-composite-condition
          (make-exn-condition
            loc
            (conc "bad parameter count - received " (hash-table-size vs) " but expected " cnt))
          (make-property-condition 'arity)
          (make-sqlite3-condition 'error))))))

(define (bind-parameters! stmt . params)
  (%bind-parameters! 'bind-parameters! stmt params))

;; Single-step a prepared statement, return #t if data is available,
;; #f otherwise
(define (step! stmt)
  (check-statement 'step! stmt)
  (let ([db (statement-database stmt)])
    (let retry ([retries 0])
      (let ([s ((foreign-safe-lambda
                  sqlite3:status "sqlite3_step" sqlite3:statement) stmt)])
        (case s
          [(row)
            #t]
          [(done)
            #f]
          [(busy)
            (let ([h (database-busy-handler db)])
              (cond
                [(and h (h db retries))
                  (retry (fx+ retries 1))]
                [else
                  ((abort-sqlite3-error 'step! db stmt) s)]))]
          [else
            ((abort-sqlite3-error 'step! db stmt) s)])))))

;; Retrieve information from a prepared/stepped statement
(define (column-count stmt)
  (check-statement 'column-count stmt)
  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt))

(define (column-type stmt i)
  (check-statement 'column-type stmt)
  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i))

(define (column-declared-type stmt i)
  (check-statement 'column-declared-type stmt)
  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i))

(define (column-name stmt i)
  (check-statement 'column-name stmt)
  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i))

;; Retrieve data from a stepped statement
(define (column-data stmt i)
  (case (column-type stmt i)
    [(integer)
      (if (and-let* ([type (column-declared-type stmt i)])
            (string-contains-ci type "bool"))
        ((foreign-lambda bool "sqlite3_column_int" sqlite3:statement int) stmt i)
        ((foreign-lambda integer64 "sqlite3_column_int64" sqlite3:statement int) stmt i))]
    [(float)
      ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i)]
    [(text)
      ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
          "int n = sqlite3_column_bytes(stmt, i);"
          "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
          "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));")
        stmt i)]
    [(blob)
      ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
          "int n = sqlite3_column_bytes(stmt, i);"
          "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
          "return(C_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));")
        stmt i)]
    [else
      (sql-null)]))

;;; Easy statement interface

;; Compile a statement and call a procedure on it, then finalize the
;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
(define (call-with-temporary-statements proc db . sqls)
  (check-database 'call-with-temporary-statements db)
  (let ([stmts #f] [exn #f])
    (dynamic-wind
      (lambda ()
        (unless stmts
          (set! stmts (map (cute prepare db <>) sqls))))
      (lambda ()
        (handle-exceptions e (set! exn e)
          (apply proc stmts)))
      (lambda ()
        (and-let* ([s stmts])
          (set! stmts #f)
          (for-each finalize! s)) ;; leaks if error occurs before last stmt
        (and-let* ([e exn])
          (set! exn #f)
          (signal e))))))

(define-syntax %define/statement+params
  (syntax-rules ()
    [(%define/statement+params ((name loc) (init ...) (stmt params))
       body ...)
      (define name
        (let ([impl (lambda (init ... stmt params) body ...)])
          (lambda (init ... db-or-stmt . params)
            (cond
              [(database? db-or-stmt)
                (call-with-temporary-statements
                  (cute impl init ... <> (cdr params))
                  db-or-stmt (car params))]
              [(statement? db-or-stmt)
                (impl init ... db-or-stmt params)]
              [else
                (error-argument-type loc db-or-stmt "database or statement")]))))]
    [(%define/statement+params (name (init ...) (stmt params))
       body ...)
      (%define/statement+params ((name 'name) (init ...) (stmt params))
        body ...)]
    [(%define/statement+params (name stmt params)
       body ...)
      (%define/statement+params ((name 'name) () (stmt params))
        body ...)]))

;; Step through a statement and ignore possible results
(define (%execute loc stmt params)
  (%bind-parameters! loc stmt params)
  (while (step! stmt))
  (void))

(%define/statement+params (execute stmt params)
  (%execute 'execute stmt params))

;; Step through a statement, ignore possible results and return the
;; count of changes performed by this statement
(%define/statement+params (update stmt params)
  (%execute 'update stmt params)
  (change-count (statement-database stmt)))

;; Return only the first column of the first result row produced by this
;; statement

(%define/statement+params (first-result stmt params)
  (%bind-parameters! 'first-result stmt params)
  (if (step! stmt)
    (let ([r (column-data stmt 0)])
      (reset! stmt)
      r)
    (abort (make-no-data-condition 'first-result stmt params))))

;; Return only the first result row produced by this statement as a list

(%define/statement+params (first-row stmt params)
  (%bind-parameters! 'first-row stmt params)
  (if (step! stmt)
    (map (cute column-data stmt <>)
      (iota (column-count stmt)))
    (abort (make-no-data-condition 'first-row stmt params))))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulating results.

(%define/statement+params ((%fold-row loc) (loc proc init) (stmt params))
  (%bind-parameters! loc stmt params)
  (let ([cl (iota (column-count stmt))])
    (let loop ([acc init])
      (if (step! stmt)
  (loop (apply proc acc (map (cute column-data stmt <>) cl)))
  acc))))

(define (fold-row proc init db-or-stmt . params)
  (check-procedure 'fold-row proc)
  (apply %fold-row 'fold-row proc init db-or-stmt params))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and discard the results

(define (for-each-row proc db-or-stmt . params)
  (check-procedure 'for-each-row proc)
  (apply %fold-row
    'for-each-row
    (lambda (acc . columns)
      (apply proc columns))
    (void)
    db-or-stmt params))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulate the results in a list

(define (map-row proc db-or-stmt . params)
  (check-procedure 'map-row proc)
  (reverse!
    (apply %fold-row
      'map-row
      (lambda (acc . columns)
        (cons (apply proc columns) acc))
      '()
      db-or-stmt params)))

;;; Utility procedures

;; Run a thunk within a database transaction, commit if return value is
;; true, rollback if return value is false or the thunk is interrupted by
;; an exception
(define (with-transaction db thunk #!optional (type 'deferred))
  (check-database 'with-transaction db)
  (check-procedure 'with-transaction thunk)
  (unless (memq type '(deferred immediate exclusive))
    (abort
      (make-composite-condition
        (make-exn-condition 'with-transaction
          "bad argument: expected deferred, immediate or exclusive"
          type)
        (make-property-condition 'type))))
  (let ([success? #f] [exn #f])
    (dynamic-wind
      (lambda ()
        (execute db
          (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
      (lambda ()
        (handle-exceptions e (begin
                               (print-error "with-transaction" exn)
                               (set! exn e))
          (set! success? (thunk))
          success?))
      (lambda ()
        (execute db
          (if success?
            "COMMIT TRANSACTION;"
            "ROLLBACK TRANSACTION;"))
        (and-let* ([e exn])
          (set! exn #f)
          (signal e))))))

;; Check if the given string is a valid SQL statement
(define sql-complete?
  (foreign-lambda bool "sqlite3_complete" nonnull-c-string))

;; Return a descriptive version string
(define database-version
  (foreign-lambda c-string "sqlite3_libversion"))

;; Return the amount of memory currently allocated by the database
(define database-memory-used
  (foreign-lambda integer "sqlite3_memory_used"))

;; Return the maximum amount of memory allocated by the database since
;; the counter was last reset
(define (database-memory-highwater #!optional reset?)
  ((foreign-lambda integer "sqlite3_memory_highwater" bool) reset?))

;; Enables (disables) the sharing of the database cache and schema data
;; structures between connections to the same database.
(define (enable-shared-cache! enable?)
  (cond-expand
   [disable-shared-cache
    #f]
   [else
    (cond
     [((foreign-lambda sqlite3:status "sqlite3_enable_shared_cache" bool) enable?)
      => (abort-sqlite3-error 'enable-shared-cache! #f)]
     [else
      enable?])]))

;; Enables (disables) the loading of native extensions using SQL statements.
(define (enable-load-extension! db enable?)
  (cond-expand
   [disable-load-extension
    #f]
   [else
    (cond
     [((foreign-lambda sqlite3:status "sqlite3_enable_load_extension" sqlite3:database bool) db enable?)
      => (abort-sqlite3-error 'enable-load-extension! db)]
     [else
      enable?])]))

)

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;