;; ==> 0
;;
;; To create database in memory use (sqlite-open ":memory:")
-;;
+;;
;; Custom collations:
;;
;; (defun Nfirst-collation (s1 s2)
(bound pointer) (length int) (cleanup int))
(cffi:defcfun ("sqlite3_bind_parameter_count"
- sqlite:bind-parameter-count) int
+ sqlite:bind-parameter-count) int
(statement sqlite-statement))
(cffi:defcfun ("sqlite3_bind_parameter_index"
- sqlite:bind-parameter-index) int
+ sqlite:bind-parameter-index) int
(statement sqlite-statement) (column c-string))
(cffi:defcfun ("sqlite3_bind_parameter_name"
- sqlite:bind-parameter-name) c-string
+ sqlite:bind-parameter-name) c-string
(statement sqlite-statement)
(position int))
ERROR is message to be signaled."
(let ((tuple (cdr (assq result sqlite-error-codes))))
(cond ((and tuple (eq (first tuple) 'sqlite-error))
- (error 'sqlite-sql-error (if (equal error "not an error") "" error)
- :code 1 :name (first tuple)
- :comment (second tuple)))
- (tuple
- (error 'sqlite-error error
- :code result :name (first tuple) :comment (second tuple)))
- (t result))))
+ (error 'sqlite-sql-error (if (equal error "not an error") "" error)
+ :code 1 :name (first tuple)
+ :comment (second tuple)))
+ (tuple
+ (error 'sqlite-error error
+ :code result :name (first tuple) :comment (second tuple)))
+ (t result))))
;;}}}
;;{{{ Open/close database
"Try to open SQLite dabase stored in FILE.
On success return database object."
(let* ((db (make-ffi-object 'sqlite))
- (result (sqlite:open-internal
- (expand-file-name file) (ffi-address-of db)))
- (retdb (ffi-get db)))
+ (result (sqlite:open-internal
+ (expand-file-name file) (ffi-address-of db)))
+ (retdb (ffi-get db)))
(sqlite-check-result result (sqlite:errmsg retdb))
(push retdb sqlite-databases)
retdb))
(defun sqlite-prepare (db sql)
"For DB prepare statement for given SQL."
(let ((stat (make-ffi-object 'sqlite-statement))
- (tail (make-ffi-object 'pointer)))
+ (tail (make-ffi-object 'pointer)))
(sqlite-check-result
(sqlite:prepare db sql (length sql)
- (ffi-address-of stat)
- (ffi-address-of tail))
+ (ffi-address-of stat)
+ (ffi-address-of tail))
(sqlite:errmsg db))
(ffi-get stat)))
\(the default one\). You must know exactly what you are doing if you
provide COPY-FLAG argument."
(let ((key (if (integerp key-object)
- key-object
- (sqlite:bind-parameter-index
- statement
- (if (symbolp key-object)
- (concat ":" (symbol-name key-object))
- key-object)))))
+ key-object
+ (sqlite:bind-parameter-index
+ statement
+ (if (symbolp key-object)
+ (concat ":" (symbol-name key-object))
+ key-object)))))
(when key
(cond ((null value) (sqlite:bind-null statement key))
- ((integerp value)
- (sqlite:bind-int statement key value))
- ((floatp value)
- (sqlite:bind-double statement key value))
- ((stringp value)
- (sqlite:bind-text statement key value (length value)
- (or copy-flag sqlite-STATIC)))
- ((and (consp value) (eq (car value) 'blob)
- (stringp (cdr value)))
- (let ((bval (ffi-create-fo `(c-data . ,(length (cdr value)))
- (cdr value))))
- (sqlite:bind-blob
- statement key bval (length (cdr value))
- (or copy-flag sqlite-STATIC))))
- (t (error 'sqlite-datatype-error value
- :comment (concat "Attempt to insert data not one of "
- "integer, float, text, or blob."))))
+ ((integerp value)
+ (sqlite:bind-int statement key value))
+ ((floatp value)
+ (sqlite:bind-double statement key value))
+ ((stringp value)
+ (sqlite:bind-text statement key value (length value)
+ (or copy-flag sqlite-STATIC)))
+ ((and (consp value) (eq (car value) 'blob)
+ (stringp (cdr value)))
+ (let ((bval (ffi-create-fo `(c-data . ,(length (cdr value)))
+ (cdr value))))
+ (sqlite:bind-blob
+ statement key bval (length (cdr value))
+ (or copy-flag sqlite-STATIC))))
+ (t (error 'sqlite-datatype-error value
+ :comment (concat "Attempt to insert data not one of "
+ "integer, float, text, or blob."))))
)))
(defun sqlite-bind-seq (statement sequence)
BINDING could be plist, list or vector."
(when binding
(cond ((and (listp binding) (keywordp (car binding)))
- (sqlite-bind-plist statement binding))
- ((or (vectorp binding) (listp binding))
- (sqlite-bind-seq statement binding)))
+ (sqlite-bind-plist statement binding))
+ ((or (vectorp binding) (listp binding))
+ (sqlite-bind-seq statement binding)))
t))
(defun sqlite-fetch-column (statement index)
(2 (sqlite:column-double statement index))
(3 (sqlite:column-text statement index))
(4 (let ((blob (sqlite:column-blob statement index))
- (blen (sqlite:column-bytes statement index)))
- (ffi-get blob :type (cons 'c-data blen))))
+ (blen (sqlite:column-bytes statement index)))
+ (ffi-get blob :type (cons 'c-data blen))))
(5 nil)))
(defun sqlite-fetch (statement)
(when (= sqlite-ROW (sqlite:step statement))
(let ((cols (sqlite:column-count statement)))
(loop for i from 0 below cols
- collect (sqlite-fetch-column statement i)))))
+ collect (sqlite-fetch-column statement i)))))
(defun sqlite-reset (statement &optional clear-bindings)
"Reset STATEMENT, so it could be used again.
'immediate
Default is deffered."
(let ((ttype (multiple-value-bind (major minor sub)
- (mapcar 'string-to-int
- (split-string-by-char (sqlite:version) ?\.))
- (setq major major) ; shut up compiler
- (if (or (>= minor 0) (>= sub 8))
- (cond ((eq type 'exclusive) " exclusive ")
- ((eq type 'immediate) " immediate ")
- (t " "))
- " "))))
+ (mapcar 'string-to-int
+ (split-string-by-char (sqlite:version) ?\.))
+ (setq major major) ; shut up compiler
+ (if (or (>= minor 0) (>= sub 8))
+ (cond ((eq type 'exclusive) " exclusive ")
+ ((eq type 'immediate) " immediate ")
+ (t " "))
+ " "))))
(sqlite-execute db (concat "begin" ttype "transaction;") :begin nil)))
(defun sqlite-commit (db)
(defmacro* sqlite-with-transaction ((database &optional type) &body body)
(let ((db-err (gensym "dberror"))
- (db-obj (gensym "dbobject")))
+ (db-obj (gensym "dbobject")))
`(let ((,db-obj ,database)
- (,db-err t))
+ (,db-err t))
(sqlite-begin-transaction ,db-obj ,type)
(unwind-protect
- (prog1
- (progn ,@body)
- (setq ,db-err nil))
- (if ,db-err
- (sqlite-rollback ,db-obj)
- (sqlite-commit ,db-obj))))))
+ (prog1
+ (progn ,@body)
+ (setq ,db-err nil))
+ (if ,db-err
+ (sqlite-rollback ,db-obj)
+ (sqlite-commit ,db-obj))))))
(put 'sqlite-with-transaction 'lisp-indent-function 'defun)
;;}}}
(defmacro* sqlite-with-prep ((statement-var db sql &optional bind) &body body)
(let ((db-obj (gensym "dbobject"))
- (sql-in (gensym "sqlin"))
- (bind-in (gensym "bindin")))
+ (sql-in (gensym "sqlin"))
+ (bind-in (gensym "bindin")))
`(let* ((,db-obj ,db)
- (,sql-in ,sql)
- (,bind-in ,bind)
- (,statement-var (sqlite-prepare ,db-obj ,sql-in)))
+ (,sql-in ,sql)
+ (,bind-in ,bind)
+ (,statement-var (sqlite-prepare ,db-obj ,sql-in)))
(unwind-protect
- (progn
- (sqlite-bind ,statement-var ,bind-in)
- ,@body)
- (sqlite-flush ,statement-var)))))
+ (progn
+ (sqlite-bind ,statement-var ,bind-in)
+ ,@body)
+ (sqlite-flush ,statement-var)))))
(put 'sqlite-with-prep 'lisp-indent-function 'defun)
(defun sqlite-execute (db sql &optional bind begin)
If BEGIN is given, then perform a transaction."
(if begin
(sqlite-with-transaction (db)
- (sqlite-with-prep (st db sql bind)
- (sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
- t))
+ (sqlite-with-prep (st db sql bind)
+ (sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
+ t))
(sqlite-with-prep (st db sql bind)
(sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
t)))
;;}}}
;;{{{ Custom collations
-(define-ffi-callback sqlite-generic-collation 'int
- ((user-data 'pointer) (len1 'int) (str1 'pointer)
- (len2 'int) (str2 'pointer))
- (let ((fun (ffi-pointer-to-lisp-object user-data))
- (s1 (ffi-get str1 :type (cons 'c-data len1)))
- (s2 (ffi-get str2 :type (cons 'c-data len2))))
- (funcall fun s1 s2)))
+(ignore-errors
+ (define-ffi-callback sqlite-generic-collation 'int
+ ((user-data 'pointer) (len1 'int) (str1 'pointer)
+ (len2 'int) (str2 'pointer))
+ (let ((fun (ffi-pointer-to-lisp-object user-data))
+ (s1 (ffi-get str1 :type (cons 'c-data len1)))
+ (s2 (ffi-get str2 :type (cons 'c-data len2))))
+ (funcall fun s1 s2))))
(defun sqlite-create-collation (db name compare-function)
"For DB register new collation named NAME.
COMPARE-FUNCTION must get exactly two string arguments and return:
-1 if first string is less then second
0 if strings are equal
- 1 if first string is greater then second"
- (let* ((ccolls (get db 'custom-collations))
- (colla (assoc name ccolls)))
- (if colla
- (setcdr colla compare-function)
- (put db 'custom-collations
- (cons (cons name compare-function) ccolls))))
- (sqlite-check-result
- (sqlite:create-collation
- db name sqlite-UTF-8
- (ffi-lisp-object-to-pointer compare-function)
- (ffi-callback-fo 'sqlite-generic-collation))
- (sqlite:errmsg db)))
+ 1 if first string is greater then second.
+
+Currently, this is only available on i386."
+ (if (not (boundp 'sqlite-generic-collation))
+ (error 'unimplemented 'ffi-make-callback
+ "for this architecture")
+ (let* ((ccolls (get db 'custom-collations))
+ (colla (assoc name ccolls)))
+ (if colla
+ (setcdr colla compare-function)
+ (put db 'custom-collations
+ (cons (cons name compare-function) ccolls))))
+ (sqlite-check-result
+ (sqlite:create-collation
+ db name sqlite-UTF-8
+ (ffi-lisp-object-to-pointer compare-function)
+ (ffi-callback-fo 'sqlite-generic-collation))
+ (sqlite:errmsg db))))
(defun sqlite-remove-collation (db name)
"For DB remove collation by NAME."
(let* ((ccolls (get db 'custom-collations))
- (colla (assoc name ccolls)))
+ (colla (assoc name ccolls)))
(when colla
(sqlite-check-result
(sqlite:create-collation
- db name sqlite-UTF-8
- (ffi-lisp-object-to-pointer (cdr colla))
- (ffi-null-pointer))
+ db name sqlite-UTF-8
+ (ffi-lisp-object-to-pointer (cdr colla))
+ (ffi-null-pointer))
(sqlite:errmsg db))
;; Remove it from custom-collations
(put db 'custom-collations (del-alist name ccolls))
t)))
;;}}}
-
+
(provide 'ffi-sqlite)
;;; ffi-sqlite.el ends here
projects / sxemacs / blobdiff