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))