1 ;;; ffi-sqlite.el --- FFI for sqlite3.
3 ;; Copyright (C) 2008 by Zajcev Evgeny.
5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
6 ;; Created: Sat Nov 22 01:08:31 2008
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: Not in FSF
28 ;; Simple usage example:
30 ;; (setq db (sqlite-open "~/mtest.db"))
31 ;; ==> #<ffiobject type=pointer size=4 fotype=0 foptr=0xb6a6600>
32 ;; (sqlite-execute db "CREATE TABLE PARAMS
33 ;; (NAME VARCHAR(256) NULL, VALUE VARCHAR(1024) NULL)")
35 ;; (sqlite-execute db "INSERT INTO PARAMS (NAME,VALUE)
36 ;; VALUES (?, ?)" '("nthoteh" "HRCHRCCR"))
38 ;; (sqlite-rows db "select * from params")
39 ;; ==> (("nthoteh" "HRCHRCCR"))
43 ;; To create database in memory use (sqlite-open ":memory:")
47 ;; (defun Nfirst-collation (s1 s2)
48 ;; "S1 is less then S2 by length"
49 ;; (let ((l1 (length s1))
51 ;; (cond ((= l1 l2) 0)
55 ;; (sqlite-create-collation db "nfirst" 'Nfirst-collation)
57 ;; Then use 'nfirst' name in queries, like this
59 ;; (sqlite-rows db "select * from TABLE order by NAME collate nfirst")
64 ;; - Support for int64 columns
65 ;; - sqlite3_collation_needed implementation
66 ;; - Cached statements
71 (ffi-load-library "libsqlite3")
76 (define-ffi-type sqlite pointer)
77 (define-ffi-type sqlite-statement pointer)
79 (cffi:defcfun ("sqlite3_libversion" sqlite:version) c-string)
81 (cffi:defcfun ("sqlite3_open" sqlite:open-internal) int
82 (filename c-string) (db (pointer sqlite)))
84 (cffi:defcfun ("sqlite3_close" sqlite:close-internal) int
87 (cffi:defcfun ("sqlite3_prepare" sqlite:prepare) int
88 (db sqlite) (sql c-string) (bytes int)
89 (statement (pointer sqlite-statement))
90 (tail (pointer c-string)))
92 (cffi:defcfun ("sqlite3_step" sqlite:step) int
93 (statement sqlite-statement))
95 (cffi:defcfun ("sqlite3_finalize" sqlite:finalize) int
96 (statement sqlite-statement))
98 (cffi:defcfun ("sqlite3_errmsg" sqlite:errmsg) c-string
101 (cffi:defcfun ("sqlite3_errcode" sqlite:errcode) int
104 (cffi:defcfun ("sqlite3_changes" sqlite:changes) int
107 (cffi:defcfun ("sqlite3_get_table" sqlite:get-table) int
108 (db sqlite) (sql c-string) (result (pointer (pointer c-string)))
109 (rows (pointer int)) (cols (pointer int)) (errmsg (pointer c-string)))
111 (cffi:defcfun ("sqlite3_free_table" sqlite:free-table) void
112 (table (pointer c-string)))
114 (cffi:defcfun ("sqlite3_free" sqlite:free) void
117 ;; Number of columns implied by statement
118 (cffi:defcfun ("sqlite3_column_count" sqlite:column-count) int
119 (statement sqlite-statement))
121 ;; Number of columns actually present in this row
122 (cffi:defcfun ("sqlite3_data_count" sqlite:data-count) int
123 (statement sqlite-statement))
125 (cffi:defcfun ("sqlite3_reset" sqlite:reset) int
126 (statement sqlite-statement))
128 (cffi:defcfun ("sqlite3_column_type" sqlite:column-type) int
129 (statement sqlite-statement) (which int))
131 (cffi:defcfun ("sqlite3_column_int" sqlite:column-int) int
132 (statement sqlite-statement) (which int))
134 (cffi:defcfun ("sqlite3_column_double" sqlite:column-double) double
135 (statement sqlite-statement) (which int))
137 (cffi:defcfun ("sqlite3_column_text" sqlite:column-text) c-string
138 (statement sqlite-statement) (which int))
140 (cffi:defcfun ("sqlite3_column_blob" sqlite:column-blob) pointer
141 (statement sqlite-statement) (which int))
143 (cffi:defcfun ("sqlite3_column_bytes" sqlite:column-bytes) int
144 (statement sqlite-statement) (which int))
146 (cffi:defcfun ("sqlite3_column_name" sqlite:column-name) c-string
147 (statement sqlite-statement) (which int))
150 (cffi:defcfun ("sqlite3_bind_text" sqlite:bind-text) int
151 (statment sqlite-statement) (position int) (bound c-string)
152 (length int) (cleanup int))
154 (cffi:defcfun ("sqlite3_bind_null" sqlite:bind-null) int
155 (statement sqlite-statement)
158 (cffi:defcfun ("sqlite3_bind_int" sqlite:bind-int) int
159 (statement sqlite-statement)
163 (cffi:defcfun ("sqlite3_bind_double" sqlite:bind-double) int
164 (statement sqlite-statement) (position int) (bound double))
166 (cffi:defcfun ("sqlite3_bind_blob" sqlite:bind-blob) int
167 (statement sqlite-statement) (position int)
168 (bound pointer) (length int) (cleanup int))
170 (cffi:defcfun ("sqlite3_bind_parameter_count"
171 sqlite:bind-parameter-count) int
172 (statement sqlite-statement))
174 (cffi:defcfun ("sqlite3_bind_parameter_index"
175 sqlite:bind-parameter-index) int
176 (statement sqlite-statement) (column c-string))
178 (cffi:defcfun ("sqlite3_bind_parameter_name"
179 sqlite:bind-parameter-name) c-string
180 (statement sqlite-statement)
183 (cffi:defcfun ("sqlite3_create_collation" sqlite:create-collation) int
184 (db sqlite) (name c-string) (e-text-rep int)
185 (user-data pointer) (callback pointer))
193 (defconst sqlite-STATIC 0)
194 (defconst sqlite-TRANSIENT -1)
195 (defconst sqlite-UTF-8 1
196 "Used as e-text-rep argument to `sqlite:create-collation'.")
198 (defconst sqlite-ROW 100 "Sqlite_step() has another row ready.")
199 (defconst sqlite-DONE 101 "Sqlite_step() has finished executing.")
202 ;;{{{ Errors handling
204 (defconst sqlite-error-codes
205 '((1 sqlite-error "SQL error or missing database")
206 (2 sqlite-internal "An internal logic error in SQLite")
207 (3 sqlite-perm "Access permission denied")
208 (4 sqlite-abort "Callback routine requested an abort")
209 (5 sqlite-busy "The database file is locked")
210 (6 sqlite-locked "A table in the database is locked")
211 (7 sqlite-nomem "A malloc() failed")
212 (8 sqlite-readonly "Attempt to write a readonly database")
213 (9 sqlite-interrupt "Operation terminated by sqlite_interrupt()")
214 (10 sqlite-ioerr "Some kind of disk I/O error occurred")
215 (11 sqlite-corrupt "The database disk image is malformed")
216 (13 sqlite-full "Insertion failed because database is full")
217 (14 sqlite-cantopen "Unable to open the database file")
218 (15 sqlite-protocol "Database lock protocol error")
219 (17 sqlite-schema "The database schema changed")
220 (18 sqlite-toobig "Too much data for one row of a table")
221 (19 sqlite-constraint "Abort due to constraint violation")
222 (20 sqlite-mismatch "Data type mismatch")
223 (21 sqlite-misuse "Library used incorrectly")
224 (22 sqlite-nolfs "Uses OS features not supported on host")
225 (23 sqlite-auth "Authorization denied"))
226 "Error codes hash table for sqlite.")
228 (define-error 'sqlite-error "SQLite error")
229 (define-error 'sqlite-sql-error "SQLite SQL error")
230 (define-error 'sqlite-datatype-error "SQLite datatype error")
232 (defun sqlite-check-result (result error)
233 "Signall an error if RESULT is not good enough.
234 ERROR is message to be signaled."
235 (let ((tuple (cdr (assq result sqlite-error-codes))))
236 (cond ((and tuple (eq (first tuple) 'sqlite-error))
237 (error 'sqlite-sql-error (if (equal error "not an error") "" error)
238 :code 1 :name (first tuple)
239 :comment (second tuple)))
241 (error 'sqlite-error error
242 :code result :name (first tuple) :comment (second tuple)))
246 ;;{{{ Open/close database
248 (defvar sqlite-databases nil
249 "List of currently onen databases.")
252 (defun sqlite-file-p (filename)
253 "Return non-nil if FILENAME is actually SQLite format 3 file."
254 ;; Unfortunately `magic:file-type' does not recognizes SQLite files,
257 (insert-file-contents-literally filename nil 0 15)
258 (string= (buffer-substring) "SQLite format 3")))
261 (defun sqlite-open (file)
262 "Try to open SQLite dabase stored in FILE.
263 On success return database object."
264 (let* ((db (make-ffi-object 'sqlite))
265 (result (sqlite:open-internal
266 (expand-file-name file) (ffi-address-of db)))
267 (retdb (ffi-get db)))
268 (sqlite-check-result result (sqlite:errmsg retdb))
269 (push retdb sqlite-databases)
272 (defun sqlite-close (db)
273 "Close SQLite database associated with DB."
274 (setq sqlite-databases (delq db sqlite-databases))
276 (sqlite:close-internal db) (sqlite:errmsg db)))
279 ;;{{{ Statement operations: binding, fetching
281 (defun sqlite-column-names (statement)
282 "For STATEMENT get list of column names."
283 (loop for i from 0 below (sqlite:column-count statement)
284 collect (sqlite:column-name statement i)))
286 (defun sqlite-prepare (db sql)
287 "For DB prepare statement for given SQL."
288 (let ((stat (make-ffi-object 'sqlite-statement))
289 (tail (make-ffi-object 'pointer)))
291 (sqlite:prepare db sql (length sql)
292 (ffi-address-of stat)
293 (ffi-address-of tail))
297 (defun sqlite-bind-value (statement key-object value &optional copy-flag)
298 "Take a STATEMENT pointer, a KEY-OBJECT and bind VALUE to it.
299 KEY-OBJECT should be an integer position or a symbol or a string.
300 Optional COPY-FLAG is one of `sqlite-STATIC' or `sqlite-TRANSIENT'
301 \(the default one\). You must know exactly what you are doing if you
302 provide COPY-FLAG argument."
303 (let ((key (if (integerp key-object)
305 (sqlite:bind-parameter-index
307 (if (symbolp key-object)
308 (concat ":" (symbol-name key-object))
311 (cond ((null value) (sqlite:bind-null statement key))
313 (sqlite:bind-int statement key value))
315 (sqlite:bind-double statement key value))
317 (sqlite:bind-text statement key value (length value)
318 (or copy-flag sqlite-STATIC)))
319 ((and (consp value) (eq (car value) 'blob)
320 (stringp (cdr value)))
321 (let ((bval (ffi-create-fo `(c-data . ,(length (cdr value)))
324 statement key bval (length (cdr value))
325 (or copy-flag sqlite-STATIC))))
326 (t (error 'sqlite-datatype-error value
327 :comment (concat "Attempt to insert data not one of "
328 "integer, float, text, or blob."))))
331 (defun sqlite-bind-seq (statement sequence)
332 "For STATEMENT bind each value in SEQUENCE."
333 (dotimes (i (length sequence))
334 (sqlite-bind-value statement (1+ i) (elt sequence i))))
336 (defun sqlite-bind-plist (statement plist)
337 "For STATEMENT bind values in PLIST."
338 (loop for (key val) on plist by #'cddr
339 do (sqlite-bind-value statement key val)))
341 (defun sqlite-bind (statement binding)
342 "For STATEMENT perform BINDING.
343 BINDING could be plist, list or vector."
345 (cond ((and (listp binding) (keywordp (car binding)))
346 (sqlite-bind-plist statement binding))
347 ((or (vectorp binding) (listp binding))
348 (sqlite-bind-seq statement binding)))
351 (defun sqlite-fetch-column (statement index)
352 "For STATEMENT fetch data from column INDEX.
353 There is currently no way to specify a casting operation."
354 ;; INTEGER==1,FLOAT==2,TEXT==3,BLOB==4,NULL==5
355 (case (sqlite:column-type statement index)
356 (1 (sqlite:column-int statement index))
357 (2 (sqlite:column-double statement index))
358 (3 (sqlite:column-text statement index))
359 (4 (let ((blob (sqlite:column-blob statement index))
360 (blen (sqlite:column-bytes statement index)))
361 (ffi-get blob :type (cons 'c-data blen))))
364 (defun sqlite-fetch (statement)
365 "For STATEMENT return vector containing all the columns.
366 nil is returned for empty row."
367 (when (= sqlite-ROW (sqlite:step statement))
368 (let ((cols (sqlite:column-count statement)))
369 (loop for i from 0 below cols
370 collect (sqlite-fetch-column statement i)))))
372 (defun sqlite-reset (statement &optional clear-bindings)
373 "Reset STATEMENT, so it could be used again.
374 If CLEAR-BINDINGS is specified also clear all bound variables."
375 (sqlite:reset statement)
378 statement (make-list (sqlite:bind-parameter-count statement) nil)))
381 (defun sqlite-flush (statement)
382 "Clean up a prepared STATEMENT.
383 DO NOT use STATEMENT after."
384 (sqlite:finalize statement))
389 (defun sqlite-begin-transaction (db &optional type)
390 "Begin transaction for DB.
395 Default is deffered."
396 (let ((ttype (multiple-value-bind (major minor sub)
397 (mapcar 'string-to-int
398 (split-string-by-char (sqlite:version) ?\.))
399 (setq major major) ; shut up compiler
400 (if (or (>= minor 0) (>= sub 8))
401 (cond ((eq type 'exclusive) " exclusive ")
402 ((eq type 'immediate) " immediate ")
405 (sqlite-execute db (concat "begin" ttype "transaction;") :begin nil)))
407 (defun sqlite-commit (db)
408 "For DB commit transaction."
409 (sqlite-execute db "commit transaction;" :begin nil))
411 (defun sqlite-rollback (db)
412 "For DB roll back transaction."
413 (sqlite-execute db "rollback transaction;" :begin nil))
415 (defmacro* sqlite-with-transaction ((database &optional type) &body body)
416 (let ((db-err (gensym "dberror"))
417 (db-obj (gensym "dbobject")))
418 `(let ((,db-obj ,database)
420 (sqlite-begin-transaction ,db-obj ,type)
426 (sqlite-rollback ,db-obj)
427 (sqlite-commit ,db-obj))))))
428 (put 'sqlite-with-transaction 'lisp-indent-function 'defun)
431 ;;{{{ execute, mapcar, rows
433 (defmacro* sqlite-with-prep ((statement-var db sql &optional bind) &body body)
434 (let ((db-obj (gensym "dbobject"))
435 (sql-in (gensym "sqlin"))
436 (bind-in (gensym "bindin")))
437 `(let* ((,db-obj ,db)
440 (,statement-var (sqlite-prepare ,db-obj ,sql-in)))
443 (sqlite-bind ,statement-var ,bind-in)
445 (sqlite-flush ,statement-var)))))
446 (put 'sqlite-with-prep 'lisp-indent-function 'defun)
448 (defun sqlite-execute (db sql &optional bind begin)
449 "For DB execute SQL query.
450 Use this for queries with no return results.
451 BIND specifies bindings for SQL query.
452 If BEGIN is given, then perform a transaction."
454 (sqlite-with-transaction (db)
455 (sqlite-with-prep (st db sql bind)
456 (sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
458 (sqlite-with-prep (st db sql bind)
459 (sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
462 (defun sqlite-mapcar (db function sql &optional bind)
463 "For DB apply FUNCTION to results of SQL query execution.
464 BIND specifies bindings list for SQL query.
465 FUNCTION must take at least as many arguments as values in row."
466 (sqlite-with-prep (statement db sql bind)
468 while (setq row (sqlite-fetch statement))
469 collect (apply function row))))
471 (defun sqlite-rows (db sql &optional bind)
472 "For DB return list of rows after executing SQL query.
473 BIND specifies bindings for SQL query."
474 (sqlite-mapcar db #'list sql bind))
477 ;;{{{ Custom collations
480 (define-ffi-callback sqlite-generic-collation 'int
481 ((user-data 'pointer) (len1 'int) (str1 'pointer)
482 (len2 'int) (str2 'pointer))
483 (let ((fun (ffi-pointer-to-lisp-object user-data))
484 (s1 (ffi-get str1 :type (cons 'c-data len1)))
485 (s2 (ffi-get str2 :type (cons 'c-data len2))))
486 (funcall fun s1 s2))))
488 (defun sqlite-create-collation (db name compare-function)
489 "For DB register new collation named NAME.
490 COMPARE-FUNCTION must get exactly two string arguments and return:
491 -1 if first string is less then second
492 0 if strings are equal
493 1 if first string is greater then second.
495 Currently, this is only available on i386."
496 (if (not (boundp 'sqlite-generic-collation))
497 (error 'unimplemented 'ffi-make-callback
498 "for this architecture")
499 (let* ((ccolls (get db 'custom-collations))
500 (colla (assoc name ccolls)))
502 (setcdr colla compare-function)
503 (put db 'custom-collations
504 (cons (cons name compare-function) ccolls))))
506 (sqlite:create-collation
508 (ffi-lisp-object-to-pointer compare-function)
509 (ffi-callback-fo 'sqlite-generic-collation))
510 (sqlite:errmsg db))))
512 (defun sqlite-remove-collation (db name)
513 "For DB remove collation by NAME."
514 (let* ((ccolls (get db 'custom-collations))
515 (colla (assoc name ccolls)))
518 (sqlite:create-collation
520 (ffi-lisp-object-to-pointer (cdr colla))
523 ;; Remove it from custom-collations
524 (put db 'custom-collations (del-alist name ccolls))
529 (provide 'ffi-sqlite)
531 ;;; ffi-sqlite.el ends here