sqlite3.scm.in 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653
  1. ;; Guile-SQLite3
  2. ;; Copyright (C) 2010, 2014 Andy Wingo <wingo at pobox dot com>
  3. ;; Copyright (C) 2018 Ludovic Courtès <ludo@gnu.org>
  4. ;; This library is free software; you can redistribute it and/or modify
  5. ;; it under the terms of the GNU Lesser General Public License as
  6. ;; published by the Free Software Foundation; either version 3 of the
  7. ;; License, or (at your option) any later version.
  8. ;;
  9. ;; This library is distributed in the hope that it will be useful, but
  10. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;; Lesser General Public License for more details.
  13. ;;
  14. ;; You should have received a copy of the GNU Lesser General Public
  15. ;; License along with this program; if not, contact:
  16. ;;
  17. ;; Free Software Foundation Voice: +1-617-542-5942
  18. ;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
  19. ;; Boston, MA 02111-1307, USA gnu@gnu.org
  20. ;;; Commentary:
  21. ;;
  22. ;; A Guile binding for sqlite.
  23. ;;
  24. ;;; Code:
  25. (define-module (sqlite3)
  26. #:use-module (system foreign)
  27. #:use-module (rnrs bytevectors)
  28. #:use-module (ice-9 match)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (srfi srfi-9)
  31. #:use-module (srfi srfi-19)
  32. #:export (sqlite-open
  33. sqlite-db?
  34. sqlite-close
  35. sqlite-enable-load-extension
  36. sqlite-exec
  37. sqlite-prepare
  38. sqlite-bind
  39. sqlite-bind-arguments
  40. sqlite-column-names
  41. sqlite-step
  42. sqlite-fold
  43. sqlite-fold-right
  44. sqlite-map
  45. sqlite-reset
  46. sqlite-finalize
  47. sqlite-bind-parameter-index
  48. sqlite-busy-timeout
  49. sqlite-expanded-sql
  50. sqlite-trace
  51. SQLITE_OPEN_READONLY
  52. SQLITE_OPEN_READWRITE
  53. SQLITE_OPEN_CREATE
  54. SQLITE_OPEN_DELETEONCLOSE
  55. SQLITE_OPEN_EXCLUSIVE
  56. SQLITE_OPEN_MAIN_DB
  57. SQLITE_OPEN_TEMP_DB
  58. SQLITE_OPEN_TRANSIENT_DB
  59. SQLITE_OPEN_MAIN_JOURNAL
  60. SQLITE_OPEN_TEMP_JOURNAL
  61. SQLITE_OPEN_SUBJOURNAL
  62. SQLITE_OPEN_MASTER_JOURNAL
  63. SQLITE_OPEN_NOMUTEX
  64. SQLITE_OPEN_FULLMUTEX
  65. SQLITE_OPEN_SHAREDCACHE
  66. SQLITE_OPEN_PRIVATECACHE
  67. SQLITE_OPEN_URI
  68. SQLITE_TRACE_STMT
  69. SQLITE_TRACE_PROFILE
  70. SQLITE_TRACE_ROW
  71. SQLITE_TRACE_CLOSE
  72. SQLITE_CONSTRAINT
  73. SQLITE_CONSTRAINT_PRIMARYKEY
  74. SQLITE_CONSTRAINT_UNIQUE))
  75. ;;
  76. ;; Utils
  77. ;;
  78. (define (string->utf8-pointer s)
  79. (string->pointer s "utf-8"))
  80. (define (utf8-pointer->string p)
  81. (pointer->string p -1 "utf-8"))
  82. ;;
  83. ;; Constants
  84. ;;
  85. ;; FIXME: snarf using compiler. These are just copied from the header...
  86. ;;
  87. (define SQLITE_OPEN_READONLY #x00000001) ;; Ok for sqlite3_open_v2()
  88. (define SQLITE_OPEN_READWRITE #x00000002) ;; Ok for sqlite3_open_v2()
  89. (define SQLITE_OPEN_CREATE #x00000004) ;; Ok for sqlite3_open_v2()
  90. (define SQLITE_OPEN_DELETEONCLOSE #x00000008) ;; VFS only
  91. (define SQLITE_OPEN_EXCLUSIVE #x00000010) ;; VFS only
  92. (define SQLITE_OPEN_MAIN_DB #x00000100) ;; VFS only
  93. (define SQLITE_OPEN_TEMP_DB #x00000200) ;; VFS only
  94. (define SQLITE_OPEN_TRANSIENT_DB #x00000400) ;; VFS only
  95. (define SQLITE_OPEN_MAIN_JOURNAL #x00000800) ;; VFS only
  96. (define SQLITE_OPEN_TEMP_JOURNAL #x00001000) ;; VFS only
  97. (define SQLITE_OPEN_SUBJOURNAL #x00002000) ;; VFS only
  98. (define SQLITE_OPEN_MASTER_JOURNAL #x00004000) ;; VFS only
  99. (define SQLITE_OPEN_NOMUTEX #x00008000) ;; Ok for sqlite3_open_v2()
  100. (define SQLITE_OPEN_FULLMUTEX #x00010000) ;; Ok for sqlite3_open_v2()
  101. (define SQLITE_OPEN_SHAREDCACHE #x00020000) ;; Ok for sqlite3_open_v2()
  102. (define SQLITE_OPEN_PRIVATECACHE #x00040000) ;; Ok for sqlite3_open_v2()
  103. (define SQLITE_OPEN_URI #x00000040) ;; Ok for sqlite3_open_v2()
  104. (define SQLITE_TRACE_STMT #x00000001)
  105. (define SQLITE_TRACE_PROFILE #x00000002)
  106. (define SQLITE_TRACE_ROW #x00000004)
  107. (define SQLITE_TRACE_CLOSE #x00000008)
  108. (define SQLITE_CONSTRAINT 19)
  109. (define SQLITE_CONSTRAINT_PRIMARYKEY
  110. (logior SQLITE_CONSTRAINT (ash 6 8)))
  111. (define SQLITE_CONSTRAINT_UNIQUE
  112. (logior SQLITE_CONSTRAINT (ash 8 8)))
  113. (define libsqlite3 (dynamic-link "@SQLITE_LIBDIR@/libsqlite3"))
  114. (define-record-type <sqlite-db>
  115. (make-db pointer open? stmts)
  116. db?
  117. (pointer db-pointer)
  118. (open? db-open? set-db-open?!)
  119. (stmts db-stmts))
  120. (define-syntax sqlite-db?
  121. (identifier-syntax db?))
  122. (define-record-type <sqlite-stmt>
  123. (make-stmt pointer live? reset? cached?)
  124. stmt?
  125. (pointer stmt-pointer)
  126. (live? stmt-live? set-stmt-live?!)
  127. (reset? stmt-reset? set-stmt-reset?!)
  128. (cached? stmt-cached? set-stmt-cached?!))
  129. (define sqlite-errmsg
  130. (let ((f (pointer->procedure
  131. '*
  132. (dynamic-func "sqlite3_errmsg" libsqlite3)
  133. (list '*))))
  134. (lambda (db)
  135. (utf8-pointer->string (f (db-pointer db))))))
  136. (define sqlite-errcode
  137. (let ((f (pointer->procedure
  138. int
  139. (dynamic-func "sqlite3_extended_errcode" libsqlite3)
  140. (list '*))))
  141. (lambda (db)
  142. (f (db-pointer db)))))
  143. (define* (sqlite-error db who #:optional code
  144. (errmsg (and db (sqlite-errmsg db))))
  145. (throw 'sqlite-error who code errmsg))
  146. (define* (check-error db #:optional who)
  147. (let ((code (sqlite-errcode db)))
  148. (if (not (zero? code))
  149. (sqlite-error db who code))))
  150. (define sqlite-close
  151. (let ((f (pointer->procedure
  152. int
  153. (dynamic-func "sqlite3_close" libsqlite3)
  154. (list '*))))
  155. (lambda (db)
  156. (when (db-open? db)
  157. ;; Finalize cached statements.
  158. (hash-for-each (lambda (sql stmt)
  159. (set-stmt-cached?! stmt #f)
  160. (sqlite-finalize stmt))
  161. (db-stmts db))
  162. (hash-clear! (db-stmts db))
  163. (let ((p (db-pointer db)))
  164. (set-db-open?! db #f)
  165. (f p))))))
  166. (define db-guardian (make-guardian))
  167. (define (pump-db-guardian)
  168. (let ((db (db-guardian)))
  169. (if db
  170. (begin
  171. (sqlite-close db)
  172. (pump-db-guardian)))))
  173. (add-hook! after-gc-hook pump-db-guardian)
  174. (define (static-errcode->errmsg code)
  175. (case code
  176. ((1) "SQL error or missing database")
  177. ((2) "Internal logic error in SQLite")
  178. ((3) "Access permission denied")
  179. ((5) "The database file is locked")
  180. ((6) "A table in the database is locked")
  181. ((7) "A malloc() failed")
  182. ((8) "Attempt to write a readonly database")
  183. ((10) "Some kind of disk I/O error occurred")
  184. ((11) "The database disk image is malformed")
  185. ((14) "Unable to open the database file")
  186. ((21) "Library used incorrectly")
  187. ((22) "Uses OS features not supported on host")
  188. ((23) "Authorization denied")
  189. ((24) "Auxiliary database format error")
  190. ((26) "File opened that is not a database file")
  191. (else "Unknown error")))
  192. (define sqlite-open
  193. (let ((f (pointer->procedure
  194. int
  195. (dynamic-func "sqlite3_open_v2" libsqlite3)
  196. (list '* '* int '*))))
  197. (lambda* (filename #:optional
  198. (flags (logior SQLITE_OPEN_READWRITE
  199. SQLITE_OPEN_CREATE
  200. SQLITE_OPEN_URI))
  201. (vfs #f))
  202. (let* ((out-db (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  203. (ret (f (string->utf8-pointer filename)
  204. out-db
  205. flags
  206. (if vfs (string->utf8-pointer vfs) %null-pointer))))
  207. (if (zero? ret)
  208. (let ((db (make-db (dereference-pointer out-db) #t
  209. (make-hash-table))))
  210. (db-guardian db)
  211. db)
  212. (sqlite-error #f 'sqlite-open ret (static-errcode->errmsg ret)))))))
  213. (define sqlite-enable-load-extension
  214. (let ((ele (pointer->procedure
  215. int
  216. (dynamic-func "sqlite3_enable_load_extension" libsqlite3)
  217. (list '* int))))
  218. (lambda (db onoff)
  219. (ele (db-pointer db) onoff))))
  220. (define sqlite-exec
  221. (let ((exec (pointer->procedure
  222. int
  223. (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))
  224. '(* * * * *))))
  225. (lambda* (db sql)
  226. "Evaluate the string SQL, which may contain one or several SQL
  227. statements, into DB. The result is unspecified."
  228. ;; XXX: 'sqlite3_exec' has a 'callback' parameter but we ignore it
  229. ;; here.
  230. (assert-live-db! db)
  231. (unless (zero? (exec (db-pointer db) (string->pointer sql)
  232. %null-pointer %null-pointer %null-pointer))
  233. (check-error db 'sqlite-exec)))))
  234. ;;;
  235. ;;; SQL statements
  236. ;;;
  237. (define sqlite-remove-statement!
  238. (lambda (db stmt)
  239. (when (stmt-cached? stmt)
  240. (let* ((stmts (db-stmts db))
  241. (key (catch 'value
  242. (lambda ()
  243. (hash-for-each (lambda (key value)
  244. (when (eq? value stmt)
  245. (throw 'value key)))
  246. stmts)
  247. #f)
  248. (lambda (_ key) key))))
  249. (hash-remove! stmts key)))))
  250. (define sqlite-finalize
  251. (let ((f (pointer->procedure
  252. int
  253. (dynamic-func "sqlite3_finalize" libsqlite3)
  254. (list '*))))
  255. (lambda (stmt)
  256. ;; Note: When STMT is cached, this merely resets. This ensures caching
  257. ;; actually works while still separating concerns: users can turn caching
  258. ;; on and off without having to change the rest of their code.
  259. (when (stmt-live? stmt)
  260. (if (stmt-cached? stmt)
  261. ;; It's necessary to reset cached statements due to the following:
  262. ;;
  263. ;; "An implicit transaction (a transaction that is started
  264. ;; automatically, not a transaction started by BEGIN) is committed
  265. ;; automatically when the last active statement finishes. A statement
  266. ;; finishes when its last cursor closes, which is guaranteed to happen
  267. ;; when the prepared statement is reset or finalized. Some statements
  268. ;; might "finish" for the purpose of transaction control prior to
  269. ;; being reset or finalized, but there is no guarantee of this."
  270. ;;
  271. ;; (see https://www.sqlite.org/lang_transaction.html)
  272. ;;
  273. ;; Thus, it's possible for an implicitly-started transaction to hang
  274. ;; around until sqlite-reset is called when the cached statement is
  275. ;; next used. Because the transaction is committed automatically only
  276. ;; when the *last active statement* finishes, the implicitly-started
  277. ;; transaction may later be upgraded to a write transaction (!) and
  278. ;; this non-reset statement will still be keeping the transaction from
  279. ;; committing until it is next used or the database connection is
  280. ;; closed. This has the potential to make (exclusive) write access to
  281. ;; the database necessary for much longer than it should be.
  282. ;;
  283. ;; So it's necessary to preserve the statement-finishing behavior of
  284. ;; sqlite_finalize here, which we do by calling sqlite-reset.
  285. (sqlite-reset stmt)
  286. (let ((p (stmt-pointer stmt)))
  287. (sqlite-remove-statement! (stmt->db stmt) stmt)
  288. (set-stmt-live?! stmt #f)
  289. (f p)))))))
  290. (define *stmt-map* (make-weak-key-hash-table))
  291. (define (stmt->db stmt)
  292. (hashq-ref *stmt-map* stmt))
  293. (define stmt-guardian (make-guardian))
  294. (define (pump-stmt-guardian)
  295. (let ((stmt (stmt-guardian)))
  296. (if stmt
  297. (begin
  298. (sqlite-finalize stmt)
  299. (pump-stmt-guardian)))))
  300. (add-hook! after-gc-hook pump-stmt-guardian)
  301. (define sqlite-reset
  302. (let ((reset (pointer->procedure
  303. int
  304. (dynamic-func "sqlite3_reset" libsqlite3)
  305. (list '*))))
  306. (lambda (stmt)
  307. (if (stmt-live? stmt)
  308. (let ((p (stmt-pointer stmt)))
  309. (set-stmt-reset?! stmt #t)
  310. (reset p))
  311. (error "statement already finalized" stmt)))))
  312. (define (assert-live-stmt! stmt)
  313. (if (not (stmt-live? stmt))
  314. (error "statement already finalized" stmt)))
  315. (define (assert-live-db! db)
  316. (if (not (db-open? db))
  317. (error "database already closed" db)))
  318. (define %sqlite-prepare
  319. (let ((prepare (pointer->procedure
  320. int
  321. (dynamic-func "sqlite3_prepare_v2" libsqlite3)
  322. (list '* '* int '* '*))))
  323. (lambda* (db sql #:key cache?)
  324. (assert-live-db! db)
  325. (let* ((out-stmt (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  326. (out-tail (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  327. (bv (string->utf8 sql))
  328. (bvp (bytevector->pointer bv))
  329. (ret (prepare (db-pointer db)
  330. bvp
  331. (bytevector-length bv)
  332. out-stmt
  333. out-tail)))
  334. (if (zero? ret)
  335. (if (= (bytevector-length bv)
  336. (- (pointer-address (dereference-pointer out-tail))
  337. (pointer-address bvp)))
  338. (let ((stmt (make-stmt (dereference-pointer out-stmt) #t #t
  339. cache?)))
  340. (stmt-guardian stmt)
  341. (hashq-set! *stmt-map* stmt db)
  342. stmt)
  343. (error "input sql has useless tail"
  344. (utf8-pointer->string
  345. (dereference-pointer out-tail))))
  346. (check-error db 'sqlite-prepare))))))
  347. (define* (sqlite-prepare db sql #:key cache?)
  348. (if cache?
  349. (match (hash-ref (db-stmts db) sql)
  350. (#f
  351. (let ((stmt (%sqlite-prepare db sql #:cache? #t)))
  352. (hash-set! (db-stmts db) sql stmt)
  353. stmt))
  354. (stmt
  355. (sqlite-reset stmt)
  356. stmt))
  357. (%sqlite-prepare db sql)))
  358. (define sqlite-bind-parameter-index
  359. (let ((bind-parameter-index (pointer->procedure
  360. int
  361. (dynamic-func "sqlite3_bind_parameter_index" libsqlite3)
  362. (list '* '*))))
  363. (lambda (stmt name)
  364. (assert-live-stmt! stmt)
  365. (let* ((ret (bind-parameter-index (stmt-pointer stmt)
  366. (string->utf8-pointer name))))
  367. (if (> ret 0)
  368. ret
  369. (begin
  370. (check-error (stmt->db stmt) 'sqlite-bind-parameter-index)
  371. (write ret)
  372. (newline)
  373. (error "No such parameter" name)))))))
  374. (define key->index
  375. (lambda (stmt key)
  376. (cond
  377. ((string? key) (sqlite-bind-parameter-index stmt key))
  378. ((symbol? key) (sqlite-bind-parameter-index stmt
  379. (string-append ":" (symbol->string key))))
  380. (else key))))
  381. (define sqlite-bind
  382. (let ((bind-blob (pointer->procedure
  383. int
  384. (dynamic-func "sqlite3_bind_blob" libsqlite3)
  385. (list '* int '* int '*)))
  386. (bind-text (pointer->procedure
  387. int
  388. (dynamic-func "sqlite3_bind_text" libsqlite3)
  389. (list '* int '* int '*)))
  390. (bind-int64 (pointer->procedure
  391. int
  392. (dynamic-func "sqlite3_bind_int64" libsqlite3)
  393. (list '* int int64)))
  394. (bind-double (pointer->procedure
  395. int
  396. (dynamic-func "sqlite3_bind_double" libsqlite3)
  397. (list '* int double)))
  398. (bind-null (pointer->procedure
  399. int
  400. (dynamic-func "sqlite3_bind_null" libsqlite3)
  401. (list '* int)))
  402. (sqlite-transient (make-pointer
  403. (bit-extract (lognot 0) 0 (* 8 (sizeof '*))))))
  404. (lambda (stmt key val)
  405. (assert-live-stmt! stmt)
  406. (let ((idx (key->index stmt key))
  407. (p (stmt-pointer stmt)))
  408. (cond
  409. ((bytevector? val)
  410. (bind-blob p idx (bytevector->pointer val) (bytevector-length val)
  411. sqlite-transient))
  412. ((string? val)
  413. (let ((bv (string->utf8 val)))
  414. (bind-text p idx (bytevector->pointer bv) (bytevector-length bv)
  415. sqlite-transient)))
  416. ((and (integer? val) (exact? val))
  417. (bind-int64 p idx val))
  418. ((number? val)
  419. (bind-double p idx (exact->inexact val)))
  420. ((not val)
  421. (bind-null p idx))
  422. (else
  423. (error "unexpected value" val)))
  424. (check-error (stmt->db stmt))))))
  425. (define (sqlite-bind-arguments stmt . args)
  426. "Bind STMT parameters, one after another, to ARGS.
  427. Also bind named parameters to the respective ones."
  428. (let loop ((i 1)
  429. (args args))
  430. (match args
  431. (()
  432. #f)
  433. (((? keyword? kw) value . rest)
  434. (sqlite-bind stmt (keyword->symbol kw) value)
  435. (loop i rest))
  436. ((arg . rest)
  437. (sqlite-bind stmt i arg)
  438. (loop (+ 1 i) rest)))))
  439. (define sqlite-column-count
  440. (let ((column-count
  441. (pointer->procedure
  442. int
  443. (dynamic-pointer "sqlite3_column_count" libsqlite3)
  444. (list '*))))
  445. (lambda (stmt)
  446. (assert-live-stmt! stmt)
  447. (column-count (stmt-pointer stmt)))))
  448. (define sqlite-column-name
  449. (let ((column-name
  450. (pointer->procedure
  451. '*
  452. (dynamic-pointer "sqlite3_column_name" libsqlite3)
  453. (list '* int))))
  454. (lambda (stmt i)
  455. (assert-live-stmt! stmt)
  456. (utf8-pointer->string (column-name (stmt-pointer stmt) i)))))
  457. (define sqlite-column-value
  458. (let ((value-type
  459. (pointer->procedure
  460. int
  461. (dynamic-pointer "sqlite3_column_type" libsqlite3)
  462. (list '* int)))
  463. (value-int
  464. (pointer->procedure
  465. int64
  466. (dynamic-pointer "sqlite3_column_int64" libsqlite3)
  467. (list '* int)))
  468. (value-double
  469. (pointer->procedure
  470. double
  471. (dynamic-pointer "sqlite3_column_double" libsqlite3)
  472. (list '* int)))
  473. (value-text
  474. (pointer->procedure
  475. '*
  476. (dynamic-pointer "sqlite3_column_text" libsqlite3)
  477. (list '* int)))
  478. (value-blob
  479. (pointer->procedure
  480. '*
  481. (dynamic-pointer "sqlite3_column_blob" libsqlite3)
  482. (list '* int)))
  483. (value-bytes
  484. (pointer->procedure
  485. int
  486. (dynamic-pointer "sqlite3_column_bytes" libsqlite3)
  487. (list '* int))))
  488. (lambda (stmt i)
  489. (assert-live-stmt! stmt)
  490. (let ((nbytes (value-bytes (stmt-pointer stmt) i)))
  491. (case (value-type (stmt-pointer stmt) i)
  492. ((1) ; SQLITE_INTEGER
  493. (value-int (stmt-pointer stmt) i))
  494. ((2) ; SQLITE_FLOAT
  495. (value-double (stmt-pointer stmt) i))
  496. ((3) ; SQLITE3_TEXT
  497. (let ((p (value-blob (stmt-pointer stmt) i)))
  498. (if (null-pointer? p)
  499. ""
  500. (utf8->string
  501. (pointer->bytevector p nbytes)))))
  502. ((4) ; SQLITE_BLOB
  503. (let ((p (value-blob (stmt-pointer stmt) i)))
  504. (if (null-pointer? p)
  505. (make-bytevector 0)
  506. (bytevector-copy
  507. (pointer->bytevector p nbytes)))))
  508. ((5) ; SQLITE_NULL
  509. #f))))))
  510. (define (sqlite-column-names stmt)
  511. (let ((v (make-vector (sqlite-column-count stmt))))
  512. (let lp ((i 0))
  513. (if (< i (vector-length v))
  514. (begin
  515. (vector-set! v i (sqlite-column-name stmt i))
  516. (lp (1+ i)))
  517. v))))
  518. (define (sqlite-row stmt)
  519. (let ((v (make-vector (sqlite-column-count stmt))))
  520. (let lp ((i 0))
  521. (if (< i (vector-length v))
  522. (begin
  523. (vector-set! v i (sqlite-column-value stmt i))
  524. (lp (1+ i)))
  525. v))))
  526. (define sqlite-busy-timeout
  527. (let ((f (pointer->procedure
  528. int
  529. (dynamic-func "sqlite3_busy_timeout" libsqlite3)
  530. (list '* int))))
  531. (lambda (db value)
  532. (assert-live-db! db)
  533. (let ((ret (f (db-pointer db) value)))
  534. (when (not (zero? ret))
  535. (check-error db 'sqlite-busy-timeout))))))
  536. (define trace-callback
  537. (lambda (callback)
  538. (procedure->pointer
  539. int
  540. ;; P and X pointers are described here:
  541. ;; https://www.sqlite.org/c3ref/c_trace.html.
  542. (lambda (trace context p x)
  543. (callback trace p x)
  544. 0)
  545. (list unsigned-int '* '* '*))))
  546. (define sqlite-expanded-sql
  547. (let ((proc (pointer->procedure
  548. '*
  549. (dynamic-func "sqlite3_expanded_sql" libsqlite3)
  550. (list '*))))
  551. (lambda (stmt-pointer)
  552. (proc stmt-pointer))))
  553. (define sqlite-trace
  554. (let ((proc (pointer->procedure
  555. int
  556. (dynamic-func "sqlite3_trace_v2" libsqlite3)
  557. (list '* unsigned-int '* '*))))
  558. (lambda (db mask callback)
  559. (proc (db-pointer db)
  560. mask
  561. (trace-callback callback)
  562. %null-pointer))))
  563. (define sqlite-step
  564. (let ((step (pointer->procedure
  565. int
  566. (dynamic-pointer "sqlite3_step" libsqlite3)
  567. (list '*))))
  568. (lambda (stmt)
  569. (assert-live-stmt! stmt)
  570. (let ((ret (step (stmt-pointer stmt))))
  571. (case ret
  572. ((100) ; SQLITE_ROW
  573. (sqlite-row stmt))
  574. ((101) ; SQLITE_DONE
  575. #f)
  576. (else
  577. (check-error (stmt->db stmt))
  578. (error "shouldn't get here")))))))
  579. (define (sqlite-fold kons knil stmt)
  580. (assert-live-stmt! stmt)
  581. (let lp ((seed knil))
  582. (let ((row (sqlite-step stmt)))
  583. (if row
  584. (lp (kons row seed))
  585. seed))))
  586. (define (sqlite-fold-right kons knil stmt)
  587. (assert-live-stmt! stmt)
  588. (let lp ()
  589. (let ((row (sqlite-step stmt)))
  590. (if row
  591. (kons row (lp))
  592. knil))))
  593. (define (sqlite-map proc stmt)
  594. (map proc
  595. (reverse! (sqlite-fold cons '() stmt))))