From: Kevin M. Rosenberg Date: Sat, 29 May 2004 13:10:32 +0000 (+0000) Subject: r9510: * db-sqlite: Remove clisp support since clisp can not run CLSQL X-Git-Tag: v3.8.6~361 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=96952664d524cd0d9891cf5a7a93545a6a7647d3 r9510: * db-sqlite: Remove clisp support since clisp can not run CLSQL with its MOP usage --- diff --git a/ChangeLog b/ChangeLog index 119049a..2ad0817 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,8 @@ 27 May 2004 Kevin Rosenberg * 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 * sql/oodml.lisp: Commit universal-time typo patch from Edi Weitz diff --git a/clsql-sqlite.asd b/clsql-sqlite.asd index bae257e..c4e9259 100644 --- a/clsql-sqlite.asd +++ b/clsql-sqlite.asd @@ -28,14 +28,11 @@ :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")))))) diff --git a/db-sqlite/sqlite-api-clisp.lisp b/db-sqlite/sqlite-api-clisp.lisp deleted file mode 100644 index 55fee0d..0000000 --- a/db-sqlite/sqlite-api-clisp.lisp +++ /dev/null @@ -1,374 +0,0 @@ -;; 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) - - -;;;; Local Variables: -;;;; Mode: lisp -;;;; Syntax: ANSI-Common-Lisp -;;;; Package: sqlite -;;;; End: diff --git a/db-sqlite/sqlite-api-uffi.lisp b/db-sqlite/sqlite-api-uffi.lisp deleted file mode 100644 index 9866749..0000000 --- a/db-sqlite/sqlite-api-uffi.lisp +++ /dev/null @@ -1,317 +0,0 @@ -;;;; -*- 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)) diff --git a/db-sqlite/sqlite-api.lisp b/db-sqlite/sqlite-api.lisp new file mode 100644 index 0000000..9866749 --- /dev/null +++ b/db-sqlite/sqlite-api.lisp @@ -0,0 +1,317 @@ +;;;; -*- 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)) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 542036f..3165e80 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -76,14 +76,11 @@ (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)) @@ -182,7 +179,7 @@ (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))) @@ -198,29 +195,11 @@ (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))))