+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
--- /dev/null
+;;;; -*- 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 <aurelio@bignoli.it>"
+ :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))
: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
--- /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: 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))))))))
+\f
+;;;; Local Variables:
+;;;; Mode: lisp
+;;;; Syntax: ANSI-Common-Lisp
+;;;; Package: sqlite
+;;;; End:
\ No newline at end of file
--- /dev/null
+;;;; -*- 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))
--- /dev/null
+;;;; -*- 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)
+
+
+
--- /dev/null
+;;;; -*- 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))
--- /dev/null
+;;; -*- 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))))
--- /dev/null
+;;;; -*- 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)))
+cl-sql (1.9.0-1) unstable; urgency=low
+
+ * Add SQLlite backend as contributed by Aurelio Bignoli
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Wed, 10 Mar 2004 15:19:46 -0700
+
cl-sql (1.8.7-1) unstable; urgency=low
* New upstream
;;; ((: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)
((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"))
(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)
(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)))
)
(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)))
(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
(pgsql-table-test specs)
(pgsql-socket-table-test specs)
(aodbc-table-test specs)
+ (sqlite-table-test specs)
))
t)
projects / clsql.git / commitdiff