sqlite3.scm.in 19 KB

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