27 May 2004 Kevin Rosenberg <kevin@rosenberg.net>
* sql/ooddl.lisp: Commit patch from Edi Weitz fixing return
type (setf slot-value-using-class)
+ * db-sqlite: Remove clisp support since clisp can not run CLSQL
+ with its MOP usage
26 May 2004 Kevin Rosenberg <kevin@rosenberg.net>
* sql/oodml.lisp: Commit universal-time typo patch from Edi Weitz
:long-description "cl-sql-sqlite package provides a database driver to SQLite database library."
- :depends-on (clsql #-clisp clsql-uffi)
+ :depends-on (clsql clsql-uffi)
:components
((:module :db-sqlite
:components
((:file "sqlite-package")
(:file "sqlite-loader" :depends-on ("sqlite-package"))
- (:file #+clisp "sqlite-api-clisp"
- #-clisp "sqlite-api-uffi"
- :depends-on ("sqlite-loader"))
- (:file "sqlite-sql" :depends-on (#+clisp "sqlite-api-clisp"
- #-clisp "sqlite-api-uffi"))))))
+ (:file "sqlite-api" :depends-on ("sqlite-loader"))
+ (:file "sqlite-sql" :depends-on ("sqlite-api"))))))
+++ /dev/null
-;; sqlite.lisp --- CLISP FFI for SQLite (http://www.sqlite.org).
-
-;; Copyright (C) 2003 Aurelio Bignoli
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2 of
-;; the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be
-;; useful, but WITHOUT ANY WARRANTY; without even the implied
-;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;; PURPOSE. See the GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public
-;; License along with this program; if not, write to the Free
-;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-;; MA 02111-1307 USA
-
-;; $Id$
-
-(in-package #:cl-user)
-
-(defpackage #:sqlite
- (:use #:common-lisp #:ffi)
- (:export
- ;;; Conditions
- #:sqlite-error
- #:sqlite-error-code
- #:sqlite-error-message
-
- ;;; Core API.
- #:sqlite-open
- #:sqlite-close
-
- ;;; New API.
- #:sqlite-compile
- #:sqlite-step
- #:sqlite-finalize
-
- ;;; Extended API.
- #:sqlite-get-table
- #:sqlite-version ; Defined as constant.
- #:sqlite-encoding ; Defined as constant.
- #:sqlite-last-insert-rowid
-
- ;;; Utility functions (used by CLSQL)
- #:make-null-row
- #:null-row-p
-
- ;;; Macros.
- #:with-open-sqlite-db
- #:with-sqlite-vm
-
- ;;; Compatibility with clsql-sql-uffi.lisp
- #:sqlite-aref
- #:sqlite-free-table
- #:make-null-vm
- #:make-null-row
- ))
-
-(in-package #:sqlite)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Return values for sqlite_exec() and sqlite_step()
-;;;;
-(defconstant SQLITE-OK 0 "Successful result")
-(defconstant SQLITE-ERROR 1 "SQL error or missing database")
-(defconstant SQLITE-INTERNAL 2 "An internal logic error in SQLite")
-(defconstant SQLITE-PERM 3 "Access permission denied")
-(defconstant SQLITE-ABORT 4 "Callback routine requested an abort")
-(defconstant SQLITE-BUSY 5 "The database file is locked")
-(defconstant SQLITE-LOCKED 6 "A table in the database is locked")
-(defconstant SQLITE-NOMEM 7 "A malloc() failed")
-(defconstant SQLITE-READONLY 8 "Attempt to write a readonly database")
-(defconstant SQLITE-INTERRUPT 9 "Operation terminated by sqlite_interrupt()")
-(defconstant SQLITE-IOERR 10 "Some kind of disk I/O error occurred")
-(defconstant SQLITE-CORRUPT 11 "The database disk image is malformed")
-(defconstant SQLITE-NOTFOUND 12 "(Internal Only) Table or record not found")
-(defconstant SQLITE-FULL 13 "Insertion failed because database is full")
-(defconstant SQLITE-CANTOPEN 14 "Unable to open the database file")
-(defconstant SQLITE-PROTOCOL 15 "Database lock protocol error")
-(defconstant SQLITE-EMPTY 16 "(Internal Only) Database table is empty")
-(defconstant SQLITE-SCHEMA 17 "The database schema changed")
-(defconstant SQLITE-TOOBIG 18 "Too much data for one row of a table")
-(defconstant SQLITE-CONSTRAINT 19 "Abort due to contraint violation")
-(defconstant SQLITE-MISMATCH 20 "Data type mismatch")
-(defconstant SQLITE-MISUSE 21 "Library used incorrectly")
-(defconstant SQLITE-NOLFS 22 "Uses OS features not supported on host")
-(defconstant SQLITE-AUTH 23 "Authorization denied")
-(defconstant SQLITE-FORMAT 24 "Auxiliary database format error")
-(defconstant SQLITE-ROW 100 "sqlite_step() has another row ready")
-(defconstant SQLITE-DONE 101 "sqlite_step() has finished executing")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; C types.
-;;;;
-(def-c-type sqlite-db c-pointer)
-(def-c-type sqlite-vm c-pointer)
-(def-c-type error-message (c-ptr c-pointer))
- ; It is not NULL only in case of error.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Conditions.
-;;;;
-(define-condition sqlite-error ()
- ((message :initarg :message :reader sqlite-error-message :initform "")
- (code :initarg :code :reader sqlite-error-code))
- (:report (lambda (condition stream)
- (let ((code (sqlite-error-code condition)))
- (format stream "SQLite error [~A] - ~A : ~A"
- code (error-string code)
- (sqlite-error-message condition))))))
-
-(defun signal-sqlite-error (code message)
- (let ((condition
- (make-condition 'sqlite-error
- :code code
- :message
- (typecase message
- (string message)
- (t (error-message-as-string message))))))
- (unless (signal condition)
- (invoke-debugger condition))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Library functions.
-;;;;
-(defmacro def-sqlite-call-out (name &rest args)
- `(def-call-out ,name
- (:language :stdc)
- (:library "libsqlite.so")
- ,@args))
-
-(def-sqlite-call-out error-string
- (:name "sqlite_error_string")
- (:arguments
- (error-code int :in))
- (:return-type c-string))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Core API.
-;;;;
-(def-sqlite-call-out %open
- (:name "sqlite_open")
- (:arguments
- (dbname c-string :in)
- (mode int :in)
- (errmsg error-message :out))
- (:return-type sqlite-db))
-
-(def-sqlite-call-out sqlite-close
- (:name "sqlite_close")
- (:arguments (db sqlite-db :in))
- (:return-type nil))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; New API.
-;;;;
-(def-sqlite-call-out %compile
- (:name "sqlite_compile")
- (:arguments
- (db sqlite-db :in)
- (sql c-string :in)
- (sql-tail (c-ptr c-string) :out)
- (vm (c-ptr sqlite-vm) :out)
- (errmsg error-message :out))
- (:return-type int))
-
-(def-sqlite-call-out %step
- (:name "sqlite_step")
- (:arguments
- (vm sqlite-vm :in)
- (cols-n (c-ptr int) :out)
- (cols (c-ptr c-pointer) :out)
- (col-names (c-ptr c-pointer) :out))
- (:return-type int))
-
-(def-sqlite-call-out %finalize
- (:name "sqlite_finalize")
- (:arguments
- (vm sqlite-vm :in)
- (errmsg error-message :out))
- (:return-type int))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Extended API.
-;;;;
-(def-sqlite-call-out sqlite-last-insert-rowid
- (:name "sqlite_last_insert_rowid")
- (:arguments
- (db sqlite-db :in))
- (:return-type int))
-
-(def-sqlite-call-out %get-table
- (:name "sqlite_get_table")
- (:arguments
- (db sqlite-db :in)
- (sql c-string :in)
- (result (c-ptr c-pointer) :out)
- (n-row (c-ptr int) :out)
- (n-column (c-ptr int) :out)
- (errmsg error-message :out))
- (:return-type int))
-
-(def-sqlite-call-out %free-table
- (:name "sqlite_free_table")
- (:arguments
- (rows c-pointer :in))
- (:return-type nil))
-
-(def-c-var %version
- (:name "sqlite_version")
- (:library "libsqlite.so")
- (:type (c-array-max char 32))
- (:read-only t))
-
-(def-c-var %encoding
- (:name "sqlite_encoding")
- (:library "libsqlite.so")
- (:type (c-array-max char 32))
- (:read-only t))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Wrapper functions.
-;;;;
-(defconstant sqlite-version
- (ext:convert-string-from-bytes %version custom:*terminal-encoding*))
-
-(defconstant sqlite-encoding
- (ext:convert-string-from-bytes %encoding custom:*terminal-encoding*))
-
-(defun error-message-as-string (p)
- (with-c-var (p1 'c-pointer p)
- (prog1
- (cast p1 'c-string)
- (foreign-free p1))))
-
-(defun sqlite-open (db-name &optional (mode 0))
- (multiple-value-bind (db error-message)
- (%open db-name mode)
- (if db
- db
- (signal-sqlite-error SQLITE-ERROR error-message))))
-
-(defun c-pointer-to-string-array (p element-n)
- (if (null p)
- p
- (with-c-var (p1 'c-pointer p)
- (cast p1 `(c-ptr (c-array c-string ,element-n))))))
-
-(defun sqlite-compile (db sql)
- (multiple-value-bind (result sql-tail vm error-message)
- (%compile db sql)
- (declare (ignore sql-tail))
- (if (= result SQLITE-OK)
- vm
- (signal-sqlite-error result error-message))))
-
-(defun sqlite-step (vm)
- (multiple-value-bind (result n-col cols col-names)
- (%step vm)
- (cond
- ((= result SQLITE-ROW)
- (values n-col (c-pointer-to-string-array cols n-col)
- (c-pointer-to-string-array col-names (* 2 n-col))))
- ((= result SQLITE-DONE) (values 0 nil nil))
- (t (signal-sqlite-error result "sqlite-step")))))
-
-(defun sqlite-finalize (vm)
- (multiple-value-bind (result error-message)
- (%finalize vm)
- (if (= result SQLITE-OK)
- t
- (signal-sqlite-error result error-message))))
-
-(defun sqlite-get-table (db sql)
- (multiple-value-bind (result rows n-row n-col error-message)
- (%get-table db sql)
- (if (= result SQLITE-OK)
- (let ((x (c-pointer-to-string-array rows (* (1+ n-row) n-col))))
- (%free-table rows)
- (values x n-row n-col))
- (signal-sqlite-error result error-message))))
-
-(defmacro with-open-sqlite-db ((db dbname &key (mode 0)) &body body)
- (let ((error-message (gensym)))
- `(multiple-value-bind (,db ,error-message)
- (sqlite-open ,dbname ,mode)
- (if (null ,db)
- (signal-sqlite-error SQLITE-ERROR ,error-message)
- (unwind-protect
- (progn ,@body)
- (sqlite-close ,db))))))
-
-(defmacro with-sqlite-vm ((vm db sql) &body body)
- `(let ((,vm (sqlite-compile ,db ,sql)))
- (unwind-protect
- (progn ,@body)
- (sqlite-finalize ,vm))))
-
-(declaim (inline null-row-p))
-(defun null-row-p (row)
- (null row))
-
-(declaim (inline make-null-row))
-(defun make-null-row ()
- nil)
-
-#+nil
-(defun test-function (db-name)
- (with-open-sqlite-db (db db-name)
- (let ((x (sqlite-get-table db "select * from sqlite_master;")))
- (with-sqlite-vm (vm db "select * from sqlite_master;")
- (let ((error-n 0))
- (loop for i = 1 then (1+ i)
- do (multiple-value-bind (n-col cols col-names)
- (sqlite-step vm)
- (declare (ignore col-names))
- (if (= n-col 0)
- (return-from nil)
- (loop for j from 0 to (1- n-col)
- for j1 = (* n-col i) then (1+ j1)
- do
- (when (string/= (aref x j1) (aref cols j))
- (format t "~&row=~A, col=~A: ~A - ~A~%"
- i j
- (aref x j1) (aref cols j))
- (incf error-n))))))
- (if (= error-n 0)
- (format t "~&Test passed!~%")
- (format t "~&Test not passed. ~A errors" error-n)))))))
-
-(defun get-column-types (db-name table-name)
- (with-open-sqlite-db (db db-name)
- (with-sqlite-vm (vm db (format nil "pragma table_info('~A')" table-name))
- (loop
- (multiple-value-bind (n-col cols col-names)
- (sqlite-step vm)
- (declare (ignore col-names))
- (if (= n-col 0)
- (return-from nil)
- (format t "~&column name = ~A, type = ~A~%"
- (aref cols 1) (aref cols 2))))))))
-
-;;; Compatibility with sqlite-api-uffi.lisp
-
-(defun sqlite-aref (row i)
- (aref row i))
-
-(defun sqlite-free-table (table)
- (declare (ignore table))
- )
-
-(defun make-null-vm ()
- nil)
-
-(defun make-null-row ()
- nil)
-
-\f
-;;;; Local Variables:
-;;;; Mode: lisp
-;;;; Syntax: ANSI-Common-Lisp
-;;;; Package: sqlite
-;;;; End:
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: sqlite-api-uffi.lisp
-;;;; Purpose: Low-level SQLite interface using UFFI
-;;;; Authors: Aurelio Bignoli and Kevin Rosenberg
-;;;; Created: Nov 2003
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
-;;;; and Copyright (c) 2003-2004 by Kevin Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:cl-user)
-
-(defpackage #:sqlite
- (:use #:common-lisp #:uffi)
- (:export
- ;;; Conditions
- #:sqlite-error
- #:sqlite-error-code
- #:sqlite-error-message
-
- ;;; Core API.
- #:sqlite-open
- #:sqlite-close
-
- ;;; New API.
- #:sqlite-compile
- #:sqlite-step
- #:sqlite-finalize
-
- ;;; Extended API.
- #:sqlite-get-table
- #:sqlite-free-table
- #:sqlite-version ; Defined as constant.
- #:sqlite-encoding ; Defined as constant.
- #:sqlite-last-insert-rowid
-
- ;;; Utility functions.
- #:make-null-row
- #:make-null-vm
- #:null-row-p
- #:sqlite-aref
- #:sqlite-free-row
-
- ;;; Types.
- #:sqlite-row
- #:sqlite-row-pointer
- #:sqlite-row-pointer-type
- #:sqlite-vm-pointer))
-
-(in-package #:sqlite)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Return values for sqlite_exec() and sqlite_step()
-;;;;
-(defconstant SQLITE-OK 0 "Successful result")
-(defconstant SQLITE-ERROR 1 "SQL error or missing database")
-(defconstant SQLITE-ROW 100 "sqlite_step() has another row ready")
-(defconstant SQLITE-DONE 101 "sqlite_step() has finished executing")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Conditions.
-;;;;
-(define-condition sqlite-error ()
- ((message :initarg :message :reader sqlite-error-message :initform "")
- (code :initarg :code :reader sqlite-error-code))
- (:report (lambda (condition stream)
- (let ((code (sqlite-error-code condition)))
- (format stream "SQLite error [~A]: ~A"
- code (sqlite-error-message condition))))))
-
-(defun signal-sqlite-error (code &optional message)
- (let ((condition
- (make-condition 'sqlite-error
- :code code
- :message (if message
- message
- (uffi:convert-from-cstring
- (sqlite-error-string code))))))
- (unless (signal condition)
- (invoke-debugger condition))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Foreign types definitions.
-;;;;
-(def-foreign-type errmsg (* :unsigned-char))
-(def-foreign-type sqlite-db :pointer-void)
-(def-foreign-type sqlite-vm :pointer-void)
-(def-foreign-type string-pointer (* (* :unsigned-char)))
-(def-foreign-type sqlite-row-pointer (* (* :unsigned-char)))
-
-(defvar +null-errmsg-pointer+ (make-null-pointer 'errmsg))
-(defvar +null-string-pointer-pointer+ (make-null-pointer 'string-pointer))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Lisp types used in declarations.
-;;;;
-(def-type sqlite-db-type sqlite-db)
-(def-type sqlite-row string-pointer)
-(def-type sqlite-row-pointer-type (* string-pointer))
-(def-type sqlite-vm-pointer (* sqlite-vm))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Library functions.
-;;;;
-(defmacro def-sqlite-function (name args &key (returning :void))
- `(def-function ,name ,args
- :module "sqlite"
- :returning ,returning))
-
-(def-sqlite-function
- "sqlite_error_string"
- ((error-code :int))
- :returning :cstring)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Core API.
-;;;;
-(declaim (inline %open))
-(def-sqlite-function
- ("sqlite_open" %open)
- ((dbname :cstring)
- (mode :int)
- (error-message (* errmsg)))
- :returning sqlite-db)
-
-(declaim (inline sqlite-close))
-(def-sqlite-function
- "sqlite_close"
- ((db sqlite-db)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; New API.
-;;;;
-(declaim (inline %compile))
-(def-sqlite-function
- ("sqlite_compile" %compile)
- ((db sqlite-db)
- (sql :cstring)
- (sql-tail (* (* :unsigned-char)))
- (vm (* sqlite-vm))
- (error-message (* errmsg)))
- :returning :int)
-
-(declaim (inline %step))
-(def-sqlite-function
- ("sqlite_step" %step)
- ((vm sqlite-vm)
- (cols-n (* :int))
- (cols (* (* (* :unsigned-char))))
- (col-names (* (* (* :unsigned-char)))))
- :returning :int)
-
-(declaim (inline %finalize))
-(def-sqlite-function
- ("sqlite_finalize" %finalize)
- ((vm sqlite-vm)
- (error-message (* errmsg)))
- :returning :int)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Extended API.
-;;;;
-(declaim (inline sqlite-last-insert-rowid))
-(def-sqlite-function
- "sqlite_last_insert_rowid"
- ((db sqlite-db))
- :returning :int)
-
-(declaim (inline %get-table))
-(def-sqlite-function
- ("sqlite_get_table" %get-table)
- ((db sqlite-db)
- (sql :cstring)
- (result (* (* (* :unsigned-char))))
- (rows-n (* :int))
- (cols-n (* :int))
- (error-message (* errmsg)))
- :returning :int)
-
-(declaim (inline %free-table))
-(def-sqlite-function
- ("sqlite_free_table" %free-table)
- ((rows :pointer-void)))
-
-(declaim (inline sqlite-libversion))
-(def-sqlite-function
- "sqlite_libversion"
- ()
- :returning :cstring)
-
-(declaim (inline sqlite-libencoding))
-(def-sqlite-function
- "sqlite_libencoding"
- ()
- :returning :cstring)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Wrapper functions.
-;;;;
-(defparameter sqlite-version (sqlite-libversion))
-(defparameter sqlite-encoding (sqlite-libencoding))
-
-(defun sqlite-open (db-name &optional (mode 0))
- (with-cstring (db-name-native db-name)
- (let ((db (%open db-name-native mode +null-errmsg-pointer+)))
- (if (null-pointer-p db)
- (signal-sqlite-error SQLITE-ERROR
- (format nil "unable to open ~A" db-name))
- db))))
-
-(defun sqlite-compile (db sql)
- (with-cstring (sql-native sql)
- (let ((vm (allocate-foreign-object 'sqlite-vm)))
- (with-foreign-object (sql-tail '(* :unsigned-char))
- (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+)))
- (if (= result SQLITE-OK)
- vm
- (progn
- (free-foreign-object vm)
- (signal-sqlite-error result))))))))
-
-(defun sqlite-step (vm)
- (declare (type sqlite-vm-pointer vm))
- (with-foreign-object (cols-n :int)
- (let ((cols (allocate-foreign-object '(* (* :unsigned-char))))
- (col-names (allocate-foreign-object '(* (* :unsigned-char)))))
- (declare (type sqlite-row-pointer-type cols col-names))
- (let ((result (%step (deref-pointer vm 'sqlite-vm)
- cols-n cols col-names)))
- (cond
- ((= result SQLITE-ROW)
- (let ((n (deref-pointer cols-n :int)))
- (values n cols col-names)))
- ((= result SQLITE-DONE)
- (free-foreign-object cols)
- (free-foreign-object col-names)
- (values 0 +null-string-pointer-pointer+ +null-string-pointer-pointer+))
- (t
- (free-foreign-object cols)
- (free-foreign-object col-names)
- (signal-sqlite-error result)))))))
-
-(defun sqlite-finalize (vm)
- (declare (type sqlite-vm-pointer vm))
- (let ((result (%finalize (deref-pointer vm 'sqlite-vm) +null-errmsg-pointer+)))
- (if (= result SQLITE-OK)
- (progn
- (free-foreign-object vm)
- t)
- (signal-sqlite-error result))))
-
-(defun sqlite-get-table (db sql)
- (declare (type sqlite-db-type db))
- (with-cstring (sql-native sql)
- (let ((rows (allocate-foreign-object '(* (* :unsigned-char)))))
- (declare (type sqlite-row-pointer-type rows))
- (with-foreign-object (rows-n :int)
- (with-foreign-object (cols-n :int)
- (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+)))
- (if (= result SQLITE-OK)
- (let ((cn (deref-pointer cols-n :int))
- (rn (deref-pointer rows-n :int)))
- (values rows rn cn))
- (progn
- (free-foreign-object rows)
- (signal-sqlite-error result)))))))))
-
-(declaim (inline sqlite-free-table))
-(defun sqlite-free-table (table)
- (declare (type sqlite-row-pointer-type table))
- (%free-table (deref-pointer table 'sqlite-row-pointer)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; Utility functions.
-;;;;
-(declaim (inline make-null-row))
-(defun make-null-row ()
- +null-string-pointer-pointer+)
-
-(declaim (inline make-null-vm))
-(defun make-null-vm ()
- (uffi:make-null-pointer 'sqlite-vm))
-
-(declaim (inline null-row-p))
-(defun null-row-p (row)
- (null-pointer-p row))
-
-(declaim (inline sqlite-aref))
-(defun sqlite-aref (a n)
- (declare (type sqlite-row-pointer-type a))
- (convert-from-foreign-string
- (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n)))
-
-(declaim (inline sqlite-free-row))
-(defun sqlite-free-row (row)
- (declare (type sqlite-row-pointer-type row))
- (free-foreign-object row))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sqlite-api-uffi.lisp
+;;;; Purpose: Low-level SQLite interface using UFFI
+;;;; Authors: Aurelio Bignoli and Kevin Rosenberg
+;;;; Created: Nov 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
+;;;; and Copyright (c) 2003-2004 by Kevin Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(defpackage #:sqlite
+ (:use #:common-lisp #:uffi)
+ (:export
+ ;;; Conditions
+ #:sqlite-error
+ #:sqlite-error-code
+ #:sqlite-error-message
+
+ ;;; Core API.
+ #:sqlite-open
+ #:sqlite-close
+
+ ;;; New API.
+ #:sqlite-compile
+ #:sqlite-step
+ #:sqlite-finalize
+
+ ;;; Extended API.
+ #:sqlite-get-table
+ #:sqlite-free-table
+ #:sqlite-version ; Defined as constant.
+ #:sqlite-encoding ; Defined as constant.
+ #:sqlite-last-insert-rowid
+
+ ;;; Utility functions.
+ #:make-null-row
+ #:make-null-vm
+ #:null-row-p
+ #:sqlite-aref
+ #:sqlite-free-row
+
+ ;;; Types.
+ #:sqlite-row
+ #:sqlite-row-pointer
+ #:sqlite-row-pointer-type
+ #:sqlite-vm-pointer))
+
+(in-package #:sqlite)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Return values for sqlite_exec() and sqlite_step()
+;;;;
+(defconstant SQLITE-OK 0 "Successful result")
+(defconstant SQLITE-ERROR 1 "SQL error or missing database")
+(defconstant SQLITE-ROW 100 "sqlite_step() has another row ready")
+(defconstant SQLITE-DONE 101 "sqlite_step() has finished executing")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Conditions.
+;;;;
+(define-condition sqlite-error ()
+ ((message :initarg :message :reader sqlite-error-message :initform "")
+ (code :initarg :code :reader sqlite-error-code))
+ (:report (lambda (condition stream)
+ (let ((code (sqlite-error-code condition)))
+ (format stream "SQLite error [~A]: ~A"
+ code (sqlite-error-message condition))))))
+
+(defun signal-sqlite-error (code &optional message)
+ (let ((condition
+ (make-condition 'sqlite-error
+ :code code
+ :message (if message
+ message
+ (uffi:convert-from-cstring
+ (sqlite-error-string code))))))
+ (unless (signal condition)
+ (invoke-debugger condition))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Foreign types definitions.
+;;;;
+(def-foreign-type errmsg (* :unsigned-char))
+(def-foreign-type sqlite-db :pointer-void)
+(def-foreign-type sqlite-vm :pointer-void)
+(def-foreign-type string-pointer (* (* :unsigned-char)))
+(def-foreign-type sqlite-row-pointer (* (* :unsigned-char)))
+
+(defvar +null-errmsg-pointer+ (make-null-pointer 'errmsg))
+(defvar +null-string-pointer-pointer+ (make-null-pointer 'string-pointer))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Lisp types used in declarations.
+;;;;
+(def-type sqlite-db-type sqlite-db)
+(def-type sqlite-row string-pointer)
+(def-type sqlite-row-pointer-type (* string-pointer))
+(def-type sqlite-vm-pointer (* sqlite-vm))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Library functions.
+;;;;
+(defmacro def-sqlite-function (name args &key (returning :void))
+ `(def-function ,name ,args
+ :module "sqlite"
+ :returning ,returning))
+
+(def-sqlite-function
+ "sqlite_error_string"
+ ((error-code :int))
+ :returning :cstring)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Core API.
+;;;;
+(declaim (inline %open))
+(def-sqlite-function
+ ("sqlite_open" %open)
+ ((dbname :cstring)
+ (mode :int)
+ (error-message (* errmsg)))
+ :returning sqlite-db)
+
+(declaim (inline sqlite-close))
+(def-sqlite-function
+ "sqlite_close"
+ ((db sqlite-db)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; New API.
+;;;;
+(declaim (inline %compile))
+(def-sqlite-function
+ ("sqlite_compile" %compile)
+ ((db sqlite-db)
+ (sql :cstring)
+ (sql-tail (* (* :unsigned-char)))
+ (vm (* sqlite-vm))
+ (error-message (* errmsg)))
+ :returning :int)
+
+(declaim (inline %step))
+(def-sqlite-function
+ ("sqlite_step" %step)
+ ((vm sqlite-vm)
+ (cols-n (* :int))
+ (cols (* (* (* :unsigned-char))))
+ (col-names (* (* (* :unsigned-char)))))
+ :returning :int)
+
+(declaim (inline %finalize))
+(def-sqlite-function
+ ("sqlite_finalize" %finalize)
+ ((vm sqlite-vm)
+ (error-message (* errmsg)))
+ :returning :int)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Extended API.
+;;;;
+(declaim (inline sqlite-last-insert-rowid))
+(def-sqlite-function
+ "sqlite_last_insert_rowid"
+ ((db sqlite-db))
+ :returning :int)
+
+(declaim (inline %get-table))
+(def-sqlite-function
+ ("sqlite_get_table" %get-table)
+ ((db sqlite-db)
+ (sql :cstring)
+ (result (* (* (* :unsigned-char))))
+ (rows-n (* :int))
+ (cols-n (* :int))
+ (error-message (* errmsg)))
+ :returning :int)
+
+(declaim (inline %free-table))
+(def-sqlite-function
+ ("sqlite_free_table" %free-table)
+ ((rows :pointer-void)))
+
+(declaim (inline sqlite-libversion))
+(def-sqlite-function
+ "sqlite_libversion"
+ ()
+ :returning :cstring)
+
+(declaim (inline sqlite-libencoding))
+(def-sqlite-function
+ "sqlite_libencoding"
+ ()
+ :returning :cstring)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Wrapper functions.
+;;;;
+(defparameter sqlite-version (sqlite-libversion))
+(defparameter sqlite-encoding (sqlite-libencoding))
+
+(defun sqlite-open (db-name &optional (mode 0))
+ (with-cstring (db-name-native db-name)
+ (let ((db (%open db-name-native mode +null-errmsg-pointer+)))
+ (if (null-pointer-p db)
+ (signal-sqlite-error SQLITE-ERROR
+ (format nil "unable to open ~A" db-name))
+ db))))
+
+(defun sqlite-compile (db sql)
+ (with-cstring (sql-native sql)
+ (let ((vm (allocate-foreign-object 'sqlite-vm)))
+ (with-foreign-object (sql-tail '(* :unsigned-char))
+ (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+)))
+ (if (= result SQLITE-OK)
+ vm
+ (progn
+ (free-foreign-object vm)
+ (signal-sqlite-error result))))))))
+
+(defun sqlite-step (vm)
+ (declare (type sqlite-vm-pointer vm))
+ (with-foreign-object (cols-n :int)
+ (let ((cols (allocate-foreign-object '(* (* :unsigned-char))))
+ (col-names (allocate-foreign-object '(* (* :unsigned-char)))))
+ (declare (type sqlite-row-pointer-type cols col-names))
+ (let ((result (%step (deref-pointer vm 'sqlite-vm)
+ cols-n cols col-names)))
+ (cond
+ ((= result SQLITE-ROW)
+ (let ((n (deref-pointer cols-n :int)))
+ (values n cols col-names)))
+ ((= result SQLITE-DONE)
+ (free-foreign-object cols)
+ (free-foreign-object col-names)
+ (values 0 +null-string-pointer-pointer+ +null-string-pointer-pointer+))
+ (t
+ (free-foreign-object cols)
+ (free-foreign-object col-names)
+ (signal-sqlite-error result)))))))
+
+(defun sqlite-finalize (vm)
+ (declare (type sqlite-vm-pointer vm))
+ (let ((result (%finalize (deref-pointer vm 'sqlite-vm) +null-errmsg-pointer+)))
+ (if (= result SQLITE-OK)
+ (progn
+ (free-foreign-object vm)
+ t)
+ (signal-sqlite-error result))))
+
+(defun sqlite-get-table (db sql)
+ (declare (type sqlite-db-type db))
+ (with-cstring (sql-native sql)
+ (let ((rows (allocate-foreign-object '(* (* :unsigned-char)))))
+ (declare (type sqlite-row-pointer-type rows))
+ (with-foreign-object (rows-n :int)
+ (with-foreign-object (cols-n :int)
+ (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+)))
+ (if (= result SQLITE-OK)
+ (let ((cn (deref-pointer cols-n :int))
+ (rn (deref-pointer rows-n :int)))
+ (values rows rn cn))
+ (progn
+ (free-foreign-object rows)
+ (signal-sqlite-error result)))))))))
+
+(declaim (inline sqlite-free-table))
+(defun sqlite-free-table (table)
+ (declare (type sqlite-row-pointer-type table))
+ (%free-table (deref-pointer table 'sqlite-row-pointer)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Utility functions.
+;;;;
+(declaim (inline make-null-row))
+(defun make-null-row ()
+ +null-string-pointer-pointer+)
+
+(declaim (inline make-null-vm))
+(defun make-null-vm ()
+ (uffi:make-null-pointer 'sqlite-vm))
+
+(declaim (inline null-row-p))
+(defun null-row-p (row)
+ (null-pointer-p row))
+
+(declaim (inline sqlite-aref))
+(defun sqlite-aref (a n)
+ (declare (type sqlite-row-pointer-type a))
+ (convert-from-foreign-string
+ (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n)))
+
+(declaim (inline sqlite-free-row))
+(defun sqlite-free-row (row)
+ (declare (type sqlite-row-pointer-type row))
+ (free-foreign-object row))
(defstruct sqlite-result-set
(vm (sqlite:make-null-vm)
- #-clisp :type
- #-clisp sqlite:sqlite-vm-pointer)
+ :type sqlite:sqlite-vm-pointer)
(first-row (sqlite:make-null-row)
- #-clisp :type
- #-clisp sqlite:sqlite-row-pointer-type)
+ :type sqlite:sqlite-row-pointer-type)
(col-names (sqlite:make-null-row)
- #-clisp :type
- #-clisp sqlite:sqlite-row-pointer-type)
+ :type sqlite:sqlite-row-pointer-type)
(result-types nil)
(n-col 0 :type fixnum))
(multiple-value-bind (n new-row col-names)
(sqlite:sqlite-step (sqlite-result-set-vm result-set))
(declare (ignore n col-names)
- #-clisp (type sqlite:sqlite-row-pointer-type new-row))
+ (type sqlite:sqlite-row-pointer-type new-row))
(if (sqlite:null-row-p new-row)
(return-from database-store-next-row nil)
(setf row new-row)))
(loop for i = 0 then (1+ i)
for rest on list
do (setf (car rest)
- #-clisp
(clsql-uffi:convert-raw-field
(uffi:deref-array
(uffi:deref-pointer row 'sqlite:sqlite-row-pointer) '(:array (* :unsigned-char)) i)
result-types
- i)
- #+clisp
- (let ((type (if result-types
- (nth i result-types)
- :string))
- (val (sqlite:sqlite-aref row i)))
- (case type
- (:string
- val)
- (:integer
- (when val (parse-integer val)))
- (:number
- (read-from-string val))
- (:double
- (when val
- (coerce
- (read-from-string val)
- 'double-float)))))))
+ i)))
(sqlite:sqlite-free-row row)
t))))
projects / clsql.git / commitdiff