sqlite3.scm 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547
  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-close
  34. sqlite-enable-load-extension
  35. sqlite-prepare*
  36. sqlite-prepare
  37. sqlite-bind
  38. sqlite-bind-arguments
  39. sqlite-column-names
  40. sqlite-step
  41. sqlite-fold
  42. sqlite-fold-right
  43. sqlite-map
  44. sqlite-reset
  45. sqlite-finalize
  46. sqlite-bind-parameter-index
  47. SQLITE_OPEN_READONLY
  48. SQLITE_OPEN_READWRITE
  49. SQLITE_OPEN_CREATE
  50. SQLITE_OPEN_DELETEONCLOSE
  51. SQLITE_OPEN_EXCLUSIVE
  52. SQLITE_OPEN_MAIN_DB
  53. SQLITE_OPEN_TEMP_DB
  54. SQLITE_OPEN_TRANSIENT_DB
  55. SQLITE_OPEN_MAIN_JOURNAL
  56. SQLITE_OPEN_TEMP_JOURNAL
  57. SQLITE_OPEN_SUBJOURNAL
  58. SQLITE_OPEN_MASTER_JOURNAL
  59. SQLITE_OPEN_NOMUTEX
  60. SQLITE_OPEN_FULLMUTEX
  61. SQLITE_OPEN_SHAREDCACHE
  62. SQLITE_OPEN_PRIVATECACHE
  63. SQLITE_CONSTRAINT
  64. SQLITE_CONSTRAINT_PRIMARYKEY))
  65. ;;
  66. ;; Utils
  67. ;;
  68. (define (string->utf8-pointer s)
  69. (string->pointer s "utf-8"))
  70. (define (utf8-pointer->string p)
  71. (pointer->string p -1 "utf-8"))
  72. ;;
  73. ;; Constants
  74. ;;
  75. ;; FIXME: snarf using compiler. These are just copied from the header...
  76. ;;
  77. (define SQLITE_OPEN_READONLY #x00000001) ;; Ok for sqlite3_open_v2()
  78. (define SQLITE_OPEN_READWRITE #x00000002) ;; Ok for sqlite3_open_v2()
  79. (define SQLITE_OPEN_CREATE #x00000004) ;; Ok for sqlite3_open_v2()
  80. (define SQLITE_OPEN_DELETEONCLOSE #x00000008) ;; VFS only
  81. (define SQLITE_OPEN_EXCLUSIVE #x00000010) ;; VFS only
  82. (define SQLITE_OPEN_MAIN_DB #x00000100) ;; VFS only
  83. (define SQLITE_OPEN_TEMP_DB #x00000200) ;; VFS only
  84. (define SQLITE_OPEN_TRANSIENT_DB #x00000400) ;; VFS only
  85. (define SQLITE_OPEN_MAIN_JOURNAL #x00000800) ;; VFS only
  86. (define SQLITE_OPEN_TEMP_JOURNAL #x00001000) ;; VFS only
  87. (define SQLITE_OPEN_SUBJOURNAL #x00002000) ;; VFS only
  88. (define SQLITE_OPEN_MASTER_JOURNAL #x00004000) ;; VFS only
  89. (define SQLITE_OPEN_NOMUTEX #x00008000) ;; Ok for sqlite3_open_v2()
  90. (define SQLITE_OPEN_FULLMUTEX #x00010000) ;; Ok for sqlite3_open_v2()
  91. (define SQLITE_OPEN_SHAREDCACHE #x00020000) ;; Ok for sqlite3_open_v2()
  92. (define SQLITE_OPEN_PRIVATECACHE #x00040000) ;; Ok for sqlite3_open_v2()
  93. (define SQLITE_CONSTRAINT 19)
  94. (define SQLITE_CONSTRAINT_PRIMARYKEY
  95. (logior SQLITE_CONSTRAINT (ash 6 8)))
  96. (define libsqlite3 (dynamic-link "libsqlite3"))
  97. (define-record-type <sqlite-db>
  98. (make-db pointer open? stmts)
  99. db?
  100. (pointer db-pointer)
  101. (open? db-open? set-db-open?!)
  102. (stmts db-stmts))
  103. (define-record-type <sqlite-stmt>
  104. (make-stmt pointer live? reset? cached?)
  105. stmt?
  106. (pointer stmt-pointer)
  107. (live? stmt-live? set-stmt-live?!)
  108. (reset? stmt-reset? set-stmt-reset?!)
  109. (cached? stmt-cached? set-stmt-cached?!))
  110. (define sqlite-errmsg
  111. (let ((f (pointer->procedure
  112. '*
  113. (dynamic-func "sqlite3_errmsg" libsqlite3)
  114. (list '*))))
  115. (lambda (db)
  116. (utf8-pointer->string (f (db-pointer db))))))
  117. (define sqlite-errcode
  118. (let ((f (pointer->procedure
  119. int
  120. (dynamic-func "sqlite3_extended_errcode" libsqlite3)
  121. (list '*))))
  122. (lambda (db)
  123. (f (db-pointer db)))))
  124. (define* (sqlite-error db who #:optional code
  125. (errmsg (and db (sqlite-errmsg db))))
  126. (throw 'sqlite-error who code errmsg))
  127. (define* (check-error db #:optional who)
  128. (let ((code (sqlite-errcode db)))
  129. (if (not (zero? code))
  130. (sqlite-error db who code))))
  131. (define sqlite-close
  132. (let ((f (pointer->procedure
  133. int
  134. (dynamic-func "sqlite3_close" libsqlite3)
  135. (list '*))))
  136. (lambda (db)
  137. (when (db-open? db)
  138. ;; Finalize cached statements.
  139. (hash-for-each (lambda (sql stmt)
  140. (set-stmt-cached?! stmt #f)
  141. (sqlite-finalize stmt))
  142. (db-stmts db))
  143. (hash-clear! (db-stmts db))
  144. (let ((p (db-pointer db)))
  145. (set-db-open?! db #f)
  146. (f p))))))
  147. (define db-guardian (make-guardian))
  148. (define (pump-db-guardian)
  149. (let ((db (db-guardian)))
  150. (if db
  151. (begin
  152. (sqlite-close db)
  153. (pump-db-guardian)))))
  154. (add-hook! after-gc-hook pump-db-guardian)
  155. (define (static-errcode->errmsg code)
  156. (case code
  157. ((1) "SQL error or missing database")
  158. ((2) "Internal logic error in SQLite")
  159. ((3) "Access permission denied")
  160. ((5) "The database file is locked")
  161. ((6) "A table in the database is locked")
  162. ((7) "A malloc() failed")
  163. ((8) "Attempt to write a readonly database")
  164. ((10) "Some kind of disk I/O error occurred")
  165. ((11) "The database disk image is malformed")
  166. ((14) "Unable to open the database file")
  167. ((21) "Library used incorrectly")
  168. ((22) "Uses OS features not supported on host")
  169. ((23) "Authorization denied")
  170. ((24) "Auxiliary database format error")
  171. ((26) "File opened that is not a database file")
  172. (else "Unknown error")))
  173. (define sqlite-open
  174. (let ((f (pointer->procedure
  175. int
  176. (dynamic-func "sqlite3_open_v2" libsqlite3)
  177. (list '* '* int '*))))
  178. (lambda* (filename #:optional
  179. (flags (logior SQLITE_OPEN_READWRITE SQLITE_OPEN_CREATE))
  180. (vfs #f))
  181. (let* ((out-db (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  182. (ret (f (string->utf8-pointer filename)
  183. out-db
  184. flags
  185. (if vfs (string->utf8-pointer vfs) %null-pointer))))
  186. (if (zero? ret)
  187. (let ((db (make-db (dereference-pointer out-db) #t
  188. (make-hash-table))))
  189. (db-guardian db)
  190. db)
  191. (sqlite-error #f 'sqlite-open ret (static-errcode->errmsg ret)))))))
  192. (define sqlite-enable-load-extension
  193. (let ((ele (pointer->procedure
  194. int
  195. (dynamic-func "sqlite3_enable_load_extension" libsqlite3)
  196. (list '* int))))
  197. (lambda (db onoff)
  198. (ele (db-pointer db) onoff))))
  199. ;;;
  200. ;;; SQL statements
  201. ;;;
  202. (define sqlite-remove-statement!
  203. (lambda (db stmt)
  204. (when (stmt-cached? stmt)
  205. (let* ((stmts (db-stmts db))
  206. (key (catch 'value
  207. (lambda ()
  208. (hash-for-each (lambda (key value)
  209. (when (eq? value stmt)
  210. (throw 'value key)))
  211. stmts)
  212. #f)
  213. (lambda (_ key) key))))
  214. (hash-remove! stmts key)))))
  215. (define sqlite-finalize
  216. (let ((f (pointer->procedure
  217. int
  218. (dynamic-func "sqlite3_finalize" libsqlite3)
  219. (list '*))))
  220. (lambda (stmt)
  221. ;; Note: When STMT is cached, this is a no-op. This ensures caching
  222. ;; actually works while still separating concerns: users can turn
  223. ;; caching on and off without having to change the rest of their code.
  224. (when (and (stmt-live? stmt)
  225. (not (stmt-cached? stmt)))
  226. (let ((p (stmt-pointer stmt)))
  227. (sqlite-remove-statement! (stmt->db stmt) stmt)
  228. (set-stmt-live?! stmt #f)
  229. (f p))))))
  230. (define *stmt-map* (make-weak-key-hash-table))
  231. (define (stmt->db stmt)
  232. (hashq-ref *stmt-map* stmt))
  233. (define stmt-guardian (make-guardian))
  234. (define (pump-stmt-guardian)
  235. (let ((stmt (stmt-guardian)))
  236. (if stmt
  237. (begin
  238. (sqlite-finalize stmt)
  239. (pump-stmt-guardian)))))
  240. (add-hook! after-gc-hook pump-stmt-guardian)
  241. (define sqlite-reset
  242. (let ((reset (pointer->procedure
  243. int
  244. (dynamic-func "sqlite3_reset" libsqlite3)
  245. (list '*))))
  246. (lambda (stmt)
  247. (if (stmt-live? stmt)
  248. (let ((p (stmt-pointer stmt)))
  249. (set-stmt-reset?! stmt #t)
  250. (reset p))
  251. (error "statement already finalized" stmt)))))
  252. (define (assert-live-stmt! stmt)
  253. (if (not (stmt-live? stmt))
  254. (error "statement already finalized" stmt)))
  255. (define (assert-live-db! db)
  256. (if (not (db-open? db))
  257. (error "database already closed" db)))
  258. (define %sqlite-prepare
  259. (let ((prepare (pointer->procedure
  260. int
  261. (dynamic-func "sqlite3_prepare_v2" libsqlite3)
  262. (list '* '* int '* '*))))
  263. (lambda* (db sql #:key cache?)
  264. (assert-live-db! db)
  265. (let* ((out-stmt (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  266. (out-tail (bytevector->pointer (make-bytevector (sizeof '*) 0)))
  267. (bv (string->utf8 sql))
  268. (bvp (bytevector->pointer bv))
  269. (ret (prepare (db-pointer db)
  270. bvp
  271. (bytevector-length bv)
  272. out-stmt
  273. out-tail)))
  274. (if (zero? ret)
  275. (if (= (bytevector-length bv)
  276. (- (pointer-address (dereference-pointer out-tail))
  277. (pointer-address bvp)))
  278. (let ((stmt (make-stmt (dereference-pointer out-stmt) #t #t
  279. cache?)))
  280. (stmt-guardian stmt)
  281. (hashq-set! *stmt-map* stmt db)
  282. stmt)
  283. (error "input sql has useless tail"
  284. (utf8-pointer->string
  285. (dereference-pointer out-tail))))
  286. (check-error db 'sqlite-prepare))))))
  287. (define* (sqlite-prepare db sql #:key cache?)
  288. (if cache?
  289. (match (hash-ref (db-stmts db) sql)
  290. (#f
  291. (let ((stmt (%sqlite-prepare db sql #:cache? #t)))
  292. (hash-set! (db-stmts db) sql stmt)
  293. stmt))
  294. (stmt
  295. (sqlite-reset stmt)
  296. stmt))
  297. (%sqlite-prepare db sql)))
  298. (define sqlite-bind-parameter-index
  299. (let ((bind-parameter-index (pointer->procedure
  300. int
  301. (dynamic-func "sqlite3_bind_parameter_index" libsqlite3)
  302. (list '* '*))))
  303. (lambda (stmt name)
  304. (assert-live-stmt! stmt)
  305. (let* ((ret (bind-parameter-index (stmt-pointer stmt)
  306. (string->utf8-pointer name))))
  307. (if (> ret 0)
  308. ret
  309. (begin
  310. (check-error (stmt->db stmt) 'sqlite-bind-parameter-index)
  311. (write ret)
  312. (newline)
  313. (error "No such parameter" name)))))))
  314. (define key->index
  315. (lambda (stmt key)
  316. (cond
  317. ((string? key) (sqlite-bind-parameter-index stmt key))
  318. ((symbol? key) (sqlite-bind-parameter-index stmt
  319. (string-append ":" (symbol->string key))))
  320. (else key))))
  321. (define sqlite-bind
  322. (let ((bind-blob (pointer->procedure
  323. int
  324. (dynamic-func "sqlite3_bind_blob" libsqlite3)
  325. (list '* int '* int '*)))
  326. (bind-text (pointer->procedure
  327. int
  328. (dynamic-func "sqlite3_bind_text" libsqlite3)
  329. (list '* int '* int '*)))
  330. (bind-int64 (pointer->procedure
  331. int
  332. (dynamic-func "sqlite3_bind_int64" libsqlite3)
  333. (list '* int int64)))
  334. (bind-double (pointer->procedure
  335. int
  336. (dynamic-func "sqlite3_bind_double" libsqlite3)
  337. (list '* int double)))
  338. (bind-null (pointer->procedure
  339. int
  340. (dynamic-func "sqlite3_bind_null" libsqlite3)
  341. (list '* int)))
  342. (sqlite-transient (make-pointer
  343. (bit-extract (lognot 0) 0 (* 8 (sizeof '*))))))
  344. (lambda (stmt key val)
  345. (assert-live-stmt! stmt)
  346. (let ((idx (key->index stmt key))
  347. (p (stmt-pointer stmt)))
  348. (cond
  349. ((bytevector? val)
  350. (bind-blob p idx (bytevector->pointer val) (bytevector-length val)
  351. sqlite-transient))
  352. ((string? val)
  353. (let ((bv (string->utf8 val)))
  354. (bind-text p idx (bytevector->pointer bv) (bytevector-length bv)
  355. sqlite-transient)))
  356. ((and (integer? val) (exact? val))
  357. (bind-int64 p idx val))
  358. ((number? val)
  359. (bind-double p idx (exact->inexact val)))
  360. ((not val)
  361. (bind-null p idx))
  362. (else
  363. (error "unexpected value" val)))
  364. (check-error (stmt->db stmt))))))
  365. (define (sqlite-bind-arguments stmt . args)
  366. "Bind STMT parameters, one after another, to ARGS.
  367. Also bind named parameters to the respective ones."
  368. (let loop ((i 1)
  369. (args args))
  370. (match args
  371. (()
  372. #f)
  373. (((? keyword? kw) value . rest)
  374. (sqlite-bind stmt (keyword->symbol kw) value)
  375. (loop i rest))
  376. ((arg . rest)
  377. (sqlite-bind stmt i arg)
  378. (loop (+ 1 i) rest)))))
  379. (define sqlite-column-count
  380. (let ((column-count
  381. (pointer->procedure
  382. int
  383. (dynamic-pointer "sqlite3_column_count" libsqlite3)
  384. (list '*))))
  385. (lambda (stmt)
  386. (assert-live-stmt! stmt)
  387. (column-count (stmt-pointer stmt)))))
  388. (define sqlite-column-name
  389. (let ((column-name
  390. (pointer->procedure
  391. '*
  392. (dynamic-pointer "sqlite3_column_name" libsqlite3)
  393. (list '* int))))
  394. (lambda (stmt i)
  395. (assert-live-stmt! stmt)
  396. (utf8-pointer->string (column-name (stmt-pointer stmt) i)))))
  397. (define sqlite-column-value
  398. (let ((value-type
  399. (pointer->procedure
  400. int
  401. (dynamic-pointer "sqlite3_column_type" libsqlite3)
  402. (list '* int)))
  403. (value-int
  404. (pointer->procedure
  405. int64
  406. (dynamic-pointer "sqlite3_column_int64" libsqlite3)
  407. (list '* int)))
  408. (value-double
  409. (pointer->procedure
  410. double
  411. (dynamic-pointer "sqlite3_column_double" libsqlite3)
  412. (list '* int)))
  413. (value-text
  414. (pointer->procedure
  415. '*
  416. (dynamic-pointer "sqlite3_column_text" libsqlite3)
  417. (list '* int)))
  418. (value-blob
  419. (pointer->procedure
  420. '*
  421. (dynamic-pointer "sqlite3_column_blob" libsqlite3)
  422. (list '* int)))
  423. (value-bytes
  424. (pointer->procedure
  425. int
  426. (dynamic-pointer "sqlite3_column_bytes" libsqlite3)
  427. (list '* int))))
  428. (lambda (stmt i)
  429. (assert-live-stmt! stmt)
  430. (case (value-type (stmt-pointer stmt) i)
  431. ((1) ; SQLITE_INTEGER
  432. (value-int (stmt-pointer stmt) i))
  433. ((2) ; SQLITE_FLOAT
  434. (value-double (stmt-pointer stmt) i))
  435. ((3) ; SQLITE3_TEXT
  436. (let ((p (value-blob (stmt-pointer stmt) i)))
  437. (if (null-pointer? p)
  438. ""
  439. (utf8->string
  440. (pointer->bytevector p (value-bytes (stmt-pointer stmt) i))))))
  441. ((4) ; SQLITE_BLOB
  442. (let ((p (value-blob (stmt-pointer stmt) i)))
  443. (if (null-pointer? p)
  444. (make-bytevector 0)
  445. (pointer->bytevector p (value-bytes (stmt-pointer stmt) i)))))
  446. ((5) ; SQLITE_NULL
  447. #f)))))
  448. (define (sqlite-column-names stmt)
  449. (let ((v (make-vector (sqlite-column-count stmt))))
  450. (let lp ((i 0))
  451. (if (< i (vector-length v))
  452. (begin
  453. (vector-set! v i (sqlite-column-name stmt i))
  454. (lp (1+ i)))
  455. v))))
  456. (define (sqlite-row stmt)
  457. (let ((v (make-vector (sqlite-column-count stmt))))
  458. (let lp ((i 0))
  459. (if (< i (vector-length v))
  460. (begin
  461. (vector-set! v i (sqlite-column-value stmt i))
  462. (lp (1+ i)))
  463. v))))
  464. (define sqlite-step
  465. (let ((step (pointer->procedure
  466. int
  467. (dynamic-pointer "sqlite3_step" libsqlite3)
  468. (list '*))))
  469. (lambda (stmt)
  470. (assert-live-stmt! stmt)
  471. (let ((ret (step (stmt-pointer stmt))))
  472. (case ret
  473. ((100) ; SQLITE_ROW
  474. (sqlite-row stmt))
  475. ((101) ; SQLITE_DONE
  476. #f)
  477. (else
  478. (check-error (stmt->db stmt))
  479. (error "shouldn't get here")))))))
  480. (define (sqlite-fold kons knil stmt)
  481. (assert-live-stmt! stmt)
  482. (let lp ((seed knil))
  483. (let ((row (sqlite-step stmt)))
  484. (if row
  485. (lp (kons row seed))
  486. seed))))
  487. (define (sqlite-fold-right kons knil stmt)
  488. (assert-live-stmt! stmt)
  489. (let lp ()
  490. (let ((row (sqlite-step stmt)))
  491. (if row
  492. (kons row (lp))
  493. knil))))
  494. (define (sqlite-map proc stmt)
  495. (map proc
  496. (reverse! (sqlite-fold cons '() stmt))))