1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: sqlite-api-uffi.lisp
6 ;;;; Purpose: Low-level SQLite interface using UFFI
7 ;;;; Authors: Aurelio Bignoli and Kevin Rosenberg
12 ;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
13 ;;;; and Copyright (c) 2003-2004 by Kevin Rosenberg
15 ;;;; CLSQL users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;; *************************************************************************
20 (in-package #:cl-user
)
23 (:use
#:common-lisp
#:uffi
)
28 #:sqlite-error-message
42 #:sqlite-version
; Defined as constant.
43 #:sqlite-encoding
; Defined as constant.
44 #:sqlite-last-insert-rowid
46 ;;; Utility functions.
57 #:sqlite-row-pointer-type
62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
64 ;;;; Return values for sqlite_exec() and sqlite_step()
66 (defconstant SQLITE-OK
0 "Successful result")
67 (defconstant SQLITE-ERROR
1 "SQL error or missing database")
68 (defconstant SQLITE-ROW
100 "sqlite_step() has another row ready")
69 (defconstant SQLITE-DONE
101 "sqlite_step() has finished executing")
71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75 (define-condition sqlite-error
()
76 ((message :initarg
:message
:reader sqlite-error-message
:initform
"")
77 (code :initarg
:code
:reader sqlite-error-code
))
78 (:report
(lambda (condition stream
)
79 (let ((code (sqlite-error-code condition
)))
80 (format stream
"SQLite error [~A]: ~A"
81 code
(sqlite-error-message condition
))))))
83 (defun signal-sqlite-error (code &optional message
)
85 (make-condition 'sqlite-error
89 (uffi:convert-from-cstring
90 (sqlite-error-string code
))))))
91 (unless (signal condition
)
92 (invoke-debugger condition
))))
94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96 ;;;; Foreign types definitions.
98 (def-foreign-type errmsg
(* :unsigned-char
))
99 (def-foreign-type sqlite-db
:pointer-void
)
100 (def-foreign-type sqlite-vm
:pointer-void
)
101 (def-foreign-type string-pointer
(* (* :unsigned-char
)))
102 (def-foreign-type sqlite-row-pointer
(* (* :unsigned-char
)))
104 (defvar +null-errmsg-pointer
+ (make-null-pointer 'errmsg
))
105 (defvar +null-string-pointer-pointer
+ (make-null-pointer 'string-pointer
))
108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
110 ;;; Lisp types used in declarations.
112 (def-type sqlite-db-type sqlite-db
)
113 (def-type sqlite-row string-pointer
)
114 (def-type sqlite-row-pointer-type
(* string-pointer
))
115 (def-type sqlite-vm-pointer
(* sqlite-vm
))
117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119 ;;;; Library functions.
121 (defmacro def-sqlite-function
(name args
&key
(returning :void
))
122 `(def-function ,name
,args
124 :returning
,returning
))
127 "sqlite_error_string"
131 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
135 (declaim (inline %open
))
137 ("sqlite_open" %open
)
140 (error-message (* errmsg
)))
141 :returning sqlite-db
)
143 (declaim (inline sqlite-close
))
148 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
152 (declaim (inline %compile
))
154 ("sqlite_compile" %compile
)
157 (sql-tail (* (* :unsigned-char
)))
159 (error-message (* errmsg
)))
162 (declaim (inline %step
))
164 ("sqlite_step" %step
)
167 (cols (* (* (* :unsigned-char
))))
168 (col-names (* (* (* :unsigned-char
)))))
171 (declaim (inline %finalize
))
173 ("sqlite_finalize" %finalize
)
175 (error-message (* errmsg
)))
178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
182 (declaim (inline sqlite-last-insert-rowid
))
184 "sqlite_last_insert_rowid"
188 (declaim (inline %get-table
))
190 ("sqlite_get_table" %get-table
)
193 (result (* (* (* :unsigned-char
))))
196 (error-message (* errmsg
)))
199 (declaim (inline %free-table
))
201 ("sqlite_free_table" %free-table
)
202 ((rows :pointer-void
)))
204 (declaim (inline sqlite-libversion
))
210 (declaim (inline sqlite-libencoding
))
216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
218 ;;;; Wrapper functions.
220 (defparameter sqlite-version
(sqlite-libversion))
221 (defparameter sqlite-encoding
(sqlite-libencoding))
223 (defun sqlite-open (db-name &optional
(mode 0))
224 (with-cstring (db-name-native db-name
)
225 (let ((db (%open db-name-native mode
+null-errmsg-pointer
+)))
226 (if (null-pointer-p db
)
227 (signal-sqlite-error SQLITE-ERROR
228 (format nil
"unable to open ~A" db-name
))
231 (defun sqlite-compile (db sql
)
232 (with-cstring (sql-native sql
)
233 (let ((vm (allocate-foreign-object 'sqlite-vm
)))
234 (with-foreign-object (sql-tail '(* :unsigned-char
))
235 (let ((result (%compile db sql-native sql-tail vm
+null-errmsg-pointer
+)))
236 (if (= result SQLITE-OK
)
239 (free-foreign-object vm
)
240 (signal-sqlite-error result
))))))))
242 (defun sqlite-step (vm)
243 (declare (type sqlite-vm-pointer vm
))
244 (with-foreign-object (cols-n :int
)
245 (let ((cols (allocate-foreign-object '(* (* :unsigned-char
))))
246 (col-names (allocate-foreign-object '(* (* :unsigned-char
)))))
247 (declare (type sqlite-row-pointer-type cols col-names
))
248 (let ((result (%step
(deref-pointer vm
'sqlite-vm
)
249 cols-n cols col-names
)))
251 ((= result SQLITE-ROW
)
252 (let ((n (deref-pointer cols-n
:int
)))
253 (values n cols col-names
)))
254 ((= result SQLITE-DONE
)
255 (free-foreign-object cols
)
256 (free-foreign-object col-names
)
257 (values 0 +null-string-pointer-pointer
+ +null-string-pointer-pointer
+))
259 (free-foreign-object cols
)
260 (free-foreign-object col-names
)
261 (signal-sqlite-error result
)))))))
263 (defun sqlite-finalize (vm)
264 (declare (type sqlite-vm-pointer vm
))
265 (let ((result (%finalize
(deref-pointer vm
'sqlite-vm
) +null-errmsg-pointer
+)))
266 (if (= result SQLITE-OK
)
268 (free-foreign-object vm
)
270 (signal-sqlite-error result
))))
272 (defun sqlite-get-table (db sql
)
273 (declare (type sqlite-db-type db
))
274 (with-cstring (sql-native sql
)
275 (let ((rows (allocate-foreign-object '(* (* :unsigned-char
)))))
276 (declare (type sqlite-row-pointer-type rows
))
277 (with-foreign-object (rows-n :int
)
278 (with-foreign-object (cols-n :int
)
279 (let ((result (%get-table db sql-native rows rows-n cols-n
+null-errmsg-pointer
+)))
280 (if (= result SQLITE-OK
)
281 (let ((cn (deref-pointer cols-n
:int
))
282 (rn (deref-pointer rows-n
:int
)))
285 (free-foreign-object rows
)
286 (signal-sqlite-error result
)))))))))
288 (declaim (inline sqlite-free-table
))
289 (defun sqlite-free-table (table)
290 (declare (type sqlite-row-pointer-type table
))
291 (%free-table
(deref-pointer table
'sqlite-row-pointer
)))
293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
295 ;;;; Utility functions.
297 (declaim (inline make-null-row
))
298 (defun make-null-row ()
299 +null-string-pointer-pointer
+)
301 (declaim (inline make-null-vm
))
302 (defun make-null-vm ()
303 (uffi:make-null-pointer
'sqlite-vm
))
305 (declaim (inline null-row-p
))
306 (defun null-row-p (row)
307 (null-pointer-p row
))
309 (declaim (inline sqlite-aref
))
310 (defun sqlite-aref (a n
)
311 (declare (type sqlite-row-pointer-type a
))
312 (convert-from-foreign-string
313 (deref-array (deref-pointer a
'sqlite-row-pointer
) '(:array
(* :unsigned-char
)) n
)))
315 (declaim (inline sqlite-raw-aref
))
316 (defun sqlite-raw-aref (a n
)
317 (declare (type sqlite-row-pointer-type a
))
318 (deref-array (deref-pointer a
'sqlite-row-pointer
) '(:array
(* :unsigned-char
)) n
))
320 (declaim (inline sqlite-free-row
))
321 (defun sqlite-free-row (row)
322 (declare (type sqlite-row-pointer-type row
))
323 (free-foreign-object row
))