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 ;;;; Programmers: Aurelio Bignoli and Kevin Rosenberg
8 ;;;; Date Started: Nov 2003
10 ;;;; $Id: sqlite-api-uffi.lisp,v 1.5 2004/03/09 20:57:19 aurelio Exp $
12 ;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
14 ;;;; CLSQL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
20 ;;; NOTE: Upon reviewing the code, I found this is not UFFI compatible.
21 ;;; it appears to work on CMUCL, but does not work correctly on Lispworks
22 ;;; and Allegro. Mostly, the processing of return strings is still incorrect
24 ;;; To fix this will require reading the SQLite API and reworking the
28 (in-package #:cl-user)
31 (:use #:common-lisp #:uffi)
36 #:sqlite-error-message
50 #:sqlite-version ; Defined as constant.
51 #:sqlite-encoding ; Defined as constant.
52 #:sqlite-last-insert-rowid
54 ;;; Utility functions.
68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70 ;;;; Return values for sqlite_exec() and sqlite_step()
72 (defconstant SQLITE-OK 0 "Successful result")
73 (defconstant SQLITE-ERROR 1 "SQL error or missing database")
74 (defconstant SQLITE-ROW 100 "sqlite_step() has another row ready")
75 (defconstant SQLITE-DONE 101 "sqlite_step() has finished executing")
77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
81 (define-condition sqlite-error ()
82 ((message :initarg :message :reader sqlite-error-message :initform "")
83 (code :initarg :code :reader sqlite-error-code))
84 (:report (lambda (condition stream)
85 (let ((code (sqlite-error-code condition)))
86 (format stream "SQLite error [~A]: ~A"
87 code (sqlite-error-message condition))))))
89 (defun signal-sqlite-error (code &optional message)
91 (make-condition 'sqlite-error
95 (sqlite-error-string code)))))
96 (unless (signal condition)
97 (invoke-debugger condition))))
99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
101 ;;;; Foreign types definitions.
103 (def-foreign-type sqlite-db :pointer-void)
104 (def-foreign-type sqlite-vm :pointer-void)
105 (def-foreign-type errmsg :cstring)
107 (def-array-pointer string-array-pointer :cstring)
109 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111 ;;; Lisp types used in declarations.
113 (def-type sqlite-db-pointer (* sqlite-db))
114 (def-type sqlite-int-pointer (* :int))
115 (def-type sqlite-row string-array-pointer)
116 (def-type sqlite-row-pointer (* string-array-pointer))
117 (def-type sqlite-vm-pointer (* sqlite-vm))
119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121 ;;;; Library functions.
123 (defmacro def-sqlite-function (name args &key (returning :void))
124 `(def-function ,name ,args
126 :returning ,returning))
129 "sqlite_error_string"
133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
137 (declaim (inline %open))
139 ("sqlite_open" %open)
142 (error-message (* errmsg)))
143 :returning sqlite-db)
145 (declaim (inline sqlite-close))
150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 (declaim (inline %compile))
156 ("sqlite_compile" %compile)
159 (sql-tail (* (* :char)))
161 (error-message (* errmsg)))
164 (declaim (inline %step))
166 ("sqlite_step" %step)
170 (col-names (* (* :char))))
173 (declaim (inline %finalize))
175 ("sqlite_finalize" %finalize)
177 (error-message (* errmsg)))
180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
184 (declaim (inline sqlite-last-insert-rowid))
186 "sqlite_last_insert_rowid"
190 (declaim (inline %get-table))
192 ("sqlite_get_table" %get-table)
195 (result (* (* :char)))
198 (error-message (* errmsg)))
201 (declaim (inline %free-table))
203 ("sqlite_free_table" %free-table)
204 ((rows :pointer-void)))
206 (declaim (inline sqlite-libversion))
212 (declaim (inline sqlite-libencoding))
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220 ;;;; Wrapper functions.
222 (defparameter sqlite-version (sqlite-libversion))
223 (defparameter sqlite-encoding (sqlite-libencoding))
225 (def-type sqlite-db-pointer-type sqlite-db-pointer)
226 (def-type sqlite-vm-pointer-type sqlite-vm-pointer)
228 (defun sqlite-open (db-name &optional (mode 0))
229 (let ((db (%open db-name mode nil)))
230 (if (null-pointer-p db)
231 (signal-sqlite-error SQLITE-ERROR
232 (format nil "unable to open ~A" db-name))
235 (defun sqlite-compile (db sql)
236 (let ((vm (allocate-foreign-object 'sqlite-vm)))
237 (with-foreign-object (sql-tail '(* :char))
238 (let ((result (%compile db sql sql-tail vm nil)))
239 (if (= result SQLITE-OK)
242 (free-foreign-object vm)
243 (signal-sqlite-error result)))))))
245 (defun sqlite-step (vm)
246 (declare (type sqlite-vm-pointer-type vm))
247 (with-foreign-object (cols-n :int)
248 (let ((cols (allocate-foreign-object '(* :char)))
249 (col-names (allocate-foreign-object '(* :char))))
250 (declare (type sqlite-row-pointer cols col-names))
251 (let ((result (%step (deref-pointer vm 'sqlite-vm)
252 cols-n cols col-names)))
254 ((= result SQLITE-ROW)
255 (let ((n (deref-pointer cols-n :int)))
256 (values n cols col-names)))
257 ((= result SQLITE-DONE)
258 (free-foreign-object cols)
259 (free-foreign-object col-names)
260 (values 0 (make-null-pointer 'string-array-pointer)
261 (make-null-pointer 'string-array-pointer)))
263 (free-foreign-object cols)
264 (free-foreign-object col-names)
265 (signal-sqlite-error result)))))))
267 (defun sqlite-finalize (vm)
268 (declare (type sqlite-vm-pointer vm))
269 (let ((result (%finalize (deref-pointer vm 'sqlite-vm) nil)))
270 (if (= result SQLITE-OK)
272 (free-foreign-object vm)
274 (signal-sqlite-error result))))
276 (defun sqlite-get-table (db sql)
277 (declare (type sqlite-db-pointer db))
278 (let ((rows (allocate-foreign-object '(* :char))))
279 (with-foreign-object (rows-n :int)
280 (with-foreign-object (cols-n :int)
281 (declare (type sqlite-row-pointer rows))
282 (let ((result (%get-table db sql rows rows-n cols-n nil)))
283 (if (= result SQLITE-OK)
284 (let ((cn (deref-pointer cols-n :int))
285 (rn (deref-pointer rows-n :int)))
288 (free-foreign-object rows)
289 (signal-sqlite-error result))))))))
291 (declaim (inline sqlite-free-table))
292 (defun sqlite-free-table (table)
293 (declare (type sqlite-row-pointer table))
294 (%free-table (deref-pointer table 'sqlite-row-pointer)))
296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
298 ;;;; Utility functions.
300 (declaim (inline make-null-row))
301 (defun make-null-row ()
302 (uffi:make-null-pointer 'string-array-pointer))
304 (declaim (inline make-null-vm))
305 (defun make-null-vm ()
306 (uffi:make-null-pointer 'sqlite-vm))
308 (declaim (inline null-row-p))
309 (defun null-row-p (row)
310 (null-pointer-p row))
312 (declaim (inline sqlite-aref))
313 (defun sqlite-aref (a n)
314 (declare (type sqlite-row-pointer a))
315 (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array :char) n))
317 (declaim (inline sqlite-free-row))
318 (defun sqlite-free-row (row)
319 (declare (type sqlite-row-pointer row))
320 (free-foreign-object row))