sqlite3.scm 15 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455
  1. ;; Guile-SQLite3
  2. ;; Copyright (C) 2010, 2014 Andy Wingo <wingo at pobox dot com>
  3. ;; This library is free software; you can redistribute it and/or modify
  4. ;; it under the terms of the GNU Lesser General Public License as
  5. ;; published by the Free Software Foundation; either version 3 of the
  6. ;; License, or (at your option) any later version.
  7. ;;
  8. ;; This library is distributed in the hope that it will be useful, but
  9. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this program; if not, contact:
  15. ;;
  16. ;; Free Software Foundation Voice: +1-617-542-5942
  17. ;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
  18. ;; Boston, MA 02111-1307, USA gnu@gnu.org
  19. ;;; Commentary:
  20. ;;
  21. ;; A Guile binding for sqlite.
  22. ;;
  23. ;;; Code:
  24. (define-module (sqlite3)
  25. #:use-module (system foreign)
  26. #:use-module (rnrs bytevectors)
  27. #:use-module (srfi srfi-9)
  28. #:export (sqlite-open
  29. sqlite-close
  30. sqlite-enable-load-extension
  31. sqlite-prepare
  32. sqlite-bind
  33. sqlite-column-names
  34. sqlite-step
  35. sqlite-fold
  36. sqlite-fold-right
  37. sqlite-map
  38. sqlite-reset
  39. sqlite-finalize
  40. SQLITE_OPEN_READONLY
  41. SQLITE_OPEN_READWRITE
  42. SQLITE_OPEN_CREATE
  43. SQLITE_OPEN_DELETEONCLOSE
  44. SQLITE_OPEN_EXCLUSIVE
  45. SQLITE_OPEN_MAIN_DB
  46. SQLITE_OPEN_TEMP_DB
  47. SQLITE_OPEN_TRANSIENT_DB
  48. SQLITE_OPEN_MAIN_JOURNAL
  49. SQLITE_OPEN_TEMP_JOURNAL
  50. SQLITE_OPEN_SUBJOURNAL
  51. SQLITE_OPEN_MASTER_JOURNAL
  52. SQLITE_OPEN_NOMUTEX
  53. SQLITE_OPEN_FULLMUTEX
  54. SQLITE_OPEN_SHAREDCACHE
  55. SQLITE_OPEN_PRIVATECACHE))
  56. ;;
  57. ;; Utils
  58. ;;
  59. (define (string->utf8-pointer s)
  60. (string->pointer s "utf-8"))
  61. (define (utf8-pointer->string p)
  62. (pointer->string p -1 "utf-8"))
  63. ;;
  64. ;; Constants
  65. ;;
  66. ;; FIXME: snarf using compiler. These are just copied from the header...
  67. ;;
  68. (define SQLITE_OPEN_READONLY #x00000001) ;; Ok for sqlite3_open_v2()
  69. (define SQLITE_OPEN_READWRITE #x00000002) ;; Ok for sqlite3_open_v2()
  70. (define SQLITE_OPEN_CREATE #x00000004) ;; Ok for sqlite3_open_v2()
  71. (define SQLITE_OPEN_DELETEONCLOSE #x00000008) ;; VFS only
  72. (define SQLITE_OPEN_EXCLUSIVE #x00000010) ;; VFS only
  73. (define SQLITE_OPEN_MAIN_DB #x00000100) ;; VFS only
  74. (define SQLITE_OPEN_TEMP_DB #x00000200) ;; VFS only
  75. (define SQLITE_OPEN_TRANSIENT_DB #x00000400) ;; VFS only
  76. (define SQLITE_OPEN_MAIN_JOURNAL #x00000800) ;; VFS only
  77. (define SQLITE_OPEN_TEMP_JOURNAL #x00001000) ;; VFS only
  78. (define SQLITE_OPEN_SUBJOURNAL #x00002000) ;; VFS only
  79. (define SQLITE_OPEN_MASTER_JOURNAL #x00004000) ;; VFS only
  80. (define SQLITE_OPEN_NOMUTEX #x00008000) ;; Ok for sqlite3_open_v2()
  81. (define SQLITE_OPEN_FULLMUTEX #x00010000) ;; Ok for sqlite3_open_v2()
  82. (define SQLITE_OPEN_SHAREDCACHE #x00020000) ;; Ok for sqlite3_open_v2()
  83. (define SQLITE_OPEN_PRIVATECACHE #x00040000) ;; Ok for sqlite3_open_v2()
  84. (define libsqlite3 (dynamic-link "libsqlite3"))
  85. (define-record-type <sqlite-db>
  86. (make-db pointer open?)
  87. db?
  88. (pointer db-pointer)
  89. (open? db-open? set-db-open?!))
  90. (define sqlite-errmsg
  91. (let ((f (pointer->procedure
  92. '*
  93. (dynamic-func "sqlite3_errmsg" libsqlite3)
  94. (list '*))))
  95. (lambda (db)
  96. (utf8-pointer->string (f (db-pointer db))))))
  97. (define sqlite-errcode
  98. (let ((f (pointer->procedure
  99. int
  100. (dynamic-func "sqlite3_extended_errcode" libsqlite3)
  101. (list '*))))
  102. (lambda (db)
  103. (f (db-pointer db)))))
  104. (define* (sqlite-error db who #:optional code
  105. (errmsg (and db (sqlite-errmsg db))))
  106. (throw 'sqlite-error who code errmsg))
  107. (define* (check-error db #:optional who)
  108. (let ((code (sqlite-errcode db)))
  109. (if (not (zero? code))
  110. (sqlite-error db who code))))
  111. (define sqlite-close
  112. (let ((f (pointer->procedure
  113. int
  114. (dynamic-func "sqlite3_close" libsqlite3)
  115. (list '*))))
  116. (lambda (db)
  117. (if (db-open? db)
  118. (begin
  119. (let ((p (db-pointer db)))
  120. (set-db-open?! db #f)
  121. (f p)))))))
  122. (define db-guardian (make-guardian))
  123. (define (pump-db-guardian)
  124. (let ((db (db-guardian)))
  125. (if db
  126. (begin
  127. (sqlite-close db)
  128. (pump-db-guardian)))))
  129. (add-hook! after-gc-hook pump-db-guardian)
  130. (define (static-errcode->errmsg code)
  131. (case code
  132. ((1) "SQL error or missing database")
  133. ((2) "Internal logic error in SQLite")
  134. ((3) "Access permission denied")
  135. ((5) "The database file is locked")
  136. ((6) "A table in the database is locked")
  137. ((7) "A malloc() failed")
  138. ((8) "Attempt to write a readonly database")
  139. ((10) "Some kind of disk I/O error occurred")
  140. ((11) "The database disk image is malformed")
  141. ((14) "Unable to open the database file")
  142. ((21) "Library used incorrectly")
  143. ((22) "Uses OS features not supported on host")
  144. ((23) "Authorization denied")
  145. ((24) "Auxiliary database format error")
  146. ((26) "File opened that is not a database file")
  147. (else "Unknown error")))
  148. (define sqlite-open
  149. (let ((f (pointer->procedure
  150. int
  151. (dynamic-func "sqlite3_open_v2" libsqlite3)
  152. (list '* '* int '*))))
  153. (lambda* (filename #:optional
  154. (flags (logior SQLITE_OPEN_READWRITE SQLITE_OPEN_CREATE))
  155. (vfs #f))
  156. (let* ((out-db (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  157. (ret (f (string->utf8-pointer filename)
  158. out-db
  159. flags
  160. (if vfs (string->utf8-pointer vfs) %null-pointer))))
  161. (if (zero? ret)
  162. (let ((db (make-db (dereference-pointer out-db) #t)))
  163. (db-guardian db)
  164. db)
  165. (sqlite-error #f 'sqlite-open ret (static-errcode->errmsg ret)))))))
  166. (define sqlite-enable-load-extension
  167. (let ((ele (pointer->procedure
  168. int
  169. (dynamic-func "sqlite3_enable_load_extension" libsqlite3)
  170. (list '* int))))
  171. (lambda (db onoff)
  172. (ele (db-pointer db) onoff))))
  173. ;;;
  174. ;;; SQL statements
  175. ;;;
  176. (define-record-type <sqlite-stmt>
  177. (make-stmt pointer live? reset?)
  178. stmt?
  179. (pointer stmt-pointer)
  180. (live? stmt-live? set-stmt-live?!)
  181. (reset? stmt-reset? set-stmt-reset?!))
  182. (define sqlite-finalize
  183. (let ((f (pointer->procedure
  184. int
  185. (dynamic-func "sqlite3_finalize" libsqlite3)
  186. (list '*))))
  187. (lambda (stmt)
  188. (if (stmt-live? stmt)
  189. (begin
  190. (let ((p (stmt-pointer stmt)))
  191. (set-stmt-live?! stmt #f)
  192. (f p)))))))
  193. (define *stmt-map* (make-weak-key-hash-table))
  194. (define (stmt->db stmt)
  195. (hashq-ref *stmt-map* stmt))
  196. (define stmt-guardian (make-guardian))
  197. (define (pump-stmt-guardian)
  198. (let ((stmt (stmt-guardian)))
  199. (if stmt
  200. (begin
  201. (sqlite-finalize stmt)
  202. (pump-stmt-guardian)))))
  203. (add-hook! after-gc-hook pump-stmt-guardian)
  204. (define sqlite-reset
  205. (let ((reset (pointer->procedure
  206. int
  207. (dynamic-func "sqlite3_reset" libsqlite3)
  208. (list '*))))
  209. (lambda (stmt)
  210. (if (stmt-live? stmt)
  211. (let ((p (stmt-pointer stmt)))
  212. (set-stmt-reset?! stmt #t)
  213. (reset p))
  214. (error "statement already finalized" stmt)))))
  215. (define (assert-live-stmt! stmt)
  216. (if (not (stmt-live? stmt))
  217. (error "statement already finalized" stmt)))
  218. (define (assert-live-db! db)
  219. (if (not (db-open? db))
  220. (error "database already closed" db)))
  221. (define sqlite-prepare
  222. (let ((prepare (pointer->procedure
  223. int
  224. (dynamic-func "sqlite3_prepare_v2" libsqlite3)
  225. (list '* '* int '* '*))))
  226. (lambda (db sql)
  227. (assert-live-db! db)
  228. (let* ((out-stmt (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  229. (out-tail (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  230. (bv (string->utf8 sql))
  231. (bvp (bytevector->pointer bv))
  232. (ret (prepare (db-pointer db)
  233. bvp
  234. (bytevector-length bv)
  235. out-stmt
  236. out-tail)))
  237. (if (zero? ret)
  238. (if (= (bytevector-length bv)
  239. (- (pointer-address (dereference-pointer out-tail))
  240. (pointer-address bvp)))
  241. (let ((stmt (make-stmt (dereference-pointer out-stmt) #t #t)))
  242. (stmt-guardian stmt)
  243. (hashq-set! *stmt-map* stmt db)
  244. stmt)
  245. (error "input sql has useless tail"
  246. (utf8-pointer->string
  247. (dereference-pointer out-tail))))
  248. (check-error db 'sqlite-prepare))))))
  249. (define key->index
  250. (lambda (stmt key)
  251. key))
  252. (define sqlite-bind
  253. (let ((bind-blob (pointer->procedure
  254. int
  255. (dynamic-func "sqlite3_bind_blob" libsqlite3)
  256. (list '* int '* int '*)))
  257. (bind-text (pointer->procedure
  258. int
  259. (dynamic-func "sqlite3_bind_text" libsqlite3)
  260. (list '* int '* int '*)))
  261. (bind-int64 (pointer->procedure
  262. int
  263. (dynamic-func "sqlite3_bind_int64" libsqlite3)
  264. (list '* int int64)))
  265. (bind-double (pointer->procedure
  266. int
  267. (dynamic-func "sqlite3_bind_double" libsqlite3)
  268. (list '* int double)))
  269. (bind-null (pointer->procedure
  270. int
  271. (dynamic-func "sqlite3_bind_null" libsqlite3)
  272. (list '* int)))
  273. (sqlite-transient (make-pointer
  274. (bit-extract (lognot 0) 0 (* 8 (sizeof '*))))))
  275. (lambda (stmt key val)
  276. (assert-live-stmt! stmt)
  277. (let ((idx (key->index stmt key))
  278. (p (stmt-pointer stmt)))
  279. (cond
  280. ((bytevector? val)
  281. (bind-blob p idx (bytevector->pointer val) (bytevector-length val)
  282. sqlite-transient))
  283. ((string? val)
  284. (let ((bv (string->utf8 val)))
  285. (bind-text p idx (bytevector->pointer bv) (bytevector-length bv)
  286. sqlite-transient)))
  287. ((and (integer? val) (exact? val))
  288. (bind-int64 p idx val))
  289. ((number? val)
  290. (bind-double p idx (exact->inexact val)))
  291. ((not val)
  292. (bind-null p idx))
  293. (else
  294. (error "unexpected value" val)))
  295. (check-error (stmt->db stmt))))))
  296. (define sqlite-column-count
  297. (let ((column-count
  298. (pointer->procedure
  299. int
  300. (dynamic-pointer "sqlite3_column_count" libsqlite3)
  301. (list '*))))
  302. (lambda (stmt)
  303. (assert-live-stmt! stmt)
  304. (column-count (stmt-pointer stmt)))))
  305. (define sqlite-column-name
  306. (let ((column-name
  307. (pointer->procedure
  308. '*
  309. (dynamic-pointer "sqlite3_column_name" libsqlite3)
  310. (list '* int))))
  311. (lambda (stmt i)
  312. (assert-live-stmt! stmt)
  313. (utf8-pointer->string (column-name (stmt-pointer stmt) i)))))
  314. (define sqlite-column-value
  315. (let ((value-type
  316. (pointer->procedure
  317. int
  318. (dynamic-pointer "sqlite3_column_type" libsqlite3)
  319. (list '* int)))
  320. (value-int
  321. (pointer->procedure
  322. int64
  323. (dynamic-pointer "sqlite3_column_int64" libsqlite3)
  324. (list '* int)))
  325. (value-double
  326. (pointer->procedure
  327. double
  328. (dynamic-pointer "sqlite3_column_double" libsqlite3)
  329. (list '* int)))
  330. (value-text
  331. (pointer->procedure
  332. '*
  333. (dynamic-pointer "sqlite3_column_text" libsqlite3)
  334. (list '* int)))
  335. (value-blob
  336. (pointer->procedure
  337. '*
  338. (dynamic-pointer "sqlite3_column_blob" libsqlite3)
  339. (list '* int)))
  340. (value-bytes
  341. (pointer->procedure
  342. int
  343. (dynamic-pointer "sqlite3_column_bytes" libsqlite3)
  344. (list '* int))))
  345. (lambda (stmt i)
  346. (assert-live-stmt! stmt)
  347. (case (value-type (stmt-pointer stmt) i)
  348. ((1) ; SQLITE_INTEGER
  349. (value-int (stmt-pointer stmt) i))
  350. ((2) ; SQLITE_FLOAT
  351. (value-double (stmt-pointer stmt) i))
  352. ((3) ; SQLITE3_TEXT
  353. (let ((p (value-blob (stmt-pointer stmt) i)))
  354. (if (null-pointer? p)
  355. ""
  356. (utf8->string
  357. (pointer->bytevector p (value-bytes (stmt-pointer stmt) i))))))
  358. ((4) ; SQLITE_BLOB
  359. (let ((p (value-blob (stmt-pointer stmt) i)))
  360. (if (null-pointer? p)
  361. (make-bytevector 0)
  362. (pointer->bytevector p (value-bytes (stmt-pointer stmt) i)))))
  363. ((5) ; SQLITE_NULL
  364. #f)))))
  365. (define (sqlite-column-names stmt)
  366. (let ((v (make-vector (sqlite-column-count stmt))))
  367. (let lp ((i 0))
  368. (if (< i (vector-length v))
  369. (begin
  370. (vector-set! v i (sqlite-column-name stmt i))
  371. (lp (1+ i)))
  372. v))))
  373. (define (sqlite-row stmt)
  374. (let ((v (make-vector (sqlite-column-count stmt))))
  375. (let lp ((i 0))
  376. (if (< i (vector-length v))
  377. (begin
  378. (vector-set! v i (sqlite-column-value stmt i))
  379. (lp (1+ i)))
  380. v))))
  381. (define sqlite-step
  382. (let ((step (pointer->procedure
  383. int
  384. (dynamic-pointer "sqlite3_step" libsqlite3)
  385. (list '*))))
  386. (lambda (stmt)
  387. (assert-live-stmt! stmt)
  388. (let ((ret (step (stmt-pointer stmt))))
  389. (case ret
  390. ((100) ; SQLITE_ROW
  391. (sqlite-row stmt))
  392. ((101) ; SQLITE_DONE
  393. #f)
  394. (else
  395. (check-error (stmt->db stmt))
  396. (error "shouldn't get here")))))))
  397. (define (sqlite-fold kons knil stmt)
  398. (assert-live-stmt! stmt)
  399. (let lp ((seed knil))
  400. (let ((row (sqlite-step stmt)))
  401. (if row
  402. (lp (kons row seed))
  403. seed))))
  404. (define (sqlite-fold-right kons knil stmt)
  405. (assert-live-stmt! stmt)
  406. (let lp ()
  407. (let ((row (sqlite-step stmt)))
  408. (if row
  409. (kons row (lp))
  410. knil))))
  411. (define (sqlite-map proc stmt)
  412. (map proc
  413. (reverse! (sqlite-fold cons '() stmt))))