source: project/release/4/sql-de-lite/trunk/sql-de-lite.scm @ 29936

Last change on this file since 29936 was 29936, checked in by Jim Ursetto, 7 years ago

sql-de-lite: Protect against access to busy handler after handler object freed

File size: 50.6 KB
Line 
1;;; sql-de-lite interface to SQLite 3
2
3;; Copyright (c) 2009 Jim Ursetto.  All rights reserved.
4;; BSD license at end of file.
5
6;;; Direct-to-C
7
8#>  #include <sqlite3.h> <#
9#>
10int busy_notification_handler(void *ctx, int times) {
11   *(C_word*)(C_data_pointer(ctx)) = C_SCHEME_TRUE;
12   return 0;
13}
14#define sqlite3_step_safe sqlite3_step
15<#
16
17;;; Module definition
18
19(module sql-de-lite
20 (
21  error-code error-message
22  open-database close-database
23  prepare prepare-transient
24  finalize resurrect
25  step ; step-through
26  fetch fetch-alist
27  fetch-all first-column
28  fetch-value
29  fetch-column fetch-row fetch-rows fetch-alists
30  column-count column-name column-type column-data
31  column-names                         ; convenience
32  bind bind-parameters bind-parameter-count bind-parameter-name
33  library-version                      ; string, not proc
34  row-data row-alist
35  reset ;reset-unconditionally         ; core binding!
36  call-with-database
37  change-count total-change-count last-insert-rowid
38  with-transaction with-deferred-transaction
39  with-immediate-transaction with-exclusive-transaction
40  autocommit?
41  rollback commit
42
43  set-busy-handler! busy-timeout
44
45  ;; advanced interface
46  query query* exec exec* sql sql/transient
47
48  ;; parameters
49  raise-database-errors
50  prepared-cache-size
51
52  ;; experimental interface
53  for-each-row for-each-row*
54  map-rows map-rows*
55  fold-rows
56  fold-rows*   ;; deprecated
57  schema print-schema
58  flush-cache!
59
60  ;; exceptions
61  sqlite-exception?
62  sqlite-exception-status
63  sqlite-exception-message
64
65  finalized?
66  database-closed?
67
68  ;; user-defined functions
69  register-scalar-function!
70  register-aggregate-function! 
71  )
72
73(import scheme
74        (except chicken reset))
75(import (only extras fprintf sprintf))
76(require-library lolevel srfi-18)
77(import (only lolevel
78              object->pointer object-release object-evict pointer=?))
79(import (only data-structures alist-ref))
80(import (only srfi-18 thread-sleep! milliseconds->time))
81(import foreign foreigners)
82(require-extension lru-cache)
83
84;;; Foreign interface
85
86(include "sqlite3-api.scm")
87
88(define-foreign-enum-type (sqlite3:type int)
89  (type->int int->type)
90  ((integer type/integer) SQLITE_INTEGER)
91  ((float   type/float)   SQLITE_FLOAT)
92  ((text    type/text)    SQLITE_TEXT)
93  ((blob    type/blob)    SQLITE_BLOB)
94  ((null    type/null)    SQLITE_NULL))
95
96(define-foreign-enum-type (sqlite3:status int)
97  (status->int int->status)
98  ((ok status/ok)               SQLITE_OK)
99  ((error status/error)         SQLITE_ERROR)
100  ((internal status/internal)   SQLITE_INTERNAL)
101  ((permission
102    status/permission)          SQLITE_PERM)
103  ((abort status/abort)         SQLITE_ABORT)
104  ((busy status/busy)           SQLITE_BUSY)
105  ((locked status/locked)       SQLITE_LOCKED)
106  ((no-memory status/no-memory) SQLITE_NOMEM)
107  ((read-only status/read-only) SQLITE_READONLY)
108  ((interrupt status/interrupt) SQLITE_INTERRUPT)
109  ((io-error status/io-error)   SQLITE_IOERR)
110  ((corrupt status/corrupt)     SQLITE_CORRUPT)
111  ((not-found status/not-found) SQLITE_NOTFOUND)
112  ((full status/full)           SQLITE_FULL)
113  ((cant-open status/cant-open) SQLITE_CANTOPEN)
114  ((protocol status/protocol)   SQLITE_PROTOCOL)
115  ((empty status/empty)         SQLITE_EMPTY)
116  ((schema status/schema)       SQLITE_SCHEMA)
117  ((too-big status/too-big)     SQLITE_TOOBIG)
118  ((constraint
119    status/constraint)          SQLITE_CONSTRAINT)
120  ((mismatch status/mismatch)   SQLITE_MISMATCH)
121  ((misuse status/misuse)       SQLITE_MISUSE)
122  ((no-lfs status/no-lfs)       SQLITE_NOLFS)
123  ((authorization
124    status/authorization)       SQLITE_AUTH)
125  ((format status/format)       SQLITE_FORMAT)
126  ((range status/range)         SQLITE_RANGE)
127  ((not-a-database
128    status/not-a-database)      SQLITE_NOTADB)
129  ((row status/row)             SQLITE_ROW)
130  ((done status/done)           SQLITE_DONE))
131
132(define-foreign-type sqlite3:destructor-type
133  (function "void" (c-pointer "void")))
134(define-foreign-variable destructor-type/transient
135  sqlite3:destructor-type "SQLITE_TRANSIENT")
136(define-foreign-variable destructor-type/static
137  sqlite3:destructor-type "SQLITE_STATIC")
138
139(define library-version (foreign-value "sqlite3_version" c-string))
140
141;;; Parameters
142
143(define raise-database-errors (make-parameter #t))
144(define prepared-cache-size (make-parameter 100))
145
146;;; Syntax
147
148(define-syntax begin0                 ; multiple values discarded
149  (syntax-rules () ((_ e0 e1 ...)
150                    (let ((tmp e0)) e1 ... tmp))))
151
152;;; Records
153
154(define-record-type sqlite-database
155  (make-db ptr filename busy-handler invoked-busy-handler? safe-step? statement-cache)
156  db?
157  (ptr db-ptr set-db-ptr!)
158  (filename db-filename)
159  (busy-handler db-busy-handler set-db-busy-handler!)
160  (invoked-busy-handler? db-invoked-busy-handler? set-db-invoked-busy-handler?!)
161  (safe-step? db-safe-step? set-db-safe-step!)  ;; global flag indicating step needs safe-lambda
162  (statement-cache db-statement-cache))
163(define-record-printer (sqlite-database db port)
164  (fprintf port "#<sqlite-database ~A on ~S>"
165           (or (db-ptr db)
166               "(closed)")
167           (db-filename db)))
168
169(define-inline (nonnull-db-ptr db)
170  (or (db-ptr db)
171      (error 'sql-de-lite "operation on closed database")))
172
173;; Thin wrapper around sqlite-statement-handle, adding the two keys
174;; which allows us to reconstitute a finalized statement.
175(define-record-type sqlite-statement
176  (make-statement db sql handle transient?)
177  statement?
178  (db  statement-db)
179  (sql statement-sql)
180  (handle statement-handle set-statement-handle!)
181  (transient? statement-transient? set-statement-transient!))
182(define-record-printer (sqlite-statement s p)
183  (fprintf p "#<sqlite-statement ~S>"
184           (statement-sql s)))
185
186;; Internal record making up the guts of a prepared statement;
187;; always embedded in a sqlite-statement.
188(define-record-type sqlite-statement-handle
189  (make-handle ptr column-names
190               parameter-count cached? run-state)
191  handle?
192  (ptr handle-ptr set-handle-ptr!)
193  (column-names handle-column-names set-handle-column-names!)
194  (parameter-count handle-parameter-count)
195  ;; cached? flag avoids a cache-ref to check existence.
196  (cached? handle-cached? set-handle-cached!)
197  (run-state handle-run-state set-handle-run-state!))
198
199;; Convenience accessors for guts of statement.  Should be inlined.
200(define (statement-ptr s)
201  (handle-ptr (statement-handle s)))
202(define (set-statement-ptr! s p)
203  (set-handle-ptr! (statement-handle s) p))
204(define (statement-column-names s)
205  (handle-column-names (statement-handle s)))
206(define (set-statement-column-names! s v)
207  (set-handle-column-names! (statement-handle s) v))
208(define (statement-parameter-count s)
209  (handle-parameter-count (statement-handle s)))
210(define (statement-cached? s)
211  (handle-cached? (statement-handle s)))
212(define (set-statement-cached! s b)
213  (set-handle-cached! (statement-handle s) b))
214(define (statement-run-state s)
215  (handle-run-state (statement-handle s)))
216;; use an int instead of symbol; this is internal, and avoids mutations
217(define (statement-reset? s)
218  (= 0 (handle-run-state (statement-handle s))))
219(define (statement-running? s)
220  (= 1 (handle-run-state (statement-handle s))))
221(define (statement-done? s)
222  (= 2 (handle-run-state (statement-handle s))))
223(define (set-statement-reset! s)
224  (set-handle-run-state! (statement-handle s) 0))
225(define (set-statement-running! s)
226  (set-handle-run-state! (statement-handle s) 1))
227(define (set-statement-done! s)
228  (set-handle-run-state! (statement-handle s) 2))
229(define (statement-safe-step? s)
230  (db-safe-step? (statement-db s)))      ;; just check the global safe step
231
232(define-inline (nonnull-statement-ptr stmt)
233  ;; All references to statement ptr implicitly check for valid db.
234  (or (and (nonnull-db-ptr (statement-db stmt))
235           (statement-handle stmt)
236           (statement-ptr stmt))
237      (error 'sql-de-lite "operation on finalized statement")))
238
239(define (finalized? stmt)             ; inline
240  (or (not (statement-handle stmt))
241      (not (statement-ptr stmt))))
242
243;;; High-level interface
244
245(define (sql db sql-str)
246  (make-statement db sql-str #f #f))     ; (finalized? s) => #t
247(define (sql/transient db sql-str)
248  (make-statement db sql-str #f #t))
249
250;; Resurrects finalized statement s or, if still live, just resets it.
251;; Returns s, which is also modified in place.
252(define (resurrect s)                ; inline
253  (cond ((finalized? s)
254         (prepare! s))
255        (else
256         (reset s))))
257
258;; fast version of unwind-protect*; does not use handle-exceptions
259;; so it is unsafe to throw an error inside the exception handler (program will lock up).
260(define-syntax fast-unwind-protect*
261  (syntax-rules ()
262    ((_ protected cleanup)
263     (fast-unwind-protect* protected cleanup cleanup))
264    ((_ protected normal abnormal)
265     (begin0
266         (let ((c (current-exception-handler)))
267           (with-exception-handler
268            (lambda (ex)
269              abnormal
270              (c ex))
271            (lambda () protected)))
272       normal))))
273
274;; Resurrects s, binds args to s and performs a query*.  If the statement
275;; was not cached, also finalizes the statement.  This is the
276;; usual way to perform a query unless you need to bind arguments
277;; manually or need other manual control.
278(define (query proc s . args)
279  (resurrect s)
280  (if (statement-cached? s)
281      ;; It's a no-op to call (finalize s) on a cached statement, but
282      ;; entirely unnecessary.
283      (and (apply bind-parameters s args)
284           (query* proc s))
285      (fast-unwind-protect*
286       (and (apply bind-parameters s args)
287            (query* proc s))
288       (finalize-transient s))))
289;; Calls (proc s) and resets the statement immediately afterward, to
290;; avoid locking the database.  If an exception occurs during proc,
291;; the statement will still be reset.  Statement is NOT reset before
292;; execution.  Note that, as closing the database will also reset any
293;; pending statements, you can dispense with the unwind-protect as long
294;; as you don't attempt to continue.
295(define (query* proc s)
296  ;; Warning: if you remove test for (statement? s) in fast-unwind-protect*
297  ;; abnormal exit, you must test it before entry like:
298  ;; (unless (statement? s)
299  ;;   (error 'query* "not a statement" s))
300  (fast-unwind-protect*
301   (proc s)
302   (reset s)  ;; May be ok to check finalized? here to avoid error if user finalized in PROC.
303   (when (and (statement? s) (not (finalized? s)))
304     (reset-unconditionally s))))
305
306;; Resurrects s, binds args to s and performs an exec*.
307(define (exec s . args)
308  (resurrect s)
309  (if (statement-cached? s)
310      (and (apply bind-parameters s args)
311           (exec* s))
312      (fast-unwind-protect*
313       (and (apply bind-parameters s args)
314            (exec* s))
315       (finalize-transient s))))
316
317;; Executes statement s, returning the number of changes (if the
318;; result set has no columns as in INSERT, DELETE) or the first row
319;; (if column data is returned as in SELECT).  Resurrection is
320;; omitted, as it would wipe out any bindings.  Reset is NOT done
321;; beforehand; it is cheap, but the user must reset before a bind
322;; anyway.  Reset afterward is not done via unwind-protect; it will
323;; be done here if a row was returned, and in step() if a database
324;; error or busy occurs, but a Scheme error (such as retrieving
325;; column data > 16MB) will not cause a reset.  This is a flaw,
326;; but substantially faster.
327(define (exec* s)
328  (and-let* ((v (fetch s)))
329    (reset s)
330    (if (> (column-count s) 0)
331        v
332        (change-count (statement-db s)))))
333
334;; Statement traversal.  These return a lambda suitable for use
335;; in the proc slot of query.  They call fetch repeatedly
336;; to grab entire rows, passing them to proc.
337(define (for-each-row proc)
338  (lambda (s)
339    (let loop ()
340      (let ((x (fetch s)))
341        (cond ((null? x) #t)
342              (else
343               (proc x)
344               (loop)))))))
345(define (map-rows proc)
346  (lambda (s)
347    (let loop ((L '()))
348      (let ((x (fetch s)))
349        (cond ((null? x) (reverse L))
350              (else
351               (loop (cons (proc x) L))))))))
352(define (fold-rows kons knil)
353  (lambda (s)
354    (let loop ((xs knil))
355      (let ((x (fetch s)))
356        (cond ((null? x) xs)
357              (else
358               (loop (kons x xs))))))))
359;; In the starred versions, proc gets one arg for each column.
360;; Users can use match-lambda to achieve the same effect.
361(define (for-each-row* proc)
362  (for-each-row (lambda (r) (apply proc r))))
363(define (map-rows* proc)
364  (map-rows (lambda (r) (apply proc r))))
365(define (fold-rows* kons knil)   ;; Deprecated -- inefficient.
366  (fold-rows (lambda (r seed) (apply kons (append r (list seed))))
367             knil))
368
369;; These produce equivalent results: 
370;; (query (map-rows car) (sql db "select name, sql from sqlite_master;"))
371;; (map car (query fetch-all (sql db "select name, sql from sqlite_master;")))
372
373;; These produce equivalent results:
374;;
375;; (query (for-each-row* (lambda (name sql)
376;;                         (print "table: " name " sql: " sql ";")))
377;;        (sql db "select name, sql from sqlite_master;"))
378;; (query (for-each-row (match-lambda ((name sql)
379;;                         (print "table: " name " sql: " sql ";"))))
380;;        (sql db "select name, sql from sqlite_master;")) 
381
382;;; Experimental
383(define (print-schema db)
384  (for-each (lambda (x) (print x ";")) (schema db)))
385(define (schema db)
386  (query (map-rows car)
387         (sql db "select sql from sqlite_master where sql not NULL;")))
388(define (first-column row)
389  (and (pair? row) (car row)))
390(define (flush-cache! db)
391  (lru-cache-flush! (db-statement-cache db)))
392
393;;; Lowlevel interface
394
395;; Internal.  Returns a statement-handle suitable for embedding in
396;; a statement record.
397;; (Note: May return #f even on SQLITE_OK, which means the statement
398;; contained only whitespace and comments and nothing was compiled.)
399(define (prepare-handle db sql)
400  (let-location ((stmt (c-pointer "sqlite3_stmt")))
401    (let retry ((times 0))
402      (let ((dbptr (nonnull-db-ptr db)))
403        (reset-busy! db)
404        (let ((rv (sqlite3_prepare_v2 dbptr
405                                      sql
406                                      (string-length sql)
407                                      (location stmt)
408                                      #f)))
409          (cond ((= rv status/ok)
410                 (if stmt
411                     (let* ((nparam (sqlite3_bind_parameter_count stmt)))
412                       (make-handle stmt
413                                    #f  ; names
414                                    nparam
415                                    #f 0)) ; cached? run-state
416                     ;; Not strictly an error, but to handle it properly we must
417                     ;; create a dummy statement and change all statement interfaces
418                     ;; to respect it; until then, we'll make it illegal.
419                     (database-error db rv 'prepare sql ;; FIXME: This will show "not an error" error.
420                                     "attempted to prepare whitespace or comment SQL")))
421                ((= rv status/busy)
422                 (let ((bh (db-busy-handler db)))
423                   (if (and bh
424                            (retry-busy? db)
425                            (bh db times))
426                       (retry (+ times 1))
427                       (database-error db rv 'prepare sql))))
428                (else
429                 (database-error db rv 'prepare sql))))))))
430
431;; Looks up a prepared statement in the statement cache.  If not
432;; found, it prepares a statement and caches it.  If transient,
433;; the cache is ignored.  An exception is
434;; thrown if a statement we pulled from cache is currently running
435;; (we could just warn and reset, if this causes problems).
436;; Statements are also marked as cached, so FINALIZE is a no-op.
437;; PREPARE! is internal; it expects a statement S which has already
438;; been allocated, and mutates the statement handle.  Returns S on
439;; success or throws an error on failure (or returns #f if errors are disabled).
440(define (prepare! s)
441  (let* ((db  (statement-db s))
442         (sql (statement-sql s))
443         (c (db-statement-cache db)))
444    (define (get-handle)
445      (cond ((or (statement-transient? s)
446                 (= 0 (lru-cache-capacity c)))
447             (prepare-handle db sql))
448            (else
449             (cond ((lru-cache-ref c sql)
450                    => (lambda (s)
451                         (cond ((statement-running? s)
452                                (error 'prepare
453                                       "cached statement is currently executing" s))
454                               ((statement-done? s)
455                                (reset s)))
456                         (statement-handle s)))
457                   ((prepare-handle db sql)
458                    => (lambda (h)
459                         (when (> (lru-cache-capacity c) 0)
460                           (set-handle-cached! h #t)
461                           (lru-cache-set! c sql s)) ;; s's handle slot will later be mutated
462                         h))
463                   (else #f)))))
464    (and-let* ((h (get-handle)))
465      (set-statement-handle! s h)
466      s)))
467
468(define (prepare db sqlst)
469  (resurrect (sql db sqlst)))
470
471;; Bypass cache when preparing statement.  Might occasionally be
472;; useful, but this call may also be removed.
473(define (prepare-transient db sqlst)
474  (resurrect (sql/transient db sqlst)))
475
476;; Returns #f on error, 'row on SQLITE_ROW, 'done on SQLITE_DONE.
477;; On error or busy, statement is reset.   Oddly, one of the benefits of
478;; resetting on error is a more descriptive error message; although
479;; step() returns result codes directly with prepare_v2(), it still
480;; takes a reset to convert "constraint failed" into "column key is
481;; not unique".
482;; We do unconditionally reset on BUSY, after any
483;; retries).  If we don't, we see weird behavior.  For example,
484;; first obtain a read lock with a SELECT step, then step an
485;; INSERT to get a BUSY; if the INSERT is not then reset, stepping
486;; a different INSERT may "succeed", but not write
487;; any data.  I assume that is an undetected MISUSE condition.
488;; NB It should not be necessary to reset between calls to busy handler.
489(define (step stmt)
490  (let ((db (statement-db stmt))
491        (sptr (nonnull-statement-ptr stmt))
492        (step/safe (if (statement-safe-step? stmt)
493                       sqlite3_step_safe
494                       sqlite3_step)))
495    (let retry ((times 0))
496      (reset-busy! db)
497      (let ((rv (step/safe sptr)))
498        (cond ((= rv status/row)
499               (set-statement-running! stmt)
500               'row)
501              ((= rv status/done)
502               (set-statement-done! stmt)
503               'done)
504              ;; sqlite3_step handles SCHEMA error itself.
505              ((= rv status/busy)
506               ;; "SQLITE_BUSY can only occur before fetching the first row." --drh
507               ;; Therefore, it is safe to reset on busy.
508               (set-statement-running! stmt)
509               (let ((bh (db-busy-handler db)))
510                 (if (and bh
511                          (retry-busy? db)
512                          (bh db times))
513                     (retry (+ times 1))
514                     (begin
515                       (reset-unconditionally stmt)
516                       (database-error db rv 'step stmt)))))
517              (else
518               (reset-unconditionally stmt)
519               (database-error db rv 'step stmt)))))))
520
521;; Finalize a statement.  Finalizing a finalized statement or a
522;; cached statement is a no-op.  Finalizing a statement on a closed
523;; DB is also a no-op; it is explicitly checked for here [*],
524;; although normally the cache prevents this issue.  All statements
525;; are automatically finalized when the database is closed, and cached
526;; statements are finalized as they expire, so it is rarely necessary
527;; to call this.
528(define (finalize stmt)
529  (or (statement-cached? stmt)
530      (finalize-transient stmt)))
531;; Finalize a statement now, regardless of its cached status.  The
532;; statement is not removed from the cache.  Finalization is indicated
533;; by #f in the statement-handle pointer slot.
534(define (finalize-transient stmt)     ; internal
535  (or (not (statement-ptr stmt))
536      (not (db-ptr (statement-db stmt))) ; [*]
537      (let ((rv (sqlite3_finalize
538                 (nonnull-statement-ptr stmt)))) ; checks db here
539        (set-statement-ptr! stmt #f)
540        (cond ((= rv status/abort)
541               (database-error
542                (statement-db stmt) rv 'finalize))
543              (else #t)))))
544
545;; Resets statement STMT.  Returns: STMT.
546;; sqlite3_reset only returns an error if the statement experienced
547;; an error, for compatibility with sqlite3_prepare.  We get the
548;; error from sqlite3_step, so ignore any error here.
549(define (reset stmt)
550  (when (not (statement-reset? stmt))
551    (reset-unconditionally stmt))
552  stmt)
553(define (reset-unconditionally stmt)
554  (sqlite3_reset (nonnull-statement-ptr stmt))
555  (set-statement-reset! stmt)
556  ;; Invalidate the column name cache, as schema can now change, and
557  ;; we have no other way to detect such.  Another option is to invalidate
558  ;; when (step) changes state to running.
559  (set-statement-column-names! stmt #f)
560  stmt)
561
562;; Bind all params in order to stmt, allowing keyword arguments.
563;; Although we take care to give consistent results when mixing named,
564;; numeric and anonymous arguments in the same statement, actually doing
565;; so is not recommended.
566(define (bind-parameters stmt . params)
567  (let ((count (bind-parameter-count stmt)))
568    (let loop ((i 1) (p params) (kw #f))
569      (if kw
570          (cond ((null? p)
571                 (error 'bind-parameters "keyword missing value" kw))
572                ((bind stmt (string-append ":" (keyword->string kw))
573                       (car p))
574                 (loop (+ i 1) (cdr p) #f))
575                (else #f))
576          (cond ((null? p)
577                 (unless (= (- i 1) count)
578                   ;; # of args unknown until entire params list is traversed, due to keywords.
579                   (error 'bind-parameters "wrong number of parameters, expected" count))
580                 stmt)
581                ((keyword? (car p))
582                 (loop i (cdr p) (car p)))
583                ((bind stmt i (car p))
584                 (loop (+ i 1) (cdr p) #f))
585                (else #f))))))
586
587;; Bind parameter at index I of statement S to value X.  The variable
588;; I may be an integer (the first parameter is 1, not 0) or a string
589;; for a named parameter -- for example, "$key", ":key" or "@key".
590;; A reference to an invalid index will throw an exception.
591(define (bind s i x)
592  (if (string? i)
593      (%bind-named s i x)
594      (%bind-int s i x)))
595
596(define (%bind-named s n x)
597  (##sys#check-string n 'bind-named)
598  (let ((i (sqlite3_bind_parameter_index (nonnull-statement-ptr s) n)))
599    (if (= i 0)
600        (error 'bind-named "no such parameter name" n s)
601        (%bind-int s i x))))
602
603(define (%bind-int stmt i x)
604  (when (or (< i 1)
605            (> i (bind-parameter-count stmt)))
606    ;; Should we test for this (and treat as error)?
607    ;; SQLite will catch this and return a range error.
608    ;; An indexing error should arguably be an immediate error...
609    (error 'bind "index out of range" i))
610  (let ((ptr (nonnull-statement-ptr stmt)))
611    (let ((rv 
612           (cond ((string? x)
613                  (sqlite3_bind_text ptr i x (string-length x)
614                                     destructor-type/transient))
615                 ((number? x)
616                  (if (exact? x)
617                      (sqlite3_bind_int64 ptr i x)    ;; Required for 64-bit.  Only int needed on 32 bit.
618                      (sqlite3_bind_double ptr i x)))
619                 ((blob? x)
620                  (sqlite3_bind_blob ptr i x (blob-size x)
621                                     destructor-type/transient))
622                 ((null? x)
623                  (sqlite3_bind_null ptr i))
624                 (else
625                  (error 'bind "invalid argument type" x)))))
626      (cond ((= rv status/ok) stmt)
627            (else (database-error (statement-db stmt) rv 'bind))))))
628
629(define bind-parameter-count statement-parameter-count)
630(define (bind-parameter-name s i)
631  ;; FIXME: possibly do domain check on index.  I believe we have to check against bind-parameter-count
632  (sqlite3_bind_parameter_name (nonnull-statement-ptr s)
633                               i))
634
635(define (change-count db)
636  (sqlite3_changes (nonnull-db-ptr db)))
637(define (total-change-count db)
638  (sqlite3_total_changes (nonnull-db-ptr db)))
639(define (last-insert-rowid db)
640  (sqlite3_last_insert_rowid (nonnull-db-ptr db)))
641(define (column-count stmt)
642  (sqlite3_column_count (nonnull-statement-ptr stmt)))
643(define (column-names stmt)
644  (let loop ((i 0) (L '()))
645    (let ((c (column-count stmt)))
646      (if (>= i c)
647          (reverse L)
648          (loop (+ i 1) (cons (column-name stmt i) L))))))
649(define (column-name stmt i)    ;; Get result set column names, lazily.
650  (let ((v (statement-column-names stmt)))
651    (if v
652        (or (vector-ref v i)
653            (let ((name (string->symbol
654                         (sqlite3_column_name (nonnull-statement-ptr stmt) i))))
655              (vector-set! v i name)
656              name))
657        (let ((name (string->symbol
658                     (sqlite3_column_name (nonnull-statement-ptr stmt) i))))
659          (when (statement-running? stmt)  ;; Or, invalidate column names in (step) when switching to running.
660            (let ((v (make-vector (column-count stmt) #f)))
661              (vector-set! v i name)
662              (set-statement-column-names! stmt v)))
663          name))))
664(define (column-type stmt i)
665  ;; can't be cached, only valid for current row
666  (int->type (sqlite3_column_type (nonnull-statement-ptr stmt) i)))
667(define (column-data stmt i)
668  (let* ((stmt-ptr (nonnull-statement-ptr stmt))
669         (t (sqlite3_column_type stmt-ptr i)))  ; faster than column-type
670    ;; INTEGER type may reach 64 bits; return at least 53 significant.     
671    (cond ((= t type/integer) (sqlite3_column_int64 stmt-ptr i))
672          ((= t type/float)   (sqlite3_column_double stmt-ptr i))
673          ((= t type/text)    (sqlite3_column_text stmt-ptr i)) ; NULs OK??
674          ((= t type/null)    '())
675          ((= t type/blob)
676           (let ((b (make-blob (sqlite3_column_bytes stmt-ptr i)))
677                 (%copy! (foreign-lambda c-pointer "C_memcpy"
678                                         scheme-pointer c-pointer int)))
679             ;; NB: "return value of sqlite3_column_blob() for a zero-length BLOB is a NULL pointer."
680             (%copy! b (sqlite3_column_blob stmt-ptr i) (blob-size b))
681             b))
682          (else
683           (error 'column-data "illegal type"))))) ; assertion
684
685;; Retrieve all columns from current row.  Does not coerce DONE
686;; to '(); instead returns NULL for all columns.
687(define (row-data stmt)
688  (let ((ncol (column-count stmt)))
689    (let loop ((i 0))
690      (if (fx>= i ncol)
691          '()
692          (cons (column-data stmt i)
693                (loop (fx+ i 1)))))))
694
695(define (row-alist stmt)
696  (let ((ncol (column-count stmt)))
697    (let loop ((i 0))
698      (if (fx>= i ncol)
699          '()
700          (cons (cons (column-name stmt i)
701                      (column-data stmt i))
702                (loop (fx+ i 1)))))))
703
704;; Add? row-vector
705
706;; Step statement and return row data. Returns #f (or error) on failure,
707;; '() on done, '(col1 col2 ...) on success.
708(define (fetch s)
709  (and-let* ((rv (step s)))
710    (case rv
711      ((done) '())
712      ((row) (row-data s))
713      (else
714       (error 'fetch "internal error: step result invalid" rv)))))
715(define fetch-row fetch)
716
717;; Same as fetch, but returns an alist: '((name1 . col1) ...)
718(define (fetch-alist s)               ; nearly identical to (fetch)
719  (and-let* ((rv (step s)))
720    (case rv
721      ((done) '())
722      ((row) (row-alist s))
723      (else
724       (error 'fetch-alist "internal error: step result invalid" rv)))))
725
726;; Fetch first column of first row, or #f if no data.
727(define (fetch-value s)
728  (and-let* ((rv (step s)))
729    (case rv
730      ((done) #f)
731      ((row)
732       (column-data s 0)
733       ;; I believe a row with no columns can never be returned; the
734       ;; above will throw an error if so.  Or we could handle it gracefully:
735       ;; (and (> 0 (column-count s)) (column-data s 0))
736       )
737      (else
738       (error 'fetch-value "internal error: step result invalid" rv)))))
739
740;; Fetch remaining rows into a list.
741(define (fetch-all s)
742  (let loop ((L '()))
743    (let ((row (fetch s)))
744      (cond ((null? row)
745             (reverse L))
746            (row
747             (loop (cons row L)))
748            (else
749             ;; Semantics are odd if exception raising is disabled.
750             (error 'fetch-all "fetch failed" s))))))
751(define fetch-rows fetch-all)
752
753;; Lots of duplicated code here.
754(define (fetch-column s)           ;; Should this be called fetch-values?  "values" may imply MV, but is more consistent.
755  (let loop ((L '()))
756    (let ((val (fetch-value s)))
757      (cond (val
758             (loop (cons val L)))
759            (else (reverse L))))))
760(define (fetch-alists s)
761  (let loop ((L '()))
762    (let ((row (fetch-alist s)))
763      (cond ((null? row)
764             (reverse L))
765            (else
766             (loop (cons row L)))))))
767
768;; Add? vector retrieval via row-vector.
769
770;;   (define (step-through stmt)
771;;     (let loop ()
772;;       (case (step stmt)
773;;         ((row)  (loop))
774;;         ((done) 'done)                  ; stmt?
775;;         (else #f))))
776
777;;; Database
778
779;; If errors are off, user can't retrieve error message as we
780;; return #f instead of db; though it's probably SQLITE_CANTOPEN.
781;; Perhaps this should always throw an error.
782;; NULL (#f) filename allowed, creates private on-disk database,
783;; same as "".
784;; Allows symbols 'memory => ":memory:" and 'temp or 'temporary => ""
785;; as filename.
786(define (open-database filename)
787  (let ((filename
788         (if (string? filename)
789             (##sys#expand-home-path filename)
790             (case filename
791               ((memory) ":memory:")
792               ((temp temporary) "")
793               (else (error 'open-database "unrecognized database type"
794                            filename))))))
795    (let-location ((db-ptr (c-pointer "sqlite3")))
796      (let* ((rv (sqlite3_open (##sys#expand-home-path filename)
797                               (location db-ptr))))
798        (if (eqv? rv status/ok)
799            (make-db db-ptr
800                     filename
801                     #f                       ; busy-handler
802                     (object-evict (vector #f)) ; invoked-busy?
803                     #f                       ; safe-step?
804                     (make-lru-cache (prepared-cache-size)
805                                     string=?
806                                     (lambda (sql stmt)
807                                       (finalize-transient stmt))))
808            (if db-ptr
809                (database-error (make-db db-ptr filename #f #f #f #f) rv
810                                'open-database filename)
811                (error 'open-database "internal error: out of memory")))))))
812
813(define (close-database db)
814  (let ((db-ptr (nonnull-db-ptr db)))
815    (lru-cache-flush! (db-statement-cache db))
816    ;; It's not safe to finalize all open statements, because SQLite itself
817    ;; may prepare statements under the hood (e.g. with FTS) and a double
818    ;; finalize is fatal.  Therefore we have removed this protective measure.
819    #;
820    (do ((stmt (sqlite3_next_stmt db-ptr #f) ; finalize pending statements
821               (sqlite3_next_stmt db-ptr stmt)))
822        ((not stmt))
823      (warning (sprintf "finalizing pending statement: ~S"
824                        (sqlite3_sql stmt)))
825      (sqlite3_finalize stmt))
826    (cond ((eqv? status/ok (sqlite3_close db-ptr))
827           (set-db-ptr! db #f)
828           (object-release (db-invoked-busy-handler? db))
829           (set-db-invoked-busy-handler?! db 'database-closed)
830           #t)
831          (else #f))))
832
833(define (database-closed? db)
834  (not (db-ptr db)))
835
836(define (call-with-database filename proc)
837  (let ((db (open-database filename)))
838    (let ((c (current-exception-handler)))
839      (begin0
840          (with-exception-handler
841           (lambda (ex)
842             ;; Failing to close the db will leak resources, but it's not clear
843             ;; what we can do other than warn and throw original exception.
844             (or (close-database db)
845                 (warning "leaked open database handle" db))
846             (c ex))
847           (lambda () (proc db)))
848        (or (close-database db)
849            (warning "leaked open database handle" db))))))
850
851(define (error-code db)
852  (int->status (sqlite3_errcode (nonnull-db-ptr db))))
853(define (error-message db)
854  (sqlite3_errmsg (nonnull-db-ptr db)))
855(define (database-error db code where . args)
856  (and (raise-database-errors)
857       (apply raise-database-error db code where args)))
858(define (raise-database-error db code where . args)
859  ;; status/misuse may not set the error code and message; signal
860  ;; a generic misuse error if we believe that has happened.
861  ;; [ref. http://www.sqlite.org/c3ref/errcode.html]
862  (if (or (not (= code status/misuse))
863          (eqv? (error-code db) 'misuse))
864      (raise-database-error/status
865       db (int->status code) where (error-message db) args)
866      (raise-database-error/status
867       db 'misuse where "misuse of interface" args)))
868(define (raise-database-error/status db status where message args)
869  (abort
870   (make-composite-condition
871    (make-property-condition 'exn
872                             'location where
873                             'message message
874                             'arguments args)
875    (make-property-condition 'sqlite
876                             'status status
877                             'message message))))
878(define sqlite-exception? (condition-predicate 'sqlite))
879;; note that these will return #f if you pass it a non-sqlite condition
880(define sqlite-exception-status (condition-property-accessor 'sqlite 'status))
881(define sqlite-exception-message (condition-property-accessor 'sqlite 'message))
882
883;;; Transactions
884
885;; Escaping or re-entering the dynamic extent of THUNK will not
886;; affect the in-progress transaction.  However, if an exception
887;; occurs, or THUNK returns #f, the transaction will be rolled back.
888;; A rollback failure is a critical error and you should likely abort.
889(define with-transaction
890  (let ((tsqls '((deferred . "begin deferred;")
891                 (immediate . "begin immediate;")
892                 (exclusive . "begin exclusive;"))))
893    (lambda (db thunk #!optional (type 'deferred))
894      (and (exec (sql db (or (alist-ref type tsqls)
895                             (error 'with-transaction
896                                    "invalid transaction type" type))))
897           (let ((rv 
898                  (handle-exceptions ex (begin (or (rollback db)
899                                                   (error 'with-transaction
900                                                          "rollback failed"))
901                                               (abort ex))
902                    (let ((rv (thunk))) ; only 1 return value allowed
903                      (and rv
904                           (commit db)  ; maybe warn on #f
905                           rv)))))
906             (or rv
907                 (if (rollback db)
908                     #f
909                     (error 'with-transaction "rollback failed"))))))))
910
911(define with-deferred-transaction with-transaction) ; convenience fxns
912(define (with-immediate-transaction db thunk)
913  (with-transaction db thunk 'immediate))
914(define (with-exclusive-transaction db thunk)
915  (with-transaction db thunk 'exclusive))
916
917(define (autocommit? db)
918  (sqlite3_get_autocommit (nonnull-db-ptr db)))
919
920;; Rollback current transaction.  Reset running queries before doing
921;; so, as rollback would fail if read or read/write queries are
922;; running.  Rolling back when no transaction is active returns #t.
923(define (rollback db)
924  (cond ((autocommit? db) #t)
925        (else
926         (reset-running-queries! db)
927         (exec (sql db "rollback;")))))
928;; Commit current transaction.  This does not roll back running queries,
929;; because running read queries are acceptable, and the behavior in the
930;; presence of pending write statements is unclear.  If the commit
931;; fails, you can always rollback, which will reset the pending queries.
932(define (commit db)
933  (cond ((autocommit? db) #t)
934        (else
935         ;; (reset-running-queries! db)
936         (exec (sql db "commit;")))))
937;; Reset all running queries.  A list of all prepared statements known
938;; to the library is obtained; if a statement is found in the cache,
939;; we call (reset) on it.  If it is not, it is a transient statement,
940;; which we do not track; forcibly reset it as its run state is unknown.
941;; Statements that fall off the cache have been finalized and are
942;; consequently not known to the library.
943(define (reset-running-queries! db)
944  (let ((db-ptr (nonnull-db-ptr db))
945        (c (db-statement-cache db)))
946    (do ((sptr (sqlite3_next_stmt db-ptr #f)
947               (sqlite3_next_stmt db-ptr sptr)))
948        ((not sptr))
949      (let* ((sql (sqlite3_sql sptr))
950             (s (lru-cache-ref c sql)))
951        (if (and s
952                 (pointer=? (statement-ptr s) sptr))
953            (reset-unconditionally s)   ; in case our state is out of sync
954            (begin
955              (fprintf
956               (current-error-port)
957               "Warning: resetting transient prepared statement: ~S\n" sql)
958              (sqlite3_reset sptr)))))))
959
960;;; Busy handling
961
962;; Busy handling is done entirely in the application, as with SRFI-18
963;; threads it is not legal to yield within a callback.  The backoff
964;; algorithm of sqlite3_busy_timeout is reimplemented.
965
966;; SQLite can deadlock in certain situations and to avoid this will
967;; return SQLITE_BUSY immediately rather than invoking the busy handler.
968;; However if there is no busy handler, we cannot tell a retryable
969;; SQLITE_BUSY from a deadlock one.  To gain deadlock protection we
970;; register a simple busy handler which sets a flag indicating this
971;; BUSY is retryable.  This handler writes the flag into an evicted
972;; object in static memory so it need not call back into Scheme nor
973;; require safe-lambda for all calls into SQLite (a performance killer!)
974
975(define (retry-busy? db)
976  (vector-ref (db-invoked-busy-handler? db) 0))
977(define (reset-busy! db)
978  (vector-set! (db-invoked-busy-handler? db) 0 #f))
979(define (set-busy-handler! db proc)
980  (let ((dbptr (nonnull-db-ptr db)))
981    (set-db-busy-handler! db proc)
982    (if proc
983        (sqlite3_busy_handler dbptr
984                              (foreign-value "busy_notification_handler"
985                                             c-pointer)
986                              (object->pointer
987                               (db-invoked-busy-handler? db)))
988        (sqlite3_busy_handler dbptr #f #f))
989    (void)))
990(define (thread-sleep!/ms ms)
991  (thread-sleep! (/ ms 1000)))
992;; (busy-timeout ms) returns a procedure suitable for use in
993;; set-busy-handler!, implementing a spinning busy timeout using the
994;; SQLite3 busy algorithm.  Other threads may be scheduled while
995;; this one is busy-waiting.
996;;   FIXME: socket egg has updated algorithm which respects actual
997;;          elapsed time, not estimated time
998(define busy-timeout
999  (let* ((delays '#(1 2 5 10 15 20 25 25  25  50  50 100))
1000         (totals '#(0 1 3  8 18 33 53 78 103 128 178 228))
1001         (ndelay (vector-length delays)))
1002    (lambda (ms)
1003      (cond
1004       ((< ms 0) (error 'busy-timeout "timeout must be non-negative" ms))
1005       ((= ms 0) #f)
1006       (else
1007        (lambda (db count)
1008          (let* ((delay (vector-ref delays (min count (- ndelay 1))))
1009                 (prior (if (< count ndelay)
1010                            (vector-ref totals count)
1011                            (+ (vector-ref totals (- ndelay 1))
1012                               (* delay (- count (- ndelay 1)))))))
1013            (let ((delay (if (> (+ prior delay) ms)
1014                             (- ms prior)
1015                             delay)))
1016              (cond ((<= delay 0) #f)
1017                    (else
1018                     (thread-sleep!/ms delay)
1019                     #t))))))))))
1020
1021;;; User-defined functions
1022
1023(define make-gc-root           ;; Create non-finalizable GC root pointing to OBJ
1024  (foreign-lambda* c-pointer ((scheme-object obj))
1025    "void *root = CHICKEN_new_gc_root();"
1026    "CHICKEN_gc_root_set(root, obj);"
1027    "return(root);"))
1028(define gc-root-ref
1029  (foreign-lambda scheme-object CHICKEN_gc_root_ref c-pointer))
1030;; (define free-gc-root
1031;;   (foreign-lambda void CHICKEN_delete_gc_root c-pointer))
1032
1033(define-inline (%callback-result ctx x)
1034  (cond ((string? x)
1035         (sqlite3_result_text ctx x (string-length x) ;; Possible FIXME: Unnecessary extra copy of x
1036                              destructor-type/transient))
1037        ((number? x)
1038         (if (exact? x)
1039             (sqlite3_result_int64 ctx x) ;; Required for 64-bit.  Only int needed on 32 bit.
1040             (sqlite3_result_double ctx x)))
1041        ((blob? x)
1042         (sqlite3_result_blob ctx x (blob-size x)
1043                              destructor-type/transient))
1044        ((null? x)
1045         (sqlite3_result_null ctx))
1046        ;; zeroblob is not supported
1047        (else
1048         (error 'callback "invalid result type" x))))
1049
1050(define %copy! (foreign-lambda c-pointer "C_memcpy"
1051                               scheme-pointer c-pointer int))
1052(define %value-at (foreign-lambda* c-pointer (((c-pointer "sqlite3_value*") vals)
1053                                              (int i))
1054                    "return(vals[i]);"))
1055
1056(define-inline %value-data
1057  (lambda (vals i)
1058    (let* ((v (%value-at vals i))
1059           (t (sqlite3_value_type v)))
1060      ;; INTEGER type may reach 64 bits; return at least 53 significant.     
1061      (cond ((= t type/integer) (sqlite3_value_int64 v))
1062            ((= t type/float)   (sqlite3_value_double v))
1063            ;; Just as in column-data we choose to disallow embedded NULs in text columns;
1064            ;; the database allows it but it may cause problems with internal functions.
1065            ;; This behavior could be changed if it becomes a problem.
1066            ((= t type/text)    (sqlite3_value_text v))
1067            ((= t type/null)    '())
1068            ((= t type/blob)
1069             ;; NB: "return value of sqlite3_column_blob() for a zero-length BLOB is a NULL pointer."
1070             (let ((b (make-blob (sqlite3_value_bytes v))))
1071               (%copy! b (sqlite3_value_blob v) (blob-size b))
1072               b))
1073            (else
1074             (error 'value-data "illegal type at index" i)))))) ; assertion
1075
1076(define (parameter-data vals n)
1077  (let loop ((i (fx- n 1)) (L '()))
1078    (if (< i 0)
1079        L
1080        (loop (fx- i 1) (cons (%value-data vals i) L)))))
1081
1082;;;; Scalars
1083
1084;; WARNING: C_disable_interrupts is run AFTER 1 C_check_for_interrupt already occurs,
1085;; upon entry.
1086
1087(define-record scalar-data db name proc)
1088
1089(define-external (scalar_callback (c-pointer ctx) (int nvals) (c-pointer vals))
1090  void
1091  (##core#inline "C_disable_interrupts")
1092  (handle-exceptions exn
1093      (sqlite3_result_error ctx ;; (or ((condition-property-accessor 'exn 'message) exn)
1094                                ;;     "Unknown Scheme error")
1095                            ;; Recommended to include exn location and objects, but may be dangerous.  FIXME.
1096                            (sprintf "(~a) ~a: ~s"
1097                                     ((condition-property-accessor 'exn 'location) exn)
1098                                     ((condition-property-accessor 'exn 'message) exn)
1099                                     ((condition-property-accessor 'exn 'arguments) exn))
1100                            -1)
1101    (let ((data (gc-root-ref (sqlite3_user_data ctx))))
1102      (let ((proc (scalar-data-proc data)))
1103        (%callback-result ctx (apply proc (parameter-data vals nvals))))))
1104  (##core#inline "C_enable_interrupts"))
1105
1106(define (register-scalar-function! db name nargs proc)
1107  (flush-cache! db)
1108  (set-db-safe-step! db #t)
1109  (cond ((not proc)
1110         (unregister-function! db name nargs))
1111        (else
1112         (##sys#check-string name 'register-scalar-function!)
1113         (##sys#check-exact nargs 'register-scalar-function!)
1114         (##sys#check-closure proc 'register-scalar-function!)
1115         (let ((dbptr (nonnull-db-ptr db))     ;; check type now before creating gc root
1116               (data (make-gc-root (make-scalar-data
1117                                    db name proc))))  ;; Note that DB and NAME are not currently used.
1118           (sqlite3_create_function_v2 dbptr name nargs
1119                                       (foreign-value "SQLITE_UTF8" int)
1120                                       data
1121                                       (foreign-value "scalar_callback" c-pointer)
1122                                       #f
1123                                       #f
1124                                       (foreign-value "CHICKEN_delete_gc_root" c-pointer))))))
1125
1126;;;; Aggregates
1127
1128(define-record aggregate-data db name pstep pfinal seed)
1129
1130(define-external (aggregate_step_callback (c-pointer ctx) (int nvals) (c-pointer vals))
1131  void
1132  (##core#inline "C_disable_interrupts")
1133  (handle-exceptions exn
1134      (sqlite3_result_error ctx
1135                            ;; Recommended to include exn location and objects, but may be dangerous.  FIXME.
1136                            (sprintf "(~a) ~a: ~s"
1137                                     ((condition-property-accessor 'exn 'location) exn)
1138                                     ((condition-property-accessor 'exn 'message) exn)
1139                                     ((condition-property-accessor 'exn 'arguments) exn))
1140                            -1)
1141    (let ((data (gc-root-ref (sqlite3_user_data ctx))))
1142      (let ((seed-box 
1143             ((foreign-lambda* scheme-object ((c-pointer ctx) (scheme-object v))
1144                "void **p = (void **)sqlite3_aggregate_context(ctx, sizeof(void *));"
1145                "if (*p == 0) { *p = CHICKEN_new_gc_root(); CHICKEN_gc_root_set(*p, v); return(v); }"
1146                "else { return(CHICKEN_gc_root_ref(*p)); }")
1147              ;; vector may not even be used, but callbacks are extremely slow anyway.
1148              ;; we could alloc in C instead.  pair better?
1149              ctx (vector (aggregate-data-seed data)))))
1150        (let ((new-seed
1151               (apply (aggregate-data-pstep data)
1152                      (vector-ref seed-box 0)
1153                      (parameter-data vals nvals))))
1154          (vector-set! seed-box 0 new-seed)))))
1155  (##core#inline "C_enable_interrupts"))
1156
1157(define-external (aggregate_final_callback (c-pointer ctx))
1158  void
1159  (##core#inline "C_disable_interrupts")
1160  (handle-exceptions exn
1161      (sqlite3_result_error ctx
1162                            ;; Recommended to include exn location and objects, but may be dangerous.  FIXME.
1163                            (sprintf "(~a) ~a: ~s"
1164                                     ((condition-property-accessor 'exn 'location) exn)
1165                                     ((condition-property-accessor 'exn 'message) exn)
1166                                     ((condition-property-accessor 'exn 'arguments) exn))
1167                            -1)
1168    (let ((data (gc-root-ref (sqlite3_user_data ctx))))
1169      (let ((seed-box
1170             ((foreign-lambda* scheme-object ((c-pointer ctx))
1171                "void **p = (void **)sqlite3_aggregate_context(ctx, sizeof(void *));"
1172                "C_word r;"
1173                "if (*p == 0) return(C_SCHEME_FALSE);"
1174                "r = CHICKEN_gc_root_ref(*p);"
1175                "CHICKEN_delete_gc_root(*p);" ;; This is probably illegal
1176                "return(r);")
1177              ctx)))
1178        (let ((pfinal (aggregate-data-pfinal data))
1179              (seed (if seed-box
1180                        (vector-ref seed-box 0)
1181                        (aggregate-data-seed data))))
1182          (%callback-result ctx (pfinal seed))))))
1183  (##core#inline "C_enable_interrupts"))
1184
1185(define (register-aggregate-function! db name nargs pstep #!optional (seed 0) (pfinal (lambda (x) x)))
1186  ;; Flush cache unconditionally because existing statements may not be reprepared automatically
1187  ;; when nargs==-1, due to SQLite bug.  This ensures idle cached statements see the update.
1188  (flush-cache! db)   ;; Maybe we can limit this to nargs==-1 case?
1189  (set-db-safe-step! db #t)
1190  (cond ((not pstep)
1191         (unregister-function! db name nargs))
1192        (else
1193         (##sys#check-string name 'register-aggregate-function!)
1194         (##sys#check-exact nargs 'register-aggregate-function!)
1195         (##sys#check-closure pstep 'register-aggregate-function!)
1196         (##sys#check-closure pfinal 'register-aggregate-function!)
1197         (let* ((dbptr (nonnull-db-ptr db))   ;; check type now before creating gc root
1198                (data (make-gc-root (make-aggregate-data
1199                                     db name pstep pfinal seed))))  ;; Note that DB and NAME are not currently used.
1200           (let ((rv (sqlite3_create_function_v2 dbptr name nargs
1201                                                 (foreign-value "SQLITE_UTF8" int)
1202                                                 data
1203                                                 #f
1204                                                 (foreign-value "aggregate_step_callback" c-pointer)
1205                                                 (foreign-value "aggregate_final_callback" c-pointer)
1206                                                 (foreign-value "CHICKEN_delete_gc_root" c-pointer))))
1207             (if (= status/ok rv)
1208                 (void)
1209                 (database-error db rv 'register-aggregate-function!)))))))
1210
1211(define (unregister-function! db name nargs)
1212  (let ((rv (sqlite3_create_function_v2 (nonnull-db-ptr db)
1213                                        name
1214                                        nargs
1215                                        (foreign-value "SQLITE_UTF8" int)
1216                                        #f #f #f #f #f)))
1217    (if (= status/ok rv)
1218        (void)
1219        (database-error db rv 'unregister-function!))))
1220
1221
1222  )  ; module
1223
1224;; Copyright (c) 2009-2012 Jim Ursetto.  All rights reserved.
1225;;
1226;; Redistribution and use in source and binary forms, with or without
1227;; modification, are permitted provided that the following conditions are met:
1228;;
1229;;  Redistributions of source code must retain the above copyright notice,
1230;;   this list of conditions and the following disclaimer.
1231;;  Redistributions in binary form must reproduce the above copyright notice,
1232;;   this list of conditions and the following disclaimer in the documentation
1233;;   and/or other materials provided with the distribution.
1234;;  Neither the name of the author nor the names of its contributors
1235;;   may be used to endorse or promote products derived from this software
1236;;   without specific prior written permission.
1237;;
1238;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
1239;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
1240;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
1241;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
1242;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
1243;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
1244;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
1245;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
1246;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
1247;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
1248;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Note: See TracBrowser for help on using the repository browser.