Changeset 14570 in project


Ignore:
Timestamp:
05/08/09 22:01:34 (11 years ago)
Author:
Jim Ursetto
Message:

sql-de-lite: dedent module to column 0

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/sql-de-lite/trunk/sql-de-lite.scm

    r14569 r14570  
    1717
    1818(module sql-de-lite
    19     (
    20      error-code error-message
    21      open-database close-database
    22      prepare prepare-transient
    23      finalize resurrect
    24      step ; step-through
    25      fetch fetch-alist
    26      fetch-all first-column
    27      column-count column-name column-type column-data
    28      column-names                         ; convenience
    29      bind bind-parameters bind-parameter-count
    30      library-version                      ; string, not proc
    31      row-data row-alist
    32      reset ;reset-unconditionally         ; core binding!
    33      call-with-database
    34      change-count total-change-count last-insert-rowid
    35      with-transaction with-deferred-transaction
    36      with-immediate-transaction with-exclusive-transaction
    37      autocommit?
    38      rollback commit
    39 
    40      set-busy-handler! busy-timeout
    41 
    42      ;; advanced interface
    43      query query* exec exec* sql
    44 
    45      ;; parameters
    46      raise-database-errors
    47      prepared-cache-size
    48 
    49      ;; experimental interface
    50      for-each-row for-each-row*
    51      map-rows map-rows*
    52      fold-rows fold-rows*
    53      schema print-schema
    54      flush-cache!
    55 
    56      ;; exceptions
    57      sqlite-exception?
    58      sqlite-exception-status
    59      sqlite-exception-message
    60 
    61      finalized?
    62      )
    63 
    64   (import scheme
    65           (except chicken reset))
    66   (import (only extras fprintf sprintf))
    67   (require-library lolevel srfi-18)
    68   (import (only lolevel
    69                 object->pointer object-release object-evict pointer=?))
    70   (import (only data-structures alist-ref))
    71   (import (only srfi-18 thread-sleep! milliseconds->time))
    72   (import foreign foreigners easyffi)
    73   (require-extension lru-cache)
     19 (
     20  error-code error-message
     21  open-database close-database
     22  prepare prepare-transient
     23  finalize resurrect
     24  step ; step-through
     25  fetch fetch-alist
     26  fetch-all first-column
     27  column-count column-name column-type column-data
     28  column-names                         ; convenience
     29  bind bind-parameters bind-parameter-count
     30  library-version                      ; string, not proc
     31  row-data row-alist
     32  reset ;reset-unconditionally         ; core binding!
     33  call-with-database
     34  change-count total-change-count last-insert-rowid
     35  with-transaction with-deferred-transaction
     36  with-immediate-transaction with-exclusive-transaction
     37  autocommit?
     38  rollback commit
     39
     40  set-busy-handler! busy-timeout
     41
     42  ;; advanced interface
     43  query query* exec exec* sql
     44
     45  ;; parameters
     46  raise-database-errors
     47  prepared-cache-size
     48
     49  ;; experimental interface
     50  for-each-row for-each-row*
     51  map-rows map-rows*
     52  fold-rows fold-rows*
     53  schema print-schema
     54  flush-cache!
     55
     56  ;; exceptions
     57  sqlite-exception?
     58  sqlite-exception-status
     59  sqlite-exception-message
     60
     61  finalized?
     62  )
     63
     64(import scheme
     65        (except chicken reset))
     66(import (only extras fprintf sprintf))
     67(require-library lolevel srfi-18)
     68(import (only lolevel
     69              object->pointer object-release object-evict pointer=?))
     70(import (only data-structures alist-ref))
     71(import (only srfi-18 thread-sleep! milliseconds->time))
     72(import foreign foreigners easyffi)
     73(require-extension lru-cache)
    7474
    7575;;; Foreign interface
    7676
    77   #>? #include "sqlite3-api.h" <#
    78  
    79   (define-foreign-enum-type (sqlite3:type int)
    80     (type->int int->type)
    81     ((integer type/integer) SQLITE_INTEGER)
    82     ((float   type/float)   SQLITE_FLOAT)
    83     ((text    type/text)    SQLITE_TEXT)
    84     ((blob    type/blob)    SQLITE_BLOB)
    85     ((null    type/null)    SQLITE_NULL))
    86 
    87   (define-foreign-enum-type (sqlite3:status int)
    88     (status->int int->status)
    89     ((ok status/ok)               SQLITE_OK)
    90     ((error status/error)         SQLITE_ERROR)
    91     ((internal status/internal)   SQLITE_INTERNAL)
    92     ((permission
    93       status/permission)          SQLITE_PERM)
    94     ((abort status/abort)         SQLITE_ABORT)
    95     ((busy status/busy)           SQLITE_BUSY)
    96     ((locked status/locked)       SQLITE_LOCKED)
    97     ((no-memory status/no-memory) SQLITE_NOMEM)
    98     ((read-only status/read-only) SQLITE_READONLY)
    99     ((interrupt status/interrupt) SQLITE_INTERRUPT)
    100     ((io-error status/io-error)   SQLITE_IOERR)
    101     ((corrupt status/corrupt)     SQLITE_CORRUPT)
    102     ((not-found status/not-found) SQLITE_NOTFOUND)
    103     ((full status/full)           SQLITE_FULL)
    104     ((cant-open status/cant-open) SQLITE_CANTOPEN)
    105     ((protocol status/protocol)   SQLITE_PROTOCOL)
    106     ((empty status/empty)         SQLITE_EMPTY)
    107     ((schema status/schema)       SQLITE_SCHEMA)
    108     ((too-big status/too-big)     SQLITE_TOOBIG)
    109     ((constraint
    110       status/constraint)          SQLITE_CONSTRAINT)
    111     ((mismatch status/mismatch)   SQLITE_MISMATCH)
    112     ((misuse status/misuse)       SQLITE_MISUSE)
    113     ((no-lfs status/no-lfs)       SQLITE_NOLFS)
    114     ((authorization
    115       status/authorization)       SQLITE_AUTH)
    116     ((format status/format)       SQLITE_FORMAT)
    117     ((range status/range)         SQLITE_RANGE)
    118     ((not-a-database
    119       status/not-a-database)      SQLITE_NOTADB)
    120     ((row status/row)             SQLITE_ROW)
    121     ((done status/done)           SQLITE_DONE))
    122 
    123   (define-foreign-type sqlite3:destructor-type
    124     (function "void" (c-pointer "void")))
    125   (define-foreign-variable destructor-type/transient
    126     sqlite3:destructor-type "SQLITE_TRANSIENT")
    127   (define-foreign-variable destructor-type/static
    128     sqlite3:destructor-type "SQLITE_STATIC")
    129   (define library-version (foreign-value "sqlite3_version" c-string))
     77#>? #include "sqlite3-api.h" <#
     78
     79(define-foreign-enum-type (sqlite3:type int)
     80  (type->int int->type)
     81  ((integer type/integer) SQLITE_INTEGER)
     82  ((float   type/float)   SQLITE_FLOAT)
     83  ((text    type/text)    SQLITE_TEXT)
     84  ((blob    type/blob)    SQLITE_BLOB)
     85  ((null    type/null)    SQLITE_NULL))
     86
     87(define-foreign-enum-type (sqlite3:status int)
     88  (status->int int->status)
     89  ((ok status/ok)               SQLITE_OK)
     90  ((error status/error)         SQLITE_ERROR)
     91  ((internal status/internal)   SQLITE_INTERNAL)
     92  ((permission
     93    status/permission)          SQLITE_PERM)
     94  ((abort status/abort)         SQLITE_ABORT)
     95  ((busy status/busy)           SQLITE_BUSY)
     96  ((locked status/locked)       SQLITE_LOCKED)
     97  ((no-memory status/no-memory) SQLITE_NOMEM)
     98  ((read-only status/read-only) SQLITE_READONLY)
     99  ((interrupt status/interrupt) SQLITE_INTERRUPT)
     100  ((io-error status/io-error)   SQLITE_IOERR)
     101  ((corrupt status/corrupt)     SQLITE_CORRUPT)
     102  ((not-found status/not-found) SQLITE_NOTFOUND)
     103  ((full status/full)           SQLITE_FULL)
     104  ((cant-open status/cant-open) SQLITE_CANTOPEN)
     105  ((protocol status/protocol)   SQLITE_PROTOCOL)
     106  ((empty status/empty)         SQLITE_EMPTY)
     107  ((schema status/schema)       SQLITE_SCHEMA)
     108  ((too-big status/too-big)     SQLITE_TOOBIG)
     109  ((constraint
     110    status/constraint)          SQLITE_CONSTRAINT)
     111  ((mismatch status/mismatch)   SQLITE_MISMATCH)
     112  ((misuse status/misuse)       SQLITE_MISUSE)
     113  ((no-lfs status/no-lfs)       SQLITE_NOLFS)
     114  ((authorization
     115    status/authorization)       SQLITE_AUTH)
     116  ((format status/format)       SQLITE_FORMAT)
     117  ((range status/range)         SQLITE_RANGE)
     118  ((not-a-database
     119    status/not-a-database)      SQLITE_NOTADB)
     120  ((row status/row)             SQLITE_ROW)
     121  ((done status/done)           SQLITE_DONE))
     122
     123(define-foreign-type sqlite3:destructor-type
     124  (function "void" (c-pointer "void")))
     125(define-foreign-variable destructor-type/transient
     126  sqlite3:destructor-type "SQLITE_TRANSIENT")
     127(define-foreign-variable destructor-type/static
     128  sqlite3:destructor-type "SQLITE_STATIC")
     129(define library-version (foreign-value "sqlite3_version" c-string))
    130130
    131131;;; Parameters
    132  
    133   (define raise-database-errors (make-parameter #t))
    134   (define prepared-cache-size (make-parameter 100))
     132
     133(define raise-database-errors (make-parameter #t))
     134(define prepared-cache-size (make-parameter 100))
    135135
    136136;;; Syntax
    137137
    138   (define-syntax begin0                 ; multiple values discarded
    139     (syntax-rules () ((_ e0 e1 ...)
    140                       (let ((tmp e0)) e1 ... tmp))))
     138(define-syntax begin0                 ; multiple values discarded
     139  (syntax-rules () ((_ e0 e1 ...)
     140                    (let ((tmp e0)) e1 ... tmp))))
    141141
    142142;;; Records
    143143
    144   (define-record-type sqlite-database
    145     (make-db ptr filename busy-handler invoked-busy-handler? statement-cache)
    146     db?
    147     (ptr db-ptr set-db-ptr!)
    148     (filename db-filename)
    149     (busy-handler db-busy-handler set-db-busy-handler!)
    150     (invoked-busy-handler? db-invoked-busy-handler?)
    151     (statement-cache db-statement-cache))
    152   (define-record-printer (sqlite-database db port)
    153     (fprintf port "#<sqlite-database ~A on ~S>"
    154              (or (db-ptr db)
    155                  "(closed)")
    156              (db-filename db)))
    157  
    158   (define-inline (nonnull-db-ptr db)
    159     (or (db-ptr db)
    160         (error 'sqlite3-simple "operation on closed database")))
    161 
    162   ;; Thin wrapper around sqlite-statement-handle, adding the two keys
    163   ;; which allows us to reconstitute a finalized statement.
    164   (define-record-type sqlite-statement
    165     (make-statement db sql handle)
    166     statement?
    167     (db  statement-db)
    168     (sql statement-sql)
    169     (handle statement-handle set-statement-handle!))
    170   (define-record-printer (sqlite-statement s p)
    171     (fprintf p "#<sqlite-statement ~S>"
    172              (statement-sql s)))
    173 
    174   ;; Internal record making up the guts of a prepared statement;
    175   ;; always embedded in a sqlite-statement.
    176   (define-record-type sqlite-statement-handle
    177     (make-handle ptr column-count column-names
    178                  parameter-count cached? run-state)
    179     handle?
    180     (ptr handle-ptr set-handle-ptr!)
    181     (column-count handle-column-count)
    182     (column-names handle-column-names)
    183     (parameter-count handle-parameter-count)
    184     ;; cached? flag avoids a cache-ref to check existence.
    185     (cached? handle-cached? set-handle-cached!)
    186     (run-state handle-run-state set-handle-run-state!))
    187 
    188   ;; Convenience accessors for guts of statement.  Should be inlined.
    189   (define (statement-ptr s)
    190     (handle-ptr (statement-handle s)))
    191   (define (set-statement-ptr! s p)
    192     (set-handle-ptr! (statement-handle s) p))
    193   (define (statement-column-count s)
    194     (handle-column-count (statement-handle s)))
    195   (define (statement-column-names s)
    196     (handle-column-names (statement-handle s)))
    197   (define (statement-parameter-count s)
    198     (handle-parameter-count (statement-handle s)))
    199   (define (statement-cached? s)
    200     (handle-cached? (statement-handle s)))
    201   (define (set-statement-cached! s b)
    202     (set-handle-cached! (statement-handle s) b))
    203   (define (statement-run-state s)
    204     (handle-run-state (statement-handle s)))
    205   ;; use an int instead of symbol; this is internal, and avoids mutations
    206   (define (statement-reset? s)
    207     (= 0 (handle-run-state (statement-handle s))))
    208   (define (statement-running? s)
    209     (= 1 (handle-run-state (statement-handle s))))
    210   (define (statement-done? s)
    211     (= 2 (handle-run-state (statement-handle s))))
    212   (define (set-statement-reset! s)
    213     (set-handle-run-state! (statement-handle s) 0))
    214   (define (set-statement-running! s)
    215     (set-handle-run-state! (statement-handle s) 1))
    216   (define (set-statement-done! s)
    217     (set-handle-run-state! (statement-handle s) 2))
    218  
    219   (define-inline (nonnull-statement-ptr stmt)
    220     ;; All references to statement ptr implicitly check for valid db.
    221     (or (and (nonnull-db-ptr (statement-db stmt))
    222              (statement-handle stmt)
    223              (statement-ptr stmt))
    224         (error 'sqlite3-simple "operation on finalized statement")))
    225 
    226   (define (finalized? stmt)             ; inline
    227     (or (not (statement-handle stmt))
    228         (not (statement-ptr stmt))))
    229 
    230 ;;; High-level interface 
    231 
    232   (define (sql db sql-str)
    233     (make-statement db sql-str #f))     ; (finalized? s) => #t
    234  
    235   ;; Resurrects finalized statement s or, if still live, just resets it.
    236   ;; Returns s, which is also modified in place.
    237   (define (resurrect s)                ; inline
    238     (cond ((finalized? s)
    239            (let ((sn (prepare (statement-db s) (statement-sql s))))
    240              (set-statement-handle! s (statement-handle sn))
    241              s))
     144(define-record-type sqlite-database
     145  (make-db ptr filename busy-handler invoked-busy-handler? statement-cache)
     146  db?
     147  (ptr db-ptr set-db-ptr!)
     148  (filename db-filename)
     149  (busy-handler db-busy-handler set-db-busy-handler!)
     150  (invoked-busy-handler? db-invoked-busy-handler?)
     151  (statement-cache db-statement-cache))
     152(define-record-printer (sqlite-database db port)
     153  (fprintf port "#<sqlite-database ~A on ~S>"
     154           (or (db-ptr db)
     155               "(closed)")
     156           (db-filename db)))
     157
     158(define-inline (nonnull-db-ptr db)
     159  (or (db-ptr db)
     160      (error 'sqlite3-simple "operation on closed database")))
     161
     162;; Thin wrapper around sqlite-statement-handle, adding the two keys
     163;; which allows us to reconstitute a finalized statement.
     164(define-record-type sqlite-statement
     165  (make-statement db sql handle)
     166  statement?
     167  (db  statement-db)
     168  (sql statement-sql)
     169  (handle statement-handle set-statement-handle!))
     170(define-record-printer (sqlite-statement s p)
     171  (fprintf p "#<sqlite-statement ~S>"
     172           (statement-sql s)))
     173
     174;; Internal record making up the guts of a prepared statement;
     175;; always embedded in a sqlite-statement.
     176(define-record-type sqlite-statement-handle
     177  (make-handle ptr column-count column-names
     178               parameter-count cached? run-state)
     179  handle?
     180  (ptr handle-ptr set-handle-ptr!)
     181  (column-count handle-column-count)
     182  (column-names handle-column-names)
     183  (parameter-count handle-parameter-count)
     184  ;; cached? flag avoids a cache-ref to check existence.
     185  (cached? handle-cached? set-handle-cached!)
     186  (run-state handle-run-state set-handle-run-state!))
     187
     188;; Convenience accessors for guts of statement.  Should be inlined.
     189(define (statement-ptr s)
     190  (handle-ptr (statement-handle s)))
     191(define (set-statement-ptr! s p)
     192  (set-handle-ptr! (statement-handle s) p))
     193(define (statement-column-count s)
     194  (handle-column-count (statement-handle s)))
     195(define (statement-column-names s)
     196  (handle-column-names (statement-handle s)))
     197(define (statement-parameter-count s)
     198  (handle-parameter-count (statement-handle s)))
     199(define (statement-cached? s)
     200  (handle-cached? (statement-handle s)))
     201(define (set-statement-cached! s b)
     202  (set-handle-cached! (statement-handle s) b))
     203(define (statement-run-state s)
     204  (handle-run-state (statement-handle s)))
     205;; use an int instead of symbol; this is internal, and avoids mutations
     206(define (statement-reset? s)
     207  (= 0 (handle-run-state (statement-handle s))))
     208(define (statement-running? s)
     209  (= 1 (handle-run-state (statement-handle s))))
     210(define (statement-done? s)
     211  (= 2 (handle-run-state (statement-handle s))))
     212(define (set-statement-reset! s)
     213  (set-handle-run-state! (statement-handle s) 0))
     214(define (set-statement-running! s)
     215  (set-handle-run-state! (statement-handle s) 1))
     216(define (set-statement-done! s)
     217  (set-handle-run-state! (statement-handle s) 2))
     218
     219(define-inline (nonnull-statement-ptr stmt)
     220  ;; All references to statement ptr implicitly check for valid db.
     221  (or (and (nonnull-db-ptr (statement-db stmt))
     222           (statement-handle stmt)
     223           (statement-ptr stmt))
     224      (error 'sqlite3-simple "operation on finalized statement")))
     225
     226(define (finalized? stmt)             ; inline
     227  (or (not (statement-handle stmt))
     228      (not (statement-ptr stmt))))
     229
     230;;; High-level interface
     231
     232(define (sql db sql-str)
     233  (make-statement db sql-str #f))     ; (finalized? s) => #t
     234
     235;; Resurrects finalized statement s or, if still live, just resets it.
     236;; Returns s, which is also modified in place.
     237(define (resurrect s)                ; inline
     238  (cond ((finalized? s)
     239         (let ((sn (prepare (statement-db s) (statement-sql s))))
     240           (set-statement-handle! s (statement-handle sn))
     241           s))
     242        (else
     243         (reset s))))
     244
     245;; Resurrects s, binds args to s and performs a query*.  This is the
     246;; usual way to perform a query unless you need to bind arguments
     247;; manually or need other manual control.
     248(define (query proc s . args)
     249  (resurrect s)
     250  (and (apply bind-parameters s args)
     251       (query* proc s)))
     252;; Calls (proc s) and resets the statement immediately afterward, to
     253;; avoid locking the database.  If an exception occurs during proc,
     254;; the statement will still be reset.  Statement is NOT reset before
     255;; execution.  Note that, as closing the database will also reset any
     256;; pending statements, you can dispense with the unwind-protect as long
     257;; as you don't attempt to continue.
     258(define (query* proc s)
     259  ;; (when (or (not (statement? s)) ; Optional check before entering
     260  ;;           (finalized? s))      ; exception handler.
     261  ;;   (error 'query* "operation on finalized statement"))
     262  (begin0
     263      (let ((c (current-exception-handler)))
     264        (with-exception-handler
     265         (lambda (ex)    ; careful not to throw another exception in here--
     266                                        ; handle-exceptions would be safer, but slower
     267           (and-let* ((statement? s)
     268                      (h (statement-handle s)) ; is this too paranoid?
     269                      (handle-ptr h))
     270             (reset-unconditionally s))
     271           (c ex))
     272         (lambda () (proc s))))
     273    (reset s)))
     274
     275;; Resurrects s, binds args to s and performs an exec*.
     276(define (exec s . args)
     277  (resurrect s)
     278  (and (apply bind-parameters s args)
     279       (exec* s)))
     280;; Executes statement s, returning the number of changes (if the
     281;; result set has no columns as in INSERT, DELETE) or the first row
     282;; (if column data is returned as in SELECT).  Resurrection is
     283;; omitted, as it would wipe out any bindings.  Reset is NOT done
     284;; beforehand; it is cheap, but the user must reset before a bind
     285;; anyway.  Reset afterward is not done via unwind-protect; it will
     286;; be done here if a row was returned, and in step() if a database
     287;; error or busy occurs, but a Scheme error (such as retrieving
     288;; column data > 16MB) will not cause a reset.  This is a flaw,
     289;; but substantially faster.
     290(define (exec* s)
     291  (and-let* ((v (fetch s)))
     292    (when (pair? v) (reset s))
     293    (if (> (column-count s) 0)
     294        v
     295        (change-count (statement-db s)))))
     296
     297;; Statement traversal.  These return a lambda suitable for use
     298;; in the proc slot of query.  They call fetch repeatedly
     299;; to grab entire rows, passing them to proc.
     300(define (for-each-row proc)
     301  (lambda (s)
     302    (let loop ()
     303      (let ((x (fetch s)))
     304        (cond ((null? x) #t)
     305              (else
     306               (proc x)
     307               (loop)))))))
     308(define (map-rows proc)
     309  (lambda (s)
     310    (let loop ((L '()))
     311      (let ((x (fetch s)))
     312        (cond ((null? x) (reverse L))
     313              (else
     314               (loop (cons (proc x) L))))))))
     315(define (fold-rows kons knil)
     316  (lambda (s)
     317    (let loop ((xs knil))
     318      (let ((x (fetch s)))
     319        (cond ((null? x) xs)
     320              (else
     321               (loop (kons x xs))))))))
     322;; In the starred versions, proc gets one arg for each column.
     323;; Users can use match-lambda to achieve the same effect.
     324(define (for-each-row* proc)
     325  (for-each-row (lambda (r) (apply proc r))))
     326(define (map-rows* proc)
     327  (map-rows (lambda (r) (apply proc r))))
     328(define (fold-rows* proc)
     329  (fold-rows (lambda (r) (apply proc r))))
     330
     331;; These produce equivalent results: 
     332;; (query (map-rows car) (sql db "select name, sql from sqlite_master;"))
     333;; (map car (query fetch-all (sql db "select name, sql from sqlite_master;")))
     334
     335;; These produce equivalent results:
     336;;
     337;; (query (for-each-row* (lambda (name sql)
     338;;                         (print "table: " name " sql: " sql ";")))
     339;;        (sql db "select name, sql from sqlite_master;"))
     340;; (query (for-each-row (match-lambda ((name sql)
     341;;                         (print "table: " name " sql: " sql ";"))))
     342;;        (sql db "select name, sql from sqlite_master;")) 
     343
     344;;; Experimental
     345(define (print-schema db)
     346  (for-each (lambda (x) (print x ";")) (schema db)))
     347(define (schema db)
     348  (query (map-rows car)
     349         (sql db "select sql from sqlite_master where sql not NULL;")))
     350(define (first-column row)
     351  (and (pair? row) (car row)))
     352(define (flush-cache! db)
     353  (lru-cache-flush! (db-statement-cache db)))
     354
     355;;; Lowlevel interface
     356
     357;; Internal.  Returns a statement-handle suitable for embedding in
     358;; a statement record.
     359;; (Note: May return #f even on SQLITE_OK, which means the statement
     360;; contained only whitespace and comments and nothing was compiled.)
     361(define (prepare-handle db sql)
     362  (let-location ((stmt (c-pointer "sqlite3_stmt")))
     363    (let retry ((times 0))
     364      (reset-busy! db)
     365      (let ((rv (sqlite3_prepare_v2 (nonnull-db-ptr db)
     366                                    sql
     367                                    (string-length sql)
     368                                    (location stmt)
     369                                    #f)))
     370        (cond ((= rv status/ok)
     371               (if stmt
     372                   (let* ((ncol (sqlite3_column_count stmt))
     373                          (nparam (sqlite3_bind_parameter_count stmt))
     374                          (names (make-vector ncol #f)))
     375                     (make-handle stmt ncol names nparam
     376                                  #f 0)) ; cached? run-state
     377                   #f))     ; not an error, even when raising errors
     378              ((= rv status/busy)
     379               (let ((bh (db-busy-handler db)))
     380                 (if (and bh
     381                          (retry-busy? db)
     382                          (bh db times))
     383                     (retry (+ times 1))
     384                     (database-error db rv 'prepare sql))))
     385              (else
     386               (database-error db rv 'prepare sql)))))))
     387
     388;; Looks up a prepared statement in the statement cache.  If not
     389;; found, it prepares a statement and caches it.  An exception is
     390;; thrown if a statement we pulled from cache is currently running
     391;; (we could just warn and reset, if this causes problems).
     392;; Statements are also marked as cached, so FINALIZE is a no-op.
     393(define (prepare db sql)
     394  (let ((c (db-statement-cache db)))
     395    (cond ((lru-cache-ref c sql)
     396           => (lambda (s)
     397                (cond ((statement-running? s)
     398                       (error 'prepare
     399                              "cached statement is currently executing" s))
     400                      ((statement-done? s)
     401                       (reset s))
     402                      (else s))))
     403          ((prepare-handle db sql)
     404           => (lambda (h)
     405                (let ((s (make-statement db sql h)))
     406                  (when (> (lru-cache-capacity c) 0)
     407                    (set-handle-cached! h #t)
     408                    (lru-cache-set! c sql s))
     409                  s)))
     410          (else #f))))
     411
     412;; Bypass cache when preparing statement.  Might occasionally be
     413;; useful, but this call may also be removed.
     414(define (prepare-transient db sql)
     415  (make-statement db sql (prepare-handle db sql)))
     416
     417;; Returns #f on error, 'row on SQLITE_ROW, 'done on SQLITE_DONE.
     418;; On error or busy, statement is reset.   Oddly, one of the benefits of
     419;; resetting on error is a more descriptive error message; although
     420;; step() returns result codes directly with prepare_v2(), it still
     421;; takes a reset to convert "constraint failed" into "column key is
     422;; not unique".
     423;; We do unconditionally reset on BUSY, after any
     424;; retries).  If we don't, we see weird behavior.  For example,
     425;; first obtain a read lock with a SELECT step, then step an
     426;; INSERT to get a BUSY; if the INSERT is not then reset, stepping
     427;; a different INSERT may "succeed", but not write
     428;; any data.  I assume that is an undetected MISUSE condition.
     429;; NB It should not be necessary to reset between calls to busy handler.
     430(define (step stmt)
     431  (let ((db (statement-db stmt)))
     432    (let retry ((times 0))
     433      (reset-busy! db)
     434      (let ((rv (sqlite3_step (nonnull-statement-ptr stmt))))
     435        (cond ((= rv status/row)
     436               (set-statement-running! stmt)
     437               'row)
     438              ((= rv status/done)
     439               (set-statement-done! stmt)
     440               'done)
     441              ;; sqlite3_step handles SCHEMA error itself.
     442              ((= rv status/busy)
     443               ;; "SQLITE_BUSY can only occur before fetching the first row." --drh
     444               ;; Therefore, it is safe to reset on busy.
     445               (set-statement-running! stmt)
     446               (let ((bh (db-busy-handler db)))
     447                 (if (and bh
     448                          (retry-busy? db)
     449                          (bh db times))
     450                     (retry (+ times 1))
     451                     (begin
     452                       (reset-unconditionally stmt)
     453                       (database-error db rv 'step stmt)))))
     454              (else
     455               (reset-unconditionally stmt)
     456               (database-error db rv 'step stmt)))))))
     457
     458;; Finalize a statement.  Finalizing a finalized statement or a
     459;; cached statement is a no-op.  Finalizing a statement on a closed
     460;; DB is also a no-op; it is explicitly checked for here [*],
     461;; although normally the cache prevents this issue.  All statements
     462;; are automatically finalized when the database is closed, and cached
     463;; statements are finalized as they expire, so it is rarely necessary
     464;; to call this.
     465(define (finalize stmt)
     466  (or (statement-cached? stmt)
     467      (finalize-transient stmt)))
     468;; Finalize a statement now, regardless of its cached status.  The
     469;; statement is not removed from the cache.  Finalization is indicated
     470;; by #f in the statement-handle pointer slot.
     471(define (finalize-transient stmt)     ; internal
     472  (or (not (statement-ptr stmt))
     473      (not (db-ptr (statement-db stmt))) ; [*]
     474      (let ((rv (sqlite3_finalize
     475                 (nonnull-statement-ptr stmt)))) ; checks db here
     476        (set-statement-ptr! stmt #f)
     477        (cond ((= rv status/abort)
     478               (database-error
     479                (statement-db stmt) rv 'finalize))
     480              (else #t)))))
     481
     482;; Resets statement STMT.  Returns: STMT.
     483;; sqlite3_reset only returns an error if the statement experienced
     484;; an error, for compatibility with sqlite3_prepare.  We get the
     485;; error from sqlite3_step, so ignore any error here.
     486(define (reset stmt)
     487  (when (not (statement-reset? stmt))
     488    (reset-unconditionally stmt))
     489  stmt)
     490(define (reset-unconditionally stmt)
     491  (sqlite3_reset (nonnull-statement-ptr stmt))
     492  (set-statement-reset! stmt)
     493  stmt)
     494
     495(define (bind-parameters stmt . params)
     496  (let ((count (bind-parameter-count stmt)))
     497    ;; SQLITE_RANGE returned on range error; should we check against
     498    ;; our own bind-parameter-count first, and if so, should it be
     499    ;; a database error?  This is similar to calling Scheme proc
     500    ;; with wrong arity, so perhaps it should error out.
     501    (unless (= (length params) count)
     502      (error 'bind-parameters "wrong number of parameters, expected" count))
     503    (let loop ((i 1) (p params))
     504      (cond ((null? p) stmt)
     505            ((bind stmt i (car p))
     506             (loop (+ i 1) (cdr p)))
     507            (else #f)))))
     508
     509;; Bind parameter at index I of statement S to value X.  The variable
     510;; I may be an integer (the first parameter is 1, not 0) or a string
     511;; for a named parameter -- for example, "$key", ":key" or "@key".
     512;; A reference to an invalid index will throw an exception.
     513(define (bind s i x)
     514  (if (string? i)
     515      (%bind-named s i x)
     516      (%bind-int s i x)))
     517
     518(define (%bind-named s n x)
     519  (##sys#check-string n 'bind-named)
     520  (let ((i (sqlite3_bind_parameter_index (nonnull-statement-ptr s) n)))
     521    (if (= i 0)
     522        (error 'bind-named "no such parameter name" n s)
     523        (%bind-int s i x))))
     524
     525(define (%bind-int stmt i x)
     526  (when (or (< i 1)
     527            (> i (bind-parameter-count stmt)))
     528    ;; Should we test for this (and treat as error)?
     529    ;; SQLite will catch this and return a range error.
     530    ;; An indexing error should arguably be an immediate error...
     531    (error 'bind "index out of range" i))
     532  (let ((ptr (nonnull-statement-ptr stmt)))
     533    (let ((rv
     534           (cond ((string? x)
     535                  (sqlite3_bind_text ptr i x (string-length x)
     536                                     destructor-type/transient))
     537                 ((number? x)
     538                  (if (exact? x)
     539                      (sqlite3_bind_int ptr i x)
     540                      (sqlite3_bind_double ptr i x)))
     541                 ((blob? x)
     542                  (sqlite3_bind_blob ptr i x (blob-size x)
     543                                     destructor-type/transient))
     544                 ((null? x)
     545                  (sqlite3_bind_null ptr i))
     546                 (else
     547                  (error 'bind "invalid argument type" x)))))
     548      (cond ((= rv status/ok) stmt)
     549            (else (database-error (statement-db stmt) rv 'bind))))))
     550
     551(define bind-parameter-count statement-parameter-count)
     552
     553(define (change-count db)
     554  (sqlite3_changes (nonnull-db-ptr db)))
     555(define (total-change-count db)
     556  (sqlite3_total_changes (nonnull-db-ptr db)))
     557(define (last-insert-rowid db)
     558  (sqlite3_last_insert_rowid (nonnull-db-ptr db)))
     559(define column-count statement-column-count)
     560(define (column-names stmt)
     561  (let loop ((i 0) (L '()))
     562    (let ((c (column-count stmt)))
     563      (if (>= i c)
     564          (reverse L)
     565          (loop (+ i 1) (cons (column-name stmt i) L))))))
     566(define (column-name stmt i)    ;; Get result set column names, lazily.
     567  (let ((v (statement-column-names stmt)))
     568    (or (vector-ref v i)
     569        (let ((name (string->symbol
     570                     (sqlite3_column_name (nonnull-statement-ptr stmt)
     571                                          i))))
     572          (vector-set! v i name)
     573          name))))
     574(define (column-type stmt i)
     575  ;; can't be cached, only valid for current row
     576  (int->type (sqlite3_column_type (nonnull-statement-ptr stmt) i)))
     577(define (column-data stmt i)
     578  (let* ((stmt-ptr (nonnull-statement-ptr stmt))
     579         (t (sqlite3_column_type stmt-ptr i)))  ; faster than column-type
     580    ;; INTEGER type may reach 64 bits; return at least 53 significant.     
     581    (cond ((= t type/integer) (sqlite3_column_int64 stmt-ptr i))
     582          ((= t type/float)   (sqlite3_column_double stmt-ptr i))
     583          ((= t type/text)    (sqlite3_column_text stmt-ptr i)) ; NULs OK??
     584          ((= t type/null)    '())
     585          ((= t type/blob)
     586           (let ((b (make-blob (sqlite3_column_bytes stmt-ptr i)))
     587                 (%copy! (foreign-lambda c-pointer "C_memcpy"
     588                                         scheme-pointer c-pointer int)))
     589             (%copy! b (sqlite3_column_blob stmt-ptr i) (blob-size b))
     590             b))
    242591          (else
    243            (reset s))))
    244 
    245   ;; Resurrects s, binds args to s and performs a query*.  This is the
    246   ;; usual way to perform a query unless you need to bind arguments
    247   ;; manually or need other manual control.
    248   (define (query proc s . args)
    249     (resurrect s)
    250     (and (apply bind-parameters s args)
    251          (query* proc s)))
    252   ;; Calls (proc s) and resets the statement immediately afterward, to
    253   ;; avoid locking the database.  If an exception occurs during proc,
    254   ;; the statement will still be reset.  Statement is NOT reset before
    255   ;; execution.  Note that, as closing the database will also reset any
    256   ;; pending statements, you can dispense with the unwind-protect as long
    257   ;; as you don't attempt to continue.
    258   (define (query* proc s)
    259     ;; (when (or (not (statement? s)) ; Optional check before entering
    260     ;;           (finalized? s))      ; exception handler.
    261     ;;   (error 'query* "operation on finalized statement"))
    262     (begin0
    263         (let ((c (current-exception-handler)))
    264           (with-exception-handler
    265            (lambda (ex)    ; careful not to throw another exception in here--
    266                       ; handle-exceptions would be safer, but slower
    267              (and-let* ((statement? s)
    268                         (h (statement-handle s)) ; is this too paranoid?
    269                         (handle-ptr h))
    270                (reset-unconditionally s))
    271              (c ex))
    272            (lambda () (proc s))))
    273         (reset s)))
    274 
    275   ;; Resurrects s, binds args to s and performs an exec*.
    276   (define (exec s . args)
    277     (resurrect s)
    278     (and (apply bind-parameters s args)
    279          (exec* s)))
    280   ;; Executes statement s, returning the number of changes (if the
    281   ;; result set has no columns as in INSERT, DELETE) or the first row
    282   ;; (if column data is returned as in SELECT).  Resurrection is
    283   ;; omitted, as it would wipe out any bindings.  Reset is NOT done
    284   ;; beforehand; it is cheap, but the user must reset before a bind
    285   ;; anyway.  Reset afterward is not done via unwind-protect; it will
    286   ;; be done here if a row was returned, and in step() if a database
    287   ;; error or busy occurs, but a Scheme error (such as retrieving
    288   ;; column data > 16MB) will not cause a reset.  This is a flaw,
    289   ;; but substantially faster.
    290   (define (exec* s)
    291     (and-let* ((v (fetch s)))
    292       (when (pair? v) (reset s))
    293       (if (> (column-count s) 0)
    294           v
    295           (change-count (statement-db s)))))
    296  
    297   ;; Statement traversal.  These return a lambda suitable for use
    298   ;; in the proc slot of query.  They call fetch repeatedly
    299   ;; to grab entire rows, passing them to proc.
    300   (define (for-each-row proc)
    301     (lambda (s)
    302       (let loop ()
    303         (let ((x (fetch s)))
    304           (cond ((null? x) #t)
    305                 (else
    306                  (proc x)
    307                  (loop)))))))
    308   (define (map-rows proc)
    309     (lambda (s)
    310       (let loop ((L '()))
    311         (let ((x (fetch s)))
    312           (cond ((null? x) (reverse L))
    313                 (else
    314                  (loop (cons (proc x) L))))))))
    315   (define (fold-rows kons knil)
    316     (lambda (s)
    317       (let loop ((xs knil))
    318         (let ((x (fetch s)))
    319           (cond ((null? x) xs)
    320                 (else
    321                  (loop (kons x xs))))))))
    322   ;; In the starred versions, proc gets one arg for each column.
    323   ;; Users can use match-lambda to achieve the same effect.
    324   (define (for-each-row* proc)
    325     (for-each-row (lambda (r) (apply proc r))))
    326   (define (map-rows* proc)
    327     (map-rows (lambda (r) (apply proc r))))
    328   (define (fold-rows* proc)
    329     (fold-rows (lambda (r) (apply proc r))))
    330 
    331   ;; These produce equivalent results: 
    332   ;; (query (map-rows car) (sql db "select name, sql from sqlite_master;"))
    333   ;; (map car (query fetch-all (sql db "select name, sql from sqlite_master;")))
    334 
    335   ;; These produce equivalent results:
    336   ;;
    337   ;; (query (for-each-row* (lambda (name sql)
    338   ;;                         (print "table: " name " sql: " sql ";")))
    339   ;;        (sql db "select name, sql from sqlite_master;"))
    340   ;; (query (for-each-row (match-lambda ((name sql)
    341   ;;                         (print "table: " name " sql: " sql ";"))))
    342   ;;        (sql db "select name, sql from sqlite_master;")) 
    343 
    344 ;;; Experimental
    345   (define (print-schema db)
    346     (for-each (lambda (x) (print x ";")) (schema db)))
    347   (define (schema db)
    348     (query (map-rows car)
    349            (sql db "select sql from sqlite_master where sql not NULL;")))
    350   (define (first-column row)
    351     (and (pair? row) (car row)))
    352   (define (flush-cache! db)
    353     (lru-cache-flush! (db-statement-cache db)))
    354 
    355 ;;; Lowlevel interface
    356 
    357   ;; Internal.  Returns a statement-handle suitable for embedding in
    358   ;; a statement record.
    359   ;; (Note: May return #f even on SQLITE_OK, which means the statement
    360   ;; contained only whitespace and comments and nothing was compiled.)
    361   (define (prepare-handle db sql)
    362     (let-location ((stmt (c-pointer "sqlite3_stmt")))
    363       (let retry ((times 0))
    364         (reset-busy! db)
    365         (let ((rv (sqlite3_prepare_v2 (nonnull-db-ptr db)
    366                                       sql
    367                                       (string-length sql)
    368                                       (location stmt)
    369                                       #f)))
    370           (cond ((= rv status/ok)
    371                  (if stmt
    372                      (let* ((ncol (sqlite3_column_count stmt))
    373                             (nparam (sqlite3_bind_parameter_count stmt))
    374                             (names (make-vector ncol #f)))
    375                        (make-handle stmt ncol names nparam
    376                                     #f 0)) ; cached? run-state
    377                      #f))     ; not an error, even when raising errors
    378                 ((= rv status/busy)
    379                  (let ((bh (db-busy-handler db)))
    380                    (if (and bh
    381                             (retry-busy? db)
    382                             (bh db times))
    383                        (retry (+ times 1))
    384                        (database-error db rv 'prepare sql))))
    385                 (else
    386                  (database-error db rv 'prepare sql)))))))
    387 
    388   ;; Looks up a prepared statement in the statement cache.  If not
    389   ;; found, it prepares a statement and caches it.  An exception is
    390   ;; thrown if a statement we pulled from cache is currently running
    391   ;; (we could just warn and reset, if this causes problems).
    392   ;; Statements are also marked as cached, so FINALIZE is a no-op.
    393   (define (prepare db sql)
    394     (let ((c (db-statement-cache db)))
    395       (cond ((lru-cache-ref c sql)
    396              => (lambda (s)
    397                   (cond ((statement-running? s)
    398                          (error 'prepare
    399                                 "cached statement is currently executing" s))
    400                         ((statement-done? s)
    401                          (reset s))
    402                         (else s))))
    403             ((prepare-handle db sql)
    404              => (lambda (h)
    405                   (let ((s (make-statement db sql h)))
    406                     (when (> (lru-cache-capacity c) 0)
    407                       (set-handle-cached! h #t)
    408                       (lru-cache-set! c sql s))
    409                     s)))
    410             (else #f))))
    411  
    412   ;; Bypass cache when preparing statement.  Might occasionally be
    413   ;; useful, but this call may also be removed.
    414   (define (prepare-transient db sql)
    415     (make-statement db sql (prepare-handle db sql)))
    416 
    417   ;; Returns #f on error, 'row on SQLITE_ROW, 'done on SQLITE_DONE.
    418   ;; On error or busy, statement is reset.   Oddly, one of the benefits of
    419   ;; resetting on error is a more descriptive error message; although
    420   ;; step() returns result codes directly with prepare_v2(), it still
    421   ;; takes a reset to convert "constraint failed" into "column key is
    422   ;; not unique".
    423   ;; We do unconditionally reset on BUSY, after any
    424   ;; retries).  If we don't, we see weird behavior.  For example,
    425   ;; first obtain a read lock with a SELECT step, then step an
    426   ;; INSERT to get a BUSY; if the INSERT is not then reset, stepping
    427   ;; a different INSERT may "succeed", but not write
    428   ;; any data.  I assume that is an undetected MISUSE condition.
    429   ;; NB It should not be necessary to reset between calls to busy handler.
    430   (define (step stmt)
    431     (let ((db (statement-db stmt)))
    432       (let retry ((times 0))
    433         (reset-busy! db)
    434         (let ((rv (sqlite3_step (nonnull-statement-ptr stmt))))
    435           (cond ((= rv status/row)
    436                  (set-statement-running! stmt)
    437                  'row)
    438                 ((= rv status/done)
    439                  (set-statement-done! stmt)
    440                  'done)
    441                 ;; sqlite3_step handles SCHEMA error itself.
    442                 ((= rv status/busy)
    443                  ;; "SQLITE_BUSY can only occur before fetching the first row." --drh
    444                  ;; Therefore, it is safe to reset on busy.
    445                  (set-statement-running! stmt)
    446                  (let ((bh (db-busy-handler db)))
    447                    (if (and bh
    448                             (retry-busy? db)
    449                             (bh db times))
    450                        (retry (+ times 1))
    451                        (begin
    452                          (reset-unconditionally stmt)
    453                          (database-error db rv 'step stmt)))))
    454                 (else
    455                  (reset-unconditionally stmt)
    456                  (database-error db rv 'step stmt)))))))
    457 
    458   ;; Finalize a statement.  Finalizing a finalized statement or a
    459   ;; cached statement is a no-op.  Finalizing a statement on a closed
    460   ;; DB is also a no-op; it is explicitly checked for here [*],
    461   ;; although normally the cache prevents this issue.  All statements
    462   ;; are automatically finalized when the database is closed, and cached
    463   ;; statements are finalized as they expire, so it is rarely necessary
    464   ;; to call this.
    465   (define (finalize stmt)
    466     (or (statement-cached? stmt)
    467         (finalize-transient stmt)))
    468   ;; Finalize a statement now, regardless of its cached status.  The
    469   ;; statement is not removed from the cache.  Finalization is indicated
    470   ;; by #f in the statement-handle pointer slot.
    471   (define (finalize-transient stmt)     ; internal
    472     (or (not (statement-ptr stmt))
    473         (not (db-ptr (statement-db stmt))) ; [*]
    474         (let ((rv (sqlite3_finalize
    475                    (nonnull-statement-ptr stmt)))) ; checks db here
    476           (set-statement-ptr! stmt #f)
    477           (cond ((= rv status/abort)
    478                  (database-error
    479                   (statement-db stmt) rv 'finalize))
    480                 (else #t)))))
    481 
    482   ;; Resets statement STMT.  Returns: STMT.
    483   ;; sqlite3_reset only returns an error if the statement experienced
    484   ;; an error, for compatibility with sqlite3_prepare.  We get the
    485   ;; error from sqlite3_step, so ignore any error here.
    486   (define (reset stmt)
    487     (when (not (statement-reset? stmt))
    488       (reset-unconditionally stmt))
    489     stmt)
    490   (define (reset-unconditionally stmt)
    491     (sqlite3_reset (nonnull-statement-ptr stmt))
    492     (set-statement-reset! stmt)
    493     stmt)
    494 
    495   (define (bind-parameters stmt . params)
    496     (let ((count (bind-parameter-count stmt)))
    497       ;; SQLITE_RANGE returned on range error; should we check against
    498       ;; our own bind-parameter-count first, and if so, should it be
    499       ;; a database error?  This is similar to calling Scheme proc
    500       ;; with wrong arity, so perhaps it should error out.
    501       (unless (= (length params) count)
    502         (error 'bind-parameters "wrong number of parameters, expected" count))
    503       (let loop ((i 1) (p params))
    504         (cond ((null? p) stmt)
    505               ((bind stmt i (car p))
    506                (loop (+ i 1) (cdr p)))
    507               (else #f)))))
    508 
    509   ;; Bind parameter at index I of statement S to value X.  The variable
    510   ;; I may be an integer (the first parameter is 1, not 0) or a string
    511   ;; for a named parameter -- for example, "$key", ":key" or "@key".
    512   ;; A reference to an invalid index will throw an exception.
    513   (define (bind s i x)
    514     (if (string? i)
    515         (%bind-named s i x)
    516         (%bind-int s i x)))
    517 
    518   (define (%bind-named s n x)
    519     (##sys#check-string n 'bind-named)
    520     (let ((i (sqlite3_bind_parameter_index (nonnull-statement-ptr s) n)))
    521       (if (= i 0)
    522           (error 'bind-named "no such parameter name" n s)
    523           (%bind-int s i x))))
    524 
    525   (define (%bind-int stmt i x)
    526     (when (or (< i 1)
    527               (> i (bind-parameter-count stmt)))
    528       ;; Should we test for this (and treat as error)?
    529       ;; SQLite will catch this and return a range error.
    530       ;; An indexing error should arguably be an immediate error...
    531       (error 'bind "index out of range" i))
    532     (let ((ptr (nonnull-statement-ptr stmt)))
    533       (let ((rv
    534              (cond ((string? x)
    535                     (sqlite3_bind_text ptr i x (string-length x)
    536                                        destructor-type/transient))
    537                    ((number? x)
    538                     (if (exact? x)
    539                         (sqlite3_bind_int ptr i x)
    540                         (sqlite3_bind_double ptr i x)))
    541                    ((blob? x)
    542                     (sqlite3_bind_blob ptr i x (blob-size x)
    543                                        destructor-type/transient))
    544                    ((null? x)
    545                     (sqlite3_bind_null ptr i))
    546                    (else
    547                     (error 'bind "invalid argument type" x)))))
    548         (cond ((= rv status/ok) stmt)
    549               (else (database-error (statement-db stmt) rv 'bind))))))
    550  
    551   (define bind-parameter-count statement-parameter-count)
    552 
    553   (define (change-count db)
    554     (sqlite3_changes (nonnull-db-ptr db)))
    555   (define (total-change-count db)
    556     (sqlite3_total_changes (nonnull-db-ptr db)))
    557   (define (last-insert-rowid db)
    558     (sqlite3_last_insert_rowid (nonnull-db-ptr db)))
    559   (define column-count statement-column-count)
    560   (define (column-names stmt)
    561     (let loop ((i 0) (L '()))
    562       (let ((c (column-count stmt)))
    563         (if (>= i c)
    564             (reverse L)
    565             (loop (+ i 1) (cons (column-name stmt i) L))))))
    566   (define (column-name stmt i)    ;; Get result set column names, lazily.
    567     (let ((v (statement-column-names stmt)))
    568       (or (vector-ref v i)
    569           (let ((name (string->symbol
    570                        (sqlite3_column_name (nonnull-statement-ptr stmt)
    571                                             i))))
    572             (vector-set! v i name)
    573             name))))
    574   (define (column-type stmt i)
    575     ;; can't be cached, only valid for current row
    576     (int->type (sqlite3_column_type (nonnull-statement-ptr stmt) i)))
    577   (define (column-data stmt i)
    578     (let* ((stmt-ptr (nonnull-statement-ptr stmt))
    579            (t (sqlite3_column_type stmt-ptr i)))  ; faster than column-type
    580       ;; INTEGER type may reach 64 bits; return at least 53 significant.     
    581       (cond ((= t type/integer) (sqlite3_column_int64 stmt-ptr i))
    582             ((= t type/float)   (sqlite3_column_double stmt-ptr i))
    583             ((= t type/text)    (sqlite3_column_text stmt-ptr i)) ; NULs OK??
    584             ((= t type/null)    '())
    585             ((= t type/blob)
    586              (let ((b (make-blob (sqlite3_column_bytes stmt-ptr i)))
    587                    (%copy! (foreign-lambda c-pointer "C_memcpy"
    588                                            scheme-pointer c-pointer int)))
    589                (%copy! b (sqlite3_column_blob stmt-ptr i) (blob-size b))
    590                b))
    591         (else
    592          (error 'column-data "illegal type"))))) ; assertion
    593 
    594   ;; Retrieve all columns from current row.  Does not coerce DONE
    595   ;; to '(); instead returns NULL for all columns.
    596   (define (row-data stmt)
    597     (let ((ncol (column-count stmt)))
    598       (let loop ((i 0))
    599         (if (fx>= i ncol)
    600             '()
    601             (cons (column-data stmt i)
    602                   (loop (fx+ i 1)))))))
    603 
    604   (define (row-alist stmt)
    605     (let ((ncol (column-count stmt)))
    606       (let loop ((i 0))
    607         (if (fx>= i ncol)
    608             '()
    609             (cons (cons (column-name stmt i)
    610                         (column-data stmt i))
    611                   (loop (fx+ i 1)))))))
    612 
    613   ;; Step statement and return row data. Returns #f (or error) on failure,
    614   ;; '() on done, '(col1 col2 ...) on success.
    615   (define (fetch s)
    616     (and-let* ((rv (step s)))
    617       (case rv
    618         ((done) '())
    619         ((row) (row-data s))
    620         (else
    621          (error 'fetch "internal error: step result invalid" rv)))))
    622   ;; Same as fetch, but returns an alist: '((name1 . col1) ...)
    623   (define (fetch-alist s)               ; nearly identical to (fetch)
    624     (and-let* ((rv (step s)))
    625       (case rv
    626         ((done) '())
    627         ((row) (row-alist s))
    628         (else
    629          (error 'fetch "internal error: step result invalid" rv)))))
    630  
    631   ;; Fetch remaining rows into a list.
    632   (define (fetch-all s)
    633     (let loop ((L '()))
    634       (let ((row (fetch s)))
    635         (cond ((null? row)
    636                (reverse L))
    637               (row
    638                (loop (cons row L)))
    639               (else
    640                ;; Semantics are odd if exception raising is disabled.
    641                (error 'fetch-all "fetch failed" s))))))
     592           (error 'column-data "illegal type"))))) ; assertion
     593
     594;; Retrieve all columns from current row.  Does not coerce DONE
     595;; to '(); instead returns NULL for all columns.
     596(define (row-data stmt)
     597  (let ((ncol (column-count stmt)))
     598    (let loop ((i 0))
     599      (if (fx>= i ncol)
     600          '()
     601          (cons (column-data stmt i)
     602                (loop (fx+ i 1)))))))
     603
     604(define (row-alist stmt)
     605  (let ((ncol (column-count stmt)))
     606    (let loop ((i 0))
     607      (if (fx>= i ncol)
     608          '()
     609          (cons (cons (column-name stmt i)
     610                      (column-data stmt i))
     611                (loop (fx+ i 1)))))))
     612
     613;; Step statement and return row data. Returns #f (or error) on failure,
     614;; '() on done, '(col1 col2 ...) on success.
     615(define (fetch s)
     616  (and-let* ((rv (step s)))
     617    (case rv
     618      ((done) '())
     619      ((row) (row-data s))
     620      (else
     621       (error 'fetch "internal error: step result invalid" rv)))))
     622;; Same as fetch, but returns an alist: '((name1 . col1) ...)
     623(define (fetch-alist s)               ; nearly identical to (fetch)
     624  (and-let* ((rv (step s)))
     625    (case rv
     626      ((done) '())
     627      ((row) (row-alist s))
     628      (else
     629       (error 'fetch "internal error: step result invalid" rv)))))
     630
     631;; Fetch remaining rows into a list.
     632(define (fetch-all s)
     633  (let loop ((L '()))
     634    (let ((row (fetch s)))
     635      (cond ((null? row)
     636             (reverse L))
     637            (row
     638             (loop (cons row L)))
     639            (else
     640             ;; Semantics are odd if exception raising is disabled.
     641             (error 'fetch-all "fetch failed" s))))))
    642642
    643643;;   (define (step-through stmt)
     
    649649
    650650;;; Database
    651  
    652   ;; If errors are off, user can't retrieve error message as we
    653   ;; return #f instead of db; though it's probably SQLITE_CANTOPEN.
    654   ;; Perhaps this should always throw an error.
    655   ;; NULL (#f) filename allowed, creates private on-disk database,
    656   ;; same as "".
    657   ;; Allows symbols 'memory => ":memory:" and 'temp or 'temporary => ""
    658   ;; as filename.
    659   (define (open-database filename)
    660     (let ((filename
    661            (if (string? filename)
    662                (##sys#expand-home-path filename)
    663                (case filename
    664                  ((memory) ":memory:")
    665                  ((temp temporary) "")
    666                  (else (error 'open-database "unrecognized database type"
    667                               filename))))))
    668       (let-location ((db-ptr (c-pointer "sqlite3")))
    669         (let* ((rv (sqlite3_open (##sys#expand-home-path filename)
    670                                  (location db-ptr))))
    671           (if (eqv? rv status/ok)
    672               (make-db db-ptr
    673                        filename
    674                        #f                       ; busy-handler
    675                        (object-evict (vector #f)) ; invoked-busy?
    676                        (make-lru-cache (prepared-cache-size)
    677                                        string=?
    678                                        (lambda (sql stmt)
    679                                          (finalize-transient stmt))))
    680               (if db-ptr
    681                   (database-error (make-db db-ptr filename #f #f #f) rv
    682                                   'open-database filename)
    683                   (error 'open-database "internal error: out of memory")))))))
    684 
    685   (define (close-database db)
    686     (let ((db-ptr (nonnull-db-ptr db)))
    687       (lru-cache-flush! (db-statement-cache db))
    688       (do ((stmt (sqlite3_next_stmt db-ptr #f) ; finalize pending statements
    689                  (sqlite3_next_stmt db-ptr stmt)))
    690           ((not stmt))
    691         (warning (sprintf "finalizing pending statement: ~S"
    692                           (sqlite3_sql stmt)))
    693         (sqlite3_finalize stmt))
    694       (cond ((eqv? status/ok (sqlite3_close db-ptr))
    695              (set-db-ptr! db #f)
    696              (object-release (db-invoked-busy-handler? db))
    697              #t)
    698             (else #f))))
    699 
    700   (define (call-with-database filename proc)
    701     (let ((db (open-database filename)))
    702       (let ((c (current-exception-handler)))
    703         (begin0
    704             (with-exception-handler
    705              (lambda (ex) (close-database db) (c ex))
    706              (lambda () (proc db)))
    707           (close-database db)))))
    708  
    709   (define (error-code db)
    710     (int->status (sqlite3_errcode (nonnull-db-ptr db))))
    711   (define (error-message db)
    712     (sqlite3_errmsg (nonnull-db-ptr db)))
    713   (define (database-error db code where . args)
    714     (and (raise-database-errors)
    715          (apply raise-database-error db code where args)))
    716   (define (raise-database-error db code where . args)
    717     ;; status/misuse may not set the error code and message; signal
    718     ;; a generic misuse error if we believe that has happened.
    719     ;; [ref. http://www.sqlite.org/c3ref/errcode.html]
    720     (if (or (not (= code status/misuse))
    721             (eqv? (error-code db) 'misuse))
    722         (raise-database-error/status
    723          db (int->status code) where (error-message db) args)
    724         (raise-database-error/status
    725          db 'misuse where "misuse of interface" args)))
    726   (define (raise-database-error/status db status where message args)
    727     (abort
    728      (make-composite-condition
    729       (make-property-condition 'exn
    730                                'location where
    731                                'message message
    732                                'arguments args)
    733       (make-property-condition 'sqlite
    734                                'status status
    735                                'message message))))
    736   (define sqlite-exception? (condition-predicate 'sqlite))
    737   ;; note that these will return #f if you pass it a non-sqlite condition
    738   (define sqlite-exception-status (condition-property-accessor 'sqlite 'status))
    739   (define sqlite-exception-message (condition-property-accessor 'sqlite 'message))
     651
     652;; If errors are off, user can't retrieve error message as we
     653;; return #f instead of db; though it's probably SQLITE_CANTOPEN.
     654;; Perhaps this should always throw an error.
     655;; NULL (#f) filename allowed, creates private on-disk database,
     656;; same as "".
     657;; Allows symbols 'memory => ":memory:" and 'temp or 'temporary => ""
     658;; as filename.
     659(define (open-database filename)
     660  (let ((filename
     661         (if (string? filename)
     662             (##sys#expand-home-path filename)
     663             (case filename
     664               ((memory) ":memory:")
     665               ((temp temporary) "")
     666               (else (error 'open-database "unrecognized database type"
     667                            filename))))))
     668    (let-location ((db-ptr (c-pointer "sqlite3")))
     669      (let* ((rv (sqlite3_open (##sys#expand-home-path filename)
     670                               (location db-ptr))))
     671        (if (eqv? rv status/ok)
     672            (make-db db-ptr
     673                     filename
     674                     #f                       ; busy-handler
     675                     (object-evict (vector #f)) ; invoked-busy?
     676                     (make-lru-cache (prepared-cache-size)
     677                                     string=?
     678                                     (lambda (sql stmt)
     679                                       (finalize-transient stmt))))
     680            (if db-ptr
     681                (database-error (make-db db-ptr filename #f #f #f) rv
     682                                'open-database filename)
     683                (error 'open-database "internal error: out of memory")))))))
     684
     685(define (close-database db)
     686  (let ((db-ptr (nonnull-db-ptr db)))
     687    (lru-cache-flush! (db-statement-cache db))
     688    (do ((stmt (sqlite3_next_stmt db-ptr #f) ; finalize pending statements
     689               (sqlite3_next_stmt db-ptr stmt)))
     690        ((not stmt))
     691      (warning (sprintf "finalizing pending statement: ~S"
     692                        (sqlite3_sql stmt)))
     693      (sqlite3_finalize stmt))
     694    (cond ((eqv? status/ok (sqlite3_close db-ptr))
     695           (set-db-ptr! db #f)
     696           (object-release (db-invoked-busy-handler? db))
     697           #t)
     698          (else #f))))
     699
     700(define (call-with-database filename proc)
     701  (let ((db (open-database filename)))
     702    (let ((c (current-exception-handler)))
     703      (begin0
     704          (with-exception-handler
     705           (lambda (ex) (close-database db) (c ex))
     706           (lambda () (proc db)))
     707        (close-database db)))))
     708
     709(define (error-code db)
     710  (int->status (sqlite3_errcode (nonnull-db-ptr db))))
     711(define (error-message db)
     712  (sqlite3_errmsg (nonnull-db-ptr db)))
     713(define (database-error db code where . args)
     714  (and (raise-database-errors)
     715       (apply raise-database-error db code where args)))
     716(define (raise-database-error db code where . args)
     717  ;; status/misuse may not set the error code and message; signal
     718  ;; a generic misuse error if we believe that has happened.
     719  ;; [ref. http://www.sqlite.org/c3ref/errcode.html]
     720  (if (or (not (= code status/misuse))
     721          (eqv? (error-code db) 'misuse))
     722      (raise-database-error/status
     723       db (int->status code) where (error-message db) args)
     724      (raise-database-error/status
     725       db 'misuse where "misuse of interface" args)))
     726(define (raise-database-error/status db status where message args)
     727  (abort
     728   (make-composite-condition
     729    (make-property-condition 'exn
     730                             'location where
     731                             'message message
     732                             'arguments args)
     733    (make-property-condition 'sqlite
     734                             'status status
     735                             'message message))))
     736(define sqlite-exception? (condition-predicate 'sqlite))
     737;; note that these will return #f if you pass it a non-sqlite condition
     738(define sqlite-exception-status (condition-property-accessor 'sqlite 'status))
     739(define sqlite-exception-message (condition-property-accessor 'sqlite 'message))
    740740
    741741;;; Transactions
    742742
    743   ;; Escaping or re-entering the dynamic extent of THUNK will not
    744   ;; affect the in-progress transaction.  However, if an exception
    745   ;; occurs, or THUNK returns #f, the transaction will be rolled back.
    746   ;; A rollback failure is a critical error and you should likely abort.
    747   (define with-transaction
    748     (let ((tsqls '((deferred . "begin deferred;")
    749                    (immediate . "begin immediate;")
    750                    (exclusive . "begin exclusive;"))))
    751       (lambda (db thunk #!optional (type 'deferred))
    752         (and (exec (sql db (or (alist-ref type tsqls)
    753                                (error 'with-transaction
    754                                       "invalid transaction type" type))))
    755              (let ((rv
    756                     (handle-exceptions ex (begin (or (rollback db)
    757                                                      (error 'with-transaction
    758                                                             "rollback failed"))
    759                                                  (abort ex))
    760                       (let ((rv (thunk))) ; only 1 return value allowed
    761                         (and rv
    762                              (commit db)  ; maybe warn on #f
    763                              rv)))))
    764                (or rv
    765                    (if (rollback db)
    766                        #f
    767                        (error 'with-transaction "rollback failed"))))))))
    768  
    769   (define with-deferred-transaction with-transaction) ; convenience fxns
    770   (define (with-immediate-transaction db thunk)
    771     (with-transaction db thunk 'immediate))
    772   (define (with-exclusive-transaction db thunk)
    773     (with-transaction db thunk 'exclusive))
    774 
    775   (define (autocommit? db)
    776     (sqlite3_get_autocommit (nonnull-db-ptr db)))
    777 
    778   ;; Rollback current transaction.  Reset running queries before doing
    779   ;; so, as rollback would fail if read or read/write queries are
    780   ;; running.  Rolling back when no transaction is active returns #t.
    781   (define (rollback db)
    782     (cond ((autocommit? db) #t)
    783           (else
    784            (reset-running-queries! db)
    785            (exec (sql db "rollback;")))))
    786   ;; Commit current transaction.  This does not roll back running queries,
    787   ;; because running read queries are acceptable, and the behavior in the
    788   ;; presence of pending write statements is unclear.  If the commit
    789   ;; fails, you can always rollback, which will reset the pending queries.
    790   (define (commit db)
    791     (cond ((autocommit? db) #t)
    792           (else
    793            ;; (reset-running-queries! db)
    794            (exec (sql db "commit;")))))
    795   ;; Reset all running queries.  A list of all prepared statements known
    796   ;; to the library is obtained; if a statement is found in the cache,
    797   ;; we call (reset) on it.  If it is not, it is a transient statement,
    798   ;; which we do not track; forcibly reset it as its run state is unknown.
    799   ;; Statements that fall off the cache have been finalized and are
    800   ;; consequently not known to the library.
    801   (define (reset-running-queries! db)
    802     (let ((db-ptr (nonnull-db-ptr db))
    803           (c (db-statement-cache db)))
    804       (do ((sptr (sqlite3_next_stmt db-ptr #f)
    805                  (sqlite3_next_stmt db-ptr sptr)))
    806           ((not sptr))
    807         (let* ((sql (sqlite3_sql sptr))
    808                (s (lru-cache-ref c sql)))
    809           (if (and s
    810                    (pointer=? (statement-ptr s) sptr))
    811               (reset-unconditionally s)   ; in case our state is out of sync
    812               (begin
    813                 (fprintf
    814                  (current-error-port)
    815                  "Warning: resetting transient prepared statement: ~S\n" sql)
    816                 (sqlite3_reset sptr)))))))
     743;; Escaping or re-entering the dynamic extent of THUNK will not
     744;; affect the in-progress transaction.  However, if an exception
     745;; occurs, or THUNK returns #f, the transaction will be rolled back.
     746;; A rollback failure is a critical error and you should likely abort.
     747(define with-transaction
     748  (let ((tsqls '((deferred . "begin deferred;")
     749                 (immediate . "begin immediate;")
     750                 (exclusive . "begin exclusive;"))))
     751    (lambda (db thunk #!optional (type 'deferred))
     752      (and (exec (sql db (or (alist-ref type tsqls)
     753                             (error 'with-transaction
     754                                    "invalid transaction type" type))))
     755           (let ((rv
     756                  (handle-exceptions ex (begin (or (rollback db)
     757                                                   (error 'with-transaction
     758                                                          "rollback failed"))
     759                                               (abort ex))
     760                    (let ((rv (thunk))) ; only 1 return value allowed
     761                      (and rv
     762                           (commit db)  ; maybe warn on #f
     763                           rv)))))
     764             (or rv
     765                 (if (rollback db)
     766                     #f
     767                     (error 'with-transaction "rollback failed"))))))))
     768
     769(define with-deferred-transaction with-transaction) ; convenience fxns
     770(define (with-immediate-transaction db thunk)
     771  (with-transaction db thunk 'immediate))
     772(define (with-exclusive-transaction db thunk)
     773  (with-transaction db thunk 'exclusive))
     774
     775(define (autocommit? db)
     776  (sqlite3_get_autocommit (nonnull-db-ptr db)))
     777
     778;; Rollback current transaction.  Reset running queries before doing
     779;; so, as rollback would fail if read or read/write queries are
     780;; running.  Rolling back when no transaction is active returns #t.
     781(define (rollback db)
     782  (cond ((autocommit? db) #t)
     783        (else
     784         (reset-running-queries! db)
     785         (exec (sql db "rollback;")))))
     786;; Commit current transaction.  This does not roll back running queries,
     787;; because running read queries are acceptable, and the behavior in the
     788;; presence of pending write statements is unclear.  If the commit
     789;; fails, you can always rollback, which will reset the pending queries.
     790(define (commit db)
     791  (cond ((autocommit? db) #t)
     792        (else
     793         ;; (reset-running-queries! db)
     794         (exec (sql db "commit;")))))
     795;; Reset all running queries.  A list of all prepared statements known
     796;; to the library is obtained; if a statement is found in the cache,
     797;; we call (reset) on it.  If it is not, it is a transient statement,
     798;; which we do not track; forcibly reset it as its run state is unknown.
     799;; Statements that fall off the cache have been finalized and are
     800;; consequently not known to the library.
     801(define (reset-running-queries! db)
     802  (let ((db-ptr (nonnull-db-ptr db))
     803        (c (db-statement-cache db)))
     804    (do ((sptr (sqlite3_next_stmt db-ptr #f)
     805               (sqlite3_next_stmt db-ptr sptr)))
     806        ((not sptr))
     807      (let* ((sql (sqlite3_sql sptr))
     808             (s (lru-cache-ref c sql)))
     809        (if (and s
     810                 (pointer=? (statement-ptr s) sptr))
     811            (reset-unconditionally s)   ; in case our state is out of sync
     812            (begin
     813              (fprintf
     814               (current-error-port)
     815               "Warning: resetting transient prepared statement: ~S\n" sql)
     816              (sqlite3_reset sptr)))))))
    817817
    818818;;; Busy handling
    819819
    820   ;; Busy handling is done entirely in the application, as with SRFI-18
    821   ;; threads it is not legal to yield within a callback.  The backoff
    822   ;; algorithm of sqlite3_busy_timeout is reimplemented.
    823 
    824   ;; SQLite can deadlock in certain situations and to avoid this will
    825   ;; return SQLITE_BUSY immediately rather than invoking the busy handler.
    826   ;; However if there is no busy handler, we cannot tell a retryable
    827   ;; SQLITE_BUSY from a deadlock one.  To gain deadlock protection we
    828   ;; register a simple busy handler which sets a flag indicating this
    829   ;; BUSY is retryable.  This handler writes the flag into an evicted
    830   ;; object in static memory so it need not call back into Scheme nor
    831   ;; require safe-lambda for all calls into SQLite (a performance killer!)
    832  
    833   (define (retry-busy? db)
    834     (vector-ref (db-invoked-busy-handler? db) 0))
    835   (define (reset-busy! db)
    836     (vector-set! (db-invoked-busy-handler? db) 0 #f))
    837   (define (set-busy-handler! db proc)
    838     (set-db-busy-handler! db proc)
    839     (if proc
    840         (sqlite3_busy_handler (nonnull-db-ptr db)
    841                               (foreign-value "busy_notification_handler"
    842                                              c-pointer)
    843                               (object->pointer
    844                                (db-invoked-busy-handler? db)))
    845         (sqlite3_busy_handler (nonnull-db-ptr db) #f #f))
    846     (void))
    847   (define (thread-sleep!/ms ms)
    848     (thread-sleep!
    849      (milliseconds->time (+ ms (current-milliseconds)))))
    850   ;; (busy-timeout ms) returns a procedure suitable for use in
    851   ;; set-busy-handler!, implementing a spinning busy timeout using the
    852   ;; SQLite3 busy algorithm.  Other threads may be scheduled while
    853   ;; this one is busy-waiting.
    854   (define busy-timeout
    855     (let* ((delays '#(1 2 5 10 15 20 25 25  25  50  50 100))
    856            (totals '#(0 1 3  8 18 33 53 78 103 128 178 228))
    857            (ndelay (vector-length delays)))
    858       (lambda (ms)
    859         (cond
    860          ((< ms 0) (error 'busy-timeout "timeout must be non-negative" ms))
    861          ((= ms 0) #f)
    862          (else
    863           (lambda (db count)
    864             (let* ((delay (vector-ref delays (min count (- ndelay 1))))
    865                    (prior (if (< count ndelay)
    866                               (vector-ref totals count)
    867                               (+ (vector-ref totals (- ndelay 1))
    868                                  (* delay (- count (- ndelay 1)))))))
    869               (let ((delay (if (> (+ prior delay) ms)
    870                                (- ms prior)
    871                                delay)))
    872                 (cond ((<= delay 0) #f)
    873                       (else
    874                        (thread-sleep!/ms delay)
    875                        #t))))))))))
     820;; Busy handling is done entirely in the application, as with SRFI-18
     821;; threads it is not legal to yield within a callback.  The backoff
     822;; algorithm of sqlite3_busy_timeout is reimplemented.
     823
     824;; SQLite can deadlock in certain situations and to avoid this will
     825;; return SQLITE_BUSY immediately rather than invoking the busy handler.
     826;; However if there is no busy handler, we cannot tell a retryable
     827;; SQLITE_BUSY from a deadlock one.  To gain deadlock protection we
     828;; register a simple busy handler which sets a flag indicating this
     829;; BUSY is retryable.  This handler writes the flag into an evicted
     830;; object in static memory so it need not call back into Scheme nor
     831;; require safe-lambda for all calls into SQLite (a performance killer!)
     832
     833(define (retry-busy? db)
     834  (vector-ref (db-invoked-busy-handler? db) 0))
     835(define (reset-busy! db)
     836  (vector-set! (db-invoked-busy-handler? db) 0 #f))
     837(define (set-busy-handler! db proc)
     838  (set-db-busy-handler! db proc)
     839  (if proc
     840      (sqlite3_busy_handler (nonnull-db-ptr db)
     841                            (foreign-value "busy_notification_handler"
     842                                           c-pointer)
     843                            (object->pointer
     844                             (db-invoked-busy-handler? db)))
     845      (sqlite3_busy_handler (nonnull-db-ptr db) #f #f))
     846  (void))
     847(define (thread-sleep!/ms ms)
     848  (thread-sleep!
     849   (milliseconds->time (+ ms (current-milliseconds)))))
     850;; (busy-timeout ms) returns a procedure suitable for use in
     851;; set-busy-handler!, implementing a spinning busy timeout using the
     852;; SQLite3 busy algorithm.  Other threads may be scheduled while
     853;; this one is busy-waiting.
     854(define busy-timeout
     855  (let* ((delays '#(1 2 5 10 15 20 25 25  25  50  50 100))
     856         (totals '#(0 1 3  8 18 33 53 78 103 128 178 228))
     857         (ndelay (vector-length delays)))
     858    (lambda (ms)
     859      (cond
     860       ((< ms 0) (error 'busy-timeout "timeout must be non-negative" ms))
     861       ((= ms 0) #f)
     862       (else
     863        (lambda (db count)
     864          (let* ((delay (vector-ref delays (min count (- ndelay 1))))
     865                 (prior (if (< count ndelay)
     866                            (vector-ref totals count)
     867                            (+ (vector-ref totals (- ndelay 1))
     868                               (* delay (- count (- ndelay 1)))))))
     869            (let ((delay (if (> (+ prior delay) ms)
     870                             (- ms prior)
     871                             delay)))
     872              (cond ((<= delay 0) #f)
     873                    (else
     874                     (thread-sleep!/ms delay)
     875                     #t))))))))))
    876876
    877877  )  ; module
Note: See TracChangeset for help on using the changeset viewer.