From: Kevin M. Rosenberg Date: Wed, 10 Mar 2004 22:33:14 +0000 (+0000) Subject: r8710: new backend X-Git-Tag: v3.8.6~755 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=fd3c9c9f21ff40904bf27eb7a797bbd6c2d80630 r8710: new backend --- diff --git a/ChangeLog b/ChangeLog index 45929d0..554b73d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +10 Mar 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Integrate patch from Aurelio Bignoli for SQLite backend + 11 Nov 2003 Kevin Rosenberg (kevin@rosenberg.net) * Converted documentation to XML format * Made package installable with asdf-install diff --git a/clsql-sqlite.asd b/clsql-sqlite.asd new file mode 100644 index 0000000..c3840fb --- /dev/null +++ b/clsql-sqlite.asd @@ -0,0 +1,41 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-postgresql.asd +;;;; Purpose: ASDF file for CLSQL SQLite backend +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id: clsql-sqlite.asd,v 1.5 2004/03/09 20:55:11 aurelio Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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. +;;;; ************************************************************************* +(defpackage #:clsql-sqlite-system (:use #:asdf #:cl)) +(in-package #:clsql-sqlite-system) + +(defsystem clsql-sqlite + :name "cl-sql-sqlite" + :author "Aurelio Bignoli " + :maintainer "Aurelio Bignoli" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQLite Driver" + :long-description "cl-sql-sqlite package provides a database driver to SQLite database library." + + :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-usql" :depends-on ("sqlite-sql"))))) + :depends-on (#-clisp :uffi + :clsql-base)) diff --git a/clsql-tests.asd b/clsql-tests.asd index a9c8729..6da0173 100644 --- a/clsql-tests.asd +++ b/clsql-tests.asd @@ -21,9 +21,12 @@ :licence "Lessor Lisp General Public License" :description "Testing suite for CLSQL" - :depends-on (:clsql :clsql-mysql :clsql-postgresql :clsql-postgresql-socket + :depends-on (:clsql #-clisp :clsql-mysql + #-clisp :clsql-postgresql + #-clisp :clsql-postgresql-socket :ptester - #+(and allegro (not allegro-cl-trial)) :clsql-aodbc) + #+(and allegro (not allegro-cl-trial)) :clsql-aodbc + :clsql-sqlite) :components ((:module tests :components diff --git a/db-sqlite/sqlite-api-clisp.lisp b/db-sqlite/sqlite-api-clisp.lisp new file mode 100644 index 0000000..101f5b4 --- /dev/null +++ b/db-sqlite/sqlite-api-clisp.lisp @@ -0,0 +1,351 @@ +;; 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: sqlite.lisp,v 1.4 2003/11/28 21:02:43 aurelio Exp $ + +(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)) + +(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)))))))) + +;;;; Local Variables: +;;;; Mode: lisp +;;;; Syntax: ANSI-Common-Lisp +;;;; Package: sqlite +;;;; End: \ No newline at end of file diff --git a/db-sqlite/sqlite-api-uffi.lisp b/db-sqlite/sqlite-api-uffi.lisp new file mode 100644 index 0000000..90f8cef --- /dev/null +++ b/db-sqlite/sqlite-api-uffi.lisp @@ -0,0 +1,311 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-api-uffi.lisp +;;;; Purpose: Low-level SQLite interface using UFFI +;;;; Programmers: Aurelio Bignoli +;;;; Date Started: Nov 2003 +;;;; +;;;; $Id: sqlite-api-uffi.lisp,v 1.5 2004/03/09 20:57:19 aurelio Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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. +;;;; ************************************************************************* +(declaim (optimize (debug 0) (speed 3) (safety 0) (compilation-speed 0))) + +(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-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 + (sqlite-error-string code))))) + (unless (signal condition) + (invoke-debugger condition)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Foreign types definitions. +;;;; +(def-foreign-type sqlite-db :pointer-void) +(def-foreign-type sqlite-vm :pointer-void) +(def-foreign-type errmsg :cstring) + +(def-array-pointer string-array-pointer :cstring) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Lisp types used in declarations. +;;;; +(def-type sqlite-db-pointer '(* sqlite-db)) +(def-type sqlite-int-pointer '(* :int)) +(def-type sqlite-row 'string-array-pointer) +(def-type sqlite-row-pointer '(* string-array-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 '(* :cstring)) + (vm '(* sqlite-vm)) + (error-message '(* errmsg))) + :returning :int) + +(declaim (inline %step)) +(def-sqlite-function + ("sqlite_step" %step) + ((vm sqlite-vm) + (cols-n '(* :int)) + (cols '(* (* :cstring))) + (col-names '(* (* :cstring)))) + :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 '(* (* :cstring))) + (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)) + (let ((db (%open db-name mode nil))) + (declare (type sqlite-db-pointer db)) + (if (null-pointer-p db) + (signal-sqlite-error SQLITE-ERROR + (format nil "unable to open ~A" db-name)) + db))) + +(defun sqlite-compile (db sql) + (declare (type sqlite-db-pointer db)) + (let ((vm (allocate-foreign-object 'sqlite-vm))) + (with-foreign-object (sql-tail :cstring) + (let ((result (%compile db sql sql-tail vm nil))) + (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 '(* :cstring))) + (col-names (allocate-foreign-object '(* :cstring)))) + (declare (type sqlite-row-pointer 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 (make-null-pointer 'string-array-pointer) + (make-null-pointer 'string-array-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) nil))) + (if (= result SQLITE-OK) + (progn + (free-foreign-object vm) + t) + (signal-sqlite-error result)))) + +(defun sqlite-get-table (db sql) + (declare (type sqlite-db-pointer db)) + (let ((rows (allocate-foreign-object '(* :cstring)))) + (with-foreign-object (rows-n :int) + (with-foreign-object (cols-n :int) + (declare (type sqlite-row-pointer rows)) + (let ((result (%get-table db sql rows rows-n cols-n nil))) + (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 table)) + (%free-table (deref-pointer table 'sqlite-row-pointer))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Utility functions. +;;;; +(declaim (inline make-null-row)) +(defun make-null-row () + (uffi:make-null-pointer 'string-array-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 a)) + (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array :cstring) n)) + +(declaim (inline sqlite-free-row)) +(defun sqlite-free-row (row) + (declare (type sqlite-row-pointer row)) + (free-foreign-object row)) diff --git a/db-sqlite/sqlite-loader.lisp b/db-sqlite/sqlite-loader.lisp new file mode 100644 index 0000000..5b1eef9 --- /dev/null +++ b/db-sqlite/sqlite-loader.lisp @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-loader.lisp +;;;; Purpose: SQLite library loader using UFFI +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Nov 2003 +;;;; +;;;; $Id: sqlite-loader.lisp,v 1.2 2003/12/03 14:07:31 aurelio Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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 :clsql-sqlite) + +(defvar *sqlite-supporting-libraries* '("c") + "Used only by CMU. List of library flags needed to be passed to ld +to load the SQLite library succesfully. If this differs at your site, +set to the right path before compiling or loading the system.") + +(defvar *sqlite-library-loaded* #+clisp t + #-clisp nil + "T if foreign library was able to be loaded successfully") + +(defmethod database-type-library-loaded ((database-type (eql :sqlite))) + "T if foreign library was able to be loaded successfully. " + *sqlite-library-loaded*) + +(defmethod database-type-load-foreign ((database-type (eql :sqlite))) + #+clisp + t + #-clisp + (let ((libpath (uffi:find-foreign-library + "libsqlite" + '("/usr/lib/" "/usr/local/lib/") + :drive-letters '("C" "D" "E")))) + (if (uffi:load-foreign-library libpath + :module "sqlite" + :supporting-libraries + *sqlite-supporting-libraries*) + (setq *sqlite-library-loaded* t) + (warn "Can't load SQLite library ~A" libpath)))) + +(clsql-base-sys:database-type-load-foreign :sqlite) + + + diff --git a/db-sqlite/sqlite-package.lisp b/db-sqlite/sqlite-package.lisp new file mode 100644 index 0000000..00c4d97 --- /dev/null +++ b/db-sqlite/sqlite-package.lisp @@ -0,0 +1,23 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-package.lisp +;;;; Purpose: Package definition for low-level SQLite interface +;;;; Programmer: Aurelio Bignoli +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id: sqlite-package.lisp,v 1.2 2003/11/27 20:23:26 aurelio Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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 :clsql-sqlite + (:use :common-lisp :clsql-base-sys) + (:export #:sqlite-database)) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp new file mode 100644 index 0000000..78068fb --- /dev/null +++ b/db-sqlite/sqlite-sql.lisp @@ -0,0 +1,179 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-sql.lisp +;;;; Purpose: High-level SQLite interface +;;;; Programmers: Aurelio Bignoli +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id: sqlite-sql.lisp,v 1.5 2004/03/09 20:57:44 aurelio Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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. +;;;; ************************************************************************* + +(declaim (optimize (speed 3) (debug 0) (safety 0))) + +(in-package :clsql-sqlite) + +(defclass sqlite-database (database) + ((sqlite-db :initarg :sqlite-db :accessor sqlite-db))) + +(defmethod database-initialize-database-type ((database-type (eql :sqlite))) + t) + +(defun check-sqlite-connection-spec (connection-spec) + (check-connection-spec connection-spec :sqlite (name))) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :sqlite))) + (check-sqlite-connection-spec connection-spec) + (first connection-spec)) + +(defmethod database-connect (connection-spec (database-type (eql :sqlite))) + (check-sqlite-connection-spec connection-spec) + (handler-case + (make-instance 'sqlite-database + :name (database-name-from-spec connection-spec :sqlite) + :sqlite-db (sqlite:sqlite-open (first connection-spec))) + (sqlite:sqlite-error (err) + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (sqlite:sqlite-error-code err) + :error (sqlite:sqlite-error-message err))))) + +(defmethod database-disconnect ((database sqlite-database)) + (sqlite:sqlite-close (sqlite-db database)) + (setf (sqlite-db database) nil) + t) + +(defmethod database-execute-command (sql-expression (database sqlite-database)) + (handler-case + (multiple-value-bind (data row-n col-n) + (sqlite:sqlite-get-table (sqlite-db database) sql-expression) + #+clisp (declare (ignore data)) + #-clisp (sqlite:sqlite-free-table data) + (unless (= row-n 0) + (error 'clsql-simple-warning + :format-control + "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " + :format-arguments (list row-n col-n)))) + (sqlite:sqlite-error (err) + (error 'clsql-sql-error + :database database + :expression sql-expression + :errno (sqlite:sqlite-error-code err) + :error (sqlite:sqlite-error-message err)))) + t) + +(defmethod database-query (query-expression (database sqlite-database) types) + (declare (ignore types)) ; SQLite is typeless! + (handler-case + (multiple-value-bind (data row-n col-n) + (sqlite:sqlite-get-table (sqlite-db database) query-expression) + #-clisp (declare (type sqlite:sqlite-row-pointer data)) + (if (= row-n 0) + nil + (prog1 + ;; The first col-n elements are column names. + (loop for i from col-n below (* (1+ row-n) col-n) by col-n + collect (loop for j from 0 below col-n + collect + (#+clisp aref + #-clisp sqlite:sqlite-aref + data (+ i j)))) + #-clisp (sqlite:sqlite-free-table data)) + )) + (sqlite:sqlite-error (err) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (sqlite:sqlite-error-code err) + :error (sqlite:sqlite-error-message err))))) + +#-clisp +(defstruct sqlite-result-set + (vm (sqlite:make-null-vm) + :type sqlite:sqlite-vm-pointer) + (first-row (sqlite:make-null-row) + :type sqlite:sqlite-row-pointer) + (n-col 0 :type fixnum)) +#+clisp +(defstruct sqlite-result-set + (vm nil) + (first-row nil) + (n-col 0 :type fixnum)) + +(defmethod database-query-result-set + (query-expression (database sqlite-database) &key full-set types) + (declare (ignore full-set types)) + (handler-case + (let* ((vm (sqlite:sqlite-compile (sqlite-db database) + query-expression)) + (result-set (make-sqlite-result-set :vm vm))) + #-clisp (declare (type sqlite:sqlite-vm-pointer vm)) + + ;;; To obtain column number we have to read the first row. + (multiple-value-bind (n-col cols col-names) + (sqlite:sqlite-step vm) + (declare (ignore col-names) + #-clisp (type sqlite:sqlite-row-pointer cols) + ) + (setf (sqlite-result-set-first-row result-set) cols + (sqlite-result-set-n-col result-set) n-col) + (values result-set n-col nil))) + (sqlite:sqlite-error (err) + (error 'clsql-sql-error + :database database + :expression query-expression + :errno (sqlite:sqlite-error-code err) + :error (sqlite:sqlite-error-message err))))) + +(defmethod database-dump-result-set (result-set (database sqlite-database)) + (declare (ignore database)) + (handler-case + (sqlite:sqlite-finalize (sqlite-result-set-vm result-set)) + (sqlite:sqlite-error (err) + (error 'clsql-simple-error + :format-control "Error finalizing SQLite VM: ~A" + :format-arguments (list (sqlite:sqlite-error-message err)))))) + +(defmethod database-store-next-row (result-set (database sqlite-database) list) + (let ((n-col (sqlite-result-set-n-col result-set))) + (if (= n-col 0) + ;; empty result set + nil + (let ((row (sqlite-result-set-first-row result-set))) + (if (sqlite:null-row-p row) + ;; First row already used. fetch another row from DB. + (handler-case + (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 new-row) + ) + (if (sqlite:null-row-p new-row) + (return-from database-store-next-row nil) + (setf row new-row))) + (sqlite:sqlite-error (err) + (error 'clsql-simple-error + :format-control "Error in sqlite-step: ~A" + :format-arguments + (list (sqlite:sqlite-error-message err))))) + + ;; Use the row previously read by database-query-result-set. + (setf (sqlite-result-set-first-row result-set) + (sqlite:make-null-row))) + (loop for i = 0 then (1+ i) + for rest on list + do (setf (car rest) + (#+clisp aref + #-clisp sqlite:sqlite-aref + row i))) + #-clisp (sqlite:sqlite-free-row row) + t)))) diff --git a/db-sqlite/sqlite-usql.lisp b/db-sqlite/sqlite-usql.lisp new file mode 100644 index 0000000..4d66be7 --- /dev/null +++ b/db-sqlite/sqlite-usql.lisp @@ -0,0 +1,70 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sqlite-usql.lisp +;;;; Purpose: SQLite interface for USQL routines +;;;; Programmers: Aurelio Bignoli +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id: sqlite-usql.lisp,v 1.3 2004/03/09 20:58:38 aurelio Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli +;;;; +;;;; 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 :clsql-sqlite) + +(defun %sequence-name-to-table-name (sequence-name) + (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) + +(defmethod database-create-sequence (sequence-name + (database sqlite-database)) + (let ((table-name (%sequence-name-to-table-name sequence-name))) + (database-execute-command + (concatenate 'string "CREATE TABLE " table-name + " (id INTEGER PRIMARY KEY)") + database) + (database-execute-command + (format nil "INSERT INTO ~A VALUES (-1)" table-name) + database))) + +(defmethod database-drop-sequence (sequence-name + (database sqlite-database)) + (database-execute-command + (concatenate 'string "DROP TABLE " + (%sequence-name-to-table-name sequence-name)) + database)) + +(defmethod database-sequence-next (sequence-name (database sqlite-database)) + (let ((table-name (%sequence-name-to-table-name sequence-name))) + (database-execute-command + (format nil "UPDATE ~A SET id=(SELECT id FROM ~A)+1" + table-name table-name) + database)) + (sqlite:sqlite-last-insert-rowid (sqlite-db database))) + +(defmethod database-list-tables ((database sqlite-database) &key system-tables) + (declare (ignore system-tables)) + ;; Query is copied from .table command of sqlite comamnd line utility. + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database '()))) + +(declaim (inline sqlite-table-info)) +(defun sqlite-table-info (table database) + (database-query (format nil "PRAGMA table_info('~A')" table) + database '())) + +(defmethod database-list-attributes (table (database sqlite-database)) + (mapcar #'(lambda (table-info) (third table-info)) + (sqlite-table-info table database))) + +(defmethod database-attribute-type (attribute table + (database sqlite-database)) + (loop for field-info in (sqlite-table-info table database) + when (string= attribute (second field-info)) + return (third field-info))) diff --git a/debian/changelog b/debian/changelog index 6627c26..22e69c3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (1.9.0-1) unstable; urgency=low + + * Add SQLlite backend as contributed by Aurelio Bignoli + + -- Kevin M. Rosenberg Wed, 10 Mar 2004 15:19:46 -0700 + cl-sql (1.8.7-1) unstable; urgency=low * New upstream diff --git a/doc/html.tar.gz b/doc/html.tar.gz index 8a1521e..0e952d1 100644 Binary files a/doc/html.tar.gz and b/doc/html.tar.gz differ diff --git a/tests/tests.lisp b/tests/tests.lisp index dd609f0..76d0dd9 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -26,7 +26,8 @@ ;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) ;;; (:aodbc ("my-dsn" "a-user" "pass")) ;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) -;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")) +;;; (:sqlite ("path-to-sqlite-db"))) (in-package :clsql-tests) @@ -40,7 +41,8 @@ ((aodbc-spec :accessor aodbc-spec) (mysql-spec :accessor mysql-spec) (pgsql-spec :accessor pgsql-spec) - (pgsql-socket-spec :accessor pgsql-socket-spec)) + (pgsql-socket-spec :accessor pgsql-socket-spec) + (sqlite-spec :accessor sqlite-spec)) (:documentation "Test fixture for CLSQL testing")) @@ -54,6 +56,7 @@ (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) (setf (pgsql-socket-spec specs) (cadr (assoc :postgresql-socket config))) + (setf (sqlite-spec specs) (cadr (assoc :sqlite config))) specs)) (progn (warn "CLSQL tester config file ~S not found" path) @@ -71,6 +74,9 @@ (defmethod pgsql-socket-table-test ((test conn-specs)) (test-table (pgsql-socket-spec test) :postgresql-socket)) +(defmethod sqlite-table-test ((test conn-specs)) + (test-table (sqlite-spec test) :sqlite)) + (defmethod test-table (spec type) (when spec (let ((db (clsql:connect spec :database-type type :if-exists :new))) @@ -105,8 +111,32 @@ ) (disconnect :database db))))) +;;; +;;; SQLite is typeless: execute untyped tests only. +;;; +(defmethod test-table (spec (type (eql :sqlite))) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil type)) + (drop-test-table db) + ) + (disconnect :database db))))) (defmethod mysql-low-level ((test conn-specs)) + #-clisp (let ((spec (mysql-spec test))) (when spec (let ((db (clsql-mysql::database-connect spec :mysql))) @@ -197,11 +227,12 @@ (test t nil :fail-info (format nil "Invalid types field (~S) passed to test-table-row" types)))) - (test (transform-float-1 int) - float - :test #'eql - :fail-info - (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) + (unless (eq db-type :sqlite) ; SQLite is typeless. + (test (transform-float-1 int) + float + :test #'eql + :fail-info + (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))) (test float (parse-double str) :test #'double-float-equal @@ -233,6 +264,7 @@ (pgsql-table-test specs) (pgsql-socket-table-test specs) (aodbc-table-test specs) + (sqlite-table-test specs) )) t)