+31 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net>
+ * clsql-sqlite3, db-sqlite3/*: NEW BACKEND
+ contributed by Aurelio Bignoli
+
23 Oct 2004 Kevin Rosenberg <kevin@rosenberg.net>
* sql/oodml.lisp: Commit patch from Walter Pelis
to use an object's database for a select on its slot.
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: clsql-sqlite.asd
+;;;; Purpose: ASDF file for CLSQL SQLite3 backend
+;;;; Programmer: Aurelio Bignoli
+;;;; Date Started: Oct 2004
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 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-sqlite3-system (:use #:asdf #:cl))
+(in-package #:clsql-sqlite3-system)
+
+(defsystem clsql-sqlite3
+ :name "cl-sql-sqlite3"
+ :author "Aurelio Bignoli <aurelio@bignoli.it>"
+ :maintainer "Aurelio Bignoli"
+ :licence "Lessor Lisp General Public License"
+ :description "Common Lisp Sqlite3 Driver"
+ :long-description "cl-sql-sqlite3 package provides a database driver to SQLite Versione 3 database library."
+
+
+ :depends-on (clsql clsql-uffi)
+ :components
+ ((:module :db-sqlite3
+ :components
+ ((:file "sqlite3-package")
+ (:file "sqlite3-loader" :depends-on ("sqlite3-package"))
+ (:file "sqlite3-api" :depends-on ("sqlite3-loader"))
+ (:file "sqlite3-sql" :depends-on ("sqlite3-api"))))))
--- /dev/null
+# FILE IDENTIFICATION
+#
+# Name: Makefile
+# Purpose: Makefile for SQLite 3 init function example.
+# Programer: Aurelio Bignoli
+# Date Started: Oct 2004
+#
+# CVS Id: $Id$
+#
+# This file, part of CLSQL, is Copyright (c) 2004 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.
+
+sqlite3-utils.so: iso-8859-15-coll.c Makefile
+ gcc -c -fPIC iso-8859-15-coll.c -o iso-8859-15-coll.o
+ gcc -shared iso-8859-15-coll.o -o sqlite3-utils.so -l sqlite3
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: example.lisp
+;;;; Purpose: Sample code for SQLite 3 initialization functions
+;;;; Authors: Aurelio Bignoli
+;;;; Created: Oct 2004
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 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.
+;;;; *************************************************************************
+
+;;;; Load CLSQL.
+(asdf:oos 'asdf:load-op :clsql-sqlite3)
+
+;;;; Load sqlite3-utils.so library. See Makefile for library creation.
+(unless (uffi:load-foreign-library "/usr/lib/clsql/sqlite3-utils.so"
+ :module "sqlite3-utils"
+ :supporting-libraries '("c"))
+ (error "Unable to load foreign library"))
+
+;;;; Define the foreign function to be used as init function.
+(uffi:def-function
+ ("create_iso_8859_15_ci_collation" create-coll)
+ ((db sqlite3:sqlite3-db))
+ :returning :int
+ :module "sqlite3-utils")
+
+;;;; Create the DB using create-coll as init function.
+(defparameter db-name "init-func-test.db")
+(clsql:destroy-database (list db-name) :database-type :sqlite3)
+(clsql:connect (list db-name #'create-coll) :database-type :sqlite3)
+
+;;;; Create a table. Field f2 uses the newly defined collating
+;;;; sequence.
+(clsql:execute-command
+ "CREATE TABLE t1 (f1 CHAR(1), f2 CHAR(1) COLLATE ISO_8859_15_CI)")
+
+;;;; Populate the table.
+(clsql:execute-command "INSERT INTO t1 VALUES ('à', 'à')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('a', 'a')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('A', 'A')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('é', 'é')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('e', 'e')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('E', 'E')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('ì', 'ì')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('i', 'i')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('I', 'I')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('ò', 'ò')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('o', 'o')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('O', 'O')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('ù', 'ù')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('u', 'u')")
+(clsql:execute-command "INSERT INTO t1 VALUES ('U', 'U')")
+
+;;;; Perform some SELECTs.
+(format t "~&SELECT * FROM t1 ==> ~A~%"(clsql:query "SELECT * FROM t1"))
+(format t "~&SELECT * FROM t1 ORDER BY f1 ==> ~A~%"
+ (clsql:query "SELECT * FROM t1 ORDER BY f1"))
+(format t "~&SELECT * FROM t1 ORDER BY f2 ==> ~A~%"
+ (clsql:query "SELECT * FROM t1 ORDER BY f2"))
+
+;;;; Disconnect from database.
+(clsql:disconnect)
\ No newline at end of file
--- /dev/null
+/****************************************************************************
+ * FILE IDENTIFICATION
+ *
+ * Name: iso-8859-15-coll.c
+ * Purpose: SQLite 3 initialization function for
+ * ISO-8859-15 collating sequence.
+ * Programmer: Aurelio Bignoli
+ * Date Started: Oct 2004
+ *
+ * $Id$
+ *
+ * This file, part of CLSQL, is Copyright (c) 2004 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.
+ ***************************************************************************/
+
+
+/* Collating sequence name. CI = Case Insensitive */
+#define ISO_8859_15_CI_NAME "ISO_8859_15_CI"
+
+/* Conversion table. */
+const unsigned char iso_8859_15_ci [] = {
+ /* 0 */ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
+ /* 1 */ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F,
+ /* 2 */ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2D, 0x2E, 0x2F,
+ /* 3 */ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F,
+ /* 4 */ 0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,
+ /* 5 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F,
+ /* 6 */ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,
+ /* 7 */ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x7C, 0x7D, 0x7E, 0x7F,
+ /* 8 */ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x73, 0x8B, 0x6F, 0x8D, 0x7A, 0x79,
+ /* 9 */ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x73, 0x9B, 0x6F, 0x9D, 0x7A, 0x79,
+ /* A */ 0xA0, 0xA1, 0xA2, 0xA3, 0xA4, 0xA5, 0x73, 0xA7, 0x73, 0xA9, 0xAA, 0xAB, 0xAC, 0xAD, 0xAE, 0xAF,
+ /* B */ 0xB0, 0xB1, 0xB2, 0xB3, 0x7A, 0xB5, 0xB6, 0xB7, 0x7A, 0xB9, 0xBA, 0xBB, 0x6F, 0xBD, 0x79, 0xBF,
+ /* C */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69,
+ /* D */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xD7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xDE, 0x73,
+ /* E */ 0x61, 0x61, 0x61, 0x61, 0x61, 0x61, 0x65, 0x63, 0x65, 0x65, 0x65, 0x65, 0x69, 0x69, 0x69, 0x69,
+ /* F */ 0x64, 0x6E, 0x6F, 0x6F, 0x6F, 0x6F, 0x6F, 0xF7, 0x6F, 0x75, 0x75, 0x75, 0x75, 0x79, 0xFE, 0x73
+};
+
+/*
+ * A modified version of sqlite3StrNICmp in sqlite/src/util.c
+ */
+int iso_8859_15_ci_StrCmp(const char *zLeft, const char *zRight, int N){
+ register unsigned char *a, *b;
+ a = (unsigned char *)zLeft;
+ b = (unsigned char *)zRight;
+ while( N-- > 0 && *a!=0 && iso_8859_15_ci[*a]==iso_8859_15_ci[*b]){ a++; b++; }
+ return N<0 ? 0 : iso_8859_15_ci[*a] - iso_8859_15_ci[*b];
+}
+
+/*
+ * A modified version of nocaseCollatinFunc in sqlite/src/main.c.
+ */
+int iso_8859_15_ci_CollatingFunc(
+ void *NotUsed,
+ int nKey1, const void *pKey1,
+ int nKey2, const void *pKey2
+){
+ int r = iso_8859_15_ci_StrCmp(
+ (const char *)pKey1, (const char *)pKey2, (nKey1<nKey2)?nKey1:nKey2);
+ if( 0==r ){
+ r = nKey1-nKey2;
+ }
+ return r;
+}
+
+/*
+ * Set the ISO_8859_15_CI collating sequence for a db.
+ */
+#include "sqlite3.h"
+
+int create_iso_8859_15_ci_collation (sqlite3 *db)
+{
+ return sqlite3_create_collation (db, ISO_8859_15_CI_NAME, SQLITE_UTF8, 0,
+ iso_8859_15_ci_CollatingFunc);
+}
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sqlite3-api.lisp
+;;;; Purpose: Low-level SQLite3 interface using UFFI
+;;;; Authors: Aurelio Bignoli
+;;;; Created: Oct 2004
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 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 #:sqlite3
+ (:use #:common-lisp #:uffi)
+ (:export
+ ;;; Conditions
+ #:sqlite3-error
+ #:sqlite3-error-code
+ #:sqlite3-error-message
+
+ ;;; API functions.
+ #:sqlite3-open
+ #:sqlite3-close
+
+ #:sqlite3-prepare
+ #:sqlite3-step
+ #:sqlite3-finalize
+
+ #:sqlite3-column-count
+ #:sqlite3-column-name
+ #:sqlite3-column-type
+ #:sqlite3-column-text
+ #:sqlite3-column-bytes
+ #:sqlite3-column-blob
+
+ ;;; Types.
+ #:sqlite3-db
+ #:sqlite3-db-type
+ #:sqlite3-stmt-type
+ #:unsigned-char-ptr-type
+ #:null-stmt
+
+ ;;; Columnt types.
+ #:SQLITE-INTEGER
+ #:SQLITE-FLOAT
+ #:SQLITE-TEXT
+ #:SQLITE-BLOB
+ #:SQLITE-NULL))
+
+(in-package #:sqlite3)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; 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 sqlite3_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 "Database 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-RANGE 25 "2nd parameter to sqlite3_bind out of range")
+(defconstant SQLITE-NOTADB 26 "File opened that is not a database file")
+(defconstant SQLITE-ROW 100 "sqlite3_step() has another row ready")
+(defconstant SQLITE-DONE 101 "sqlite3_step() has finished executing")
+
+(defparameter error-codes
+ (list
+ (cons SQLITE-OK "not an error")
+ (cons SQLITE-ERROR "SQL logic error or missing database")
+ (cons SQLITE-INTERNAL "internal SQLite implementation flaw")
+ (cons SQLITE-PERM "access permission denied")
+ (cons SQLITE-ABORT "callback requested query abort")
+ (cons SQLITE-BUSY "database is locked")
+ (cons SQLITE-LOCKED "database table is locked")
+ (cons SQLITE-NOMEM "out of memory")
+ (cons SQLITE-READONLY "attempt to write a readonly database")
+ (cons SQLITE-INTERRUPT "interrupted")
+ (cons SQLITE-IOERR "disk I/O error")
+ (cons SQLITE-CORRUPT "database disk image is malformed")
+ (cons SQLITE-NOTFOUND "table or record not found")
+ (cons SQLITE-FULL "database is full")
+ (cons SQLITE-CANTOPEN "unable to open database file")
+ (cons SQLITE-PROTOCOL "database locking protocol failure")
+ (cons SQLITE-EMPTY "table contains no data")
+ (cons SQLITE-SCHEMA "database schema has changed")
+ (cons SQLITE-TOOBIG "too much data for one table row")
+ (cons SQLITE-CONSTRAINT "constraint failed")
+ (cons SQLITE-MISMATCH "datatype mismatch")
+ (cons SQLITE-MISUSE "library routine called out of sequence")
+ (cons SQLITE-NOLFS "kernel lacks large file support")
+ (cons SQLITE-AUTH "authorization denied")
+ (cons SQLITE-FORMAT "auxiliary database format error")
+ (cons SQLITE-RANGE "bind index out of range")
+ (cons SQLITE-NOTADB "file is encrypted or is not a database"))
+ "Association list of error messages.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Column types.
+;;;;
+(defconstant SQLITE-INTEGER 1)
+(defconstant SQLITE-FLOAT 2)
+(defconstant SQLITE-TEXT 3)
+(defconstant SQLITE-BLOB 4)
+(defconstant SQLITE-NULL 5)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Foreign types definitions.
+;;;;
+(def-foreign-type sqlite3-db :pointer-void)
+(def-foreign-type sqlite3-stmt :pointer-void)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Lisp types definitions.
+;;;;
+(def-type sqlite3-db-type sqlite3-db)
+(def-type sqlite3-db-ptr-type (* sqlite3-db))
+(def-type sqlite3-stmt-type sqlite3-stmt)
+(def-type sqlite3-stmt-ptr-type (* sqlite3-stmt))
+(def-type unsigned-char-ptr-type (* :unsigned-char))
+
+(defparameter null-stmt (make-null-pointer :void))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Hash tables for db and statement pointers.
+;;;
+(defvar *db-pointers* (make-hash-table))
+(defvar *stmt-pointers* (make-hash-table))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Conditions.
+;;;;
+(define-condition sqlite3-error ()
+ ((message :initarg :message :reader sqlite3-error-message :initform "")
+ (code :initarg :code :reader sqlite3-error-code))
+ (:report (lambda (condition stream)
+ (format stream "Sqlite3 error [~A]: ~A"
+ (sqlite3-error-code condition)
+ (sqlite3-error-message condition)))))
+
+(defmethod signal-sqlite3-error (db)
+ (let ((condition
+ (make-condition 'sqlite3-error
+ :code (sqlite3-errcode db)
+ :message (convert-from-cstring (sqlite3-errmsg db)))))
+ (unless (signal condition)
+ (invoke-debugger condition))))
+
+(defmethod signal-sqlite3-error ((code number))
+ (let ((condition
+ (make-condition 'sqlite3-error
+ :code code
+ :message (let ((s (cdr (assoc code error-codes))))
+ (if s
+ s
+ "unknown error")))))
+ (unless (signal condition)
+ (invoke-debugger condition))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Library functions.
+;;;;
+(defmacro def-sqlite3-function (name args &key (returning :void))
+ `(def-function ,name ,args
+ :module "sqlite3"
+ :returning ,returning))
+
+(declaim (inline %errcode))
+(def-sqlite3-function
+ "sqlite3_errcode"
+ ((db sqlite3-db))
+ :returning :int)
+
+(declaim (inline %errmsg))
+(def-sqlite3-function
+ "sqlite3_errmsg"
+ ((db sqlite3-db))
+ :returning :cstring)
+
+(declaim (inline %open))
+(def-sqlite3-function
+ ("sqlite3_open" %open)
+ ((dbname :cstring)
+ (db (* sqlite3-db)))
+ :returning :int)
+
+(declaim (inline %close))
+(def-sqlite3-function
+ ("sqlite3_close" %close)
+ ((db sqlite3-db))
+ :returning :int)
+
+(declaim (inline %prepare))
+(def-sqlite3-function
+ ("sqlite3_prepare" %prepare)
+ ((db sqlite3-db)
+ (sql :cstring)
+ (len :int)
+ (stmt (* sqlite3-stmt))
+ (sql-tail (* (* :unsigned-char))))
+ :returning :int)
+
+(declaim (inline %step))
+(def-sqlite3-function
+ ("sqlite3_step" %step)
+ ((stmt sqlite3-stmt))
+ :returning :int)
+
+(declaim (inline %finalize))
+(def-sqlite3-function
+ ("sqlite3_finalize" %finalize)
+ ((stmt sqlite3-stmt))
+ :returning :int)
+
+(declaim (inline sqlite3-column-count))
+(def-sqlite3-function
+ "sqlite3_column_count"
+ ((stmt sqlite3-stmt))
+ :returning :int)
+
+(declaim (inline %column-name))
+(def-sqlite3-function
+ ("sqlite3_column_name" %column-name)
+ ((stmt sqlite3-stmt)
+ (n-col :int))
+ :returning :cstring)
+
+(declaim (inline sqlite3-column-type))
+(def-sqlite3-function
+ "sqlite3_column_type"
+ ((stmt sqlite3-stmt)
+ (n-col :int))
+ :returning :int)
+
+(declaim (inline sqlite3-column-text))
+(def-sqlite3-function
+ "sqlite3_column_text"
+ ((stmt sqlite3-stmt)
+ (n-col :int))
+ :returning (* :unsigned-char))
+
+(declaim (inline sqlite3-column-bytes))
+(def-sqlite3-function
+ "sqlite3_column_bytes"
+ ((stmt sqlite3-stmt)
+ (n-col :int))
+ :returning :int)
+
+(declaim (inline sqlite3-column-blob))
+(def-sqlite3-function
+ "sqlite3_column_blob"
+ ((stmt sqlite3-stmt)
+ (n-col :int))
+ :returning :pointer-void)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; wrapper functions.
+;;;;
+(defun sqlite3-open (db-name &optional (mode 0))
+ (declare (ignore mode) (type string db-name))
+ (let ((dbp (allocate-foreign-object 'sqlite3-db)))
+ (declare (type sqlite3-db-ptr-type dbp))
+ (with-cstring (db-name-native db-name)
+ (let ((result (%open db-name-native dbp)))
+ (if (/= result 0)
+ (progn
+ ;; According to docs, the db must be closed even in case
+ ;; of error.
+ (%close (deref-pointer dbp 'sqlite3-db))
+ (free-foreign-object dbp)
+ (signal-sqlite3-error result))
+ (let ((db (deref-pointer dbp 'sqlite3-db)))
+ (declare (type sqlite3-db-type db))
+ (setf (gethash db *db-pointers*) dbp)
+ db))))))
+
+(declaim (ftype (function (sqlite3-db-type) t) sqlite3-close))
+(defun sqlite3-close (db)
+ (declare (type sqlite3-db-type db))
+ (let ((result (%close db)))
+ (if (/= result 0)
+ (signal-sqlite3-error result)
+ (progn
+ (free-foreign-object (gethash db *db-pointers*))
+ (remhash db *db-pointers*)
+ t))))
+
+(declaim (ftype (function (sqlite3-db-type string) sqlite3-stmt-type) sqlite3-prepare))
+(defun sqlite3-prepare (db sql)
+ (declare (type sqlite3-db-type db))
+ (with-cstring (sql-native sql)
+ (let ((stmtp (allocate-foreign-object 'sqlite3-stmt)))
+ (declare (type sqlite3-stmt-ptr-type stmtp))
+ (with-foreign-object (sql-tail '(* :unsigned-char))
+ (let ((result (%prepare db sql-native -1 stmtp sql-tail)))
+ (if (/= result SQLITE-OK)
+ (progn
+ (unless (null-pointer-p stmtp)
+ ;; There is an error, but a statement has been allocated:
+ ;; finalize it (better safe than sorry).
+ (%finalize (deref-pointer stmtp 'sqlite3-stmt)))
+ (free-foreign-object stmtp)
+ (signal-sqlite3-error db))
+ (let ((stmt (deref-pointer stmtp 'sqlite3-stmt)))
+ (declare (type sqlite3-stmt-type stmt))
+ (setf (gethash stmt *stmt-pointers*) stmtp)
+ stmt)))))))
+
+(declaim (ftype (function (sqlite3-stmt-type) t) sqlite3-step))
+(defun sqlite3-step (stmt)
+ (declare (type sqlite3-stmt-type stmt))
+ (let ((result (%step stmt)))
+ (cond ((= result SQLITE-ROW) t)
+ ((= result SQLITE-DONE) nil)
+ (t (signal-sqlite3-error result)))))
+
+(declaim (ftype (function (sqlite3-stmt-type) t) sqlite3-finalize))
+(defun sqlite3-finalize (stmt)
+ (declare (type sqlite3-stmt-type stmt))
+ (let ((result (%finalize stmt)))
+ (if (/= result SQLITE-OK)
+ (signal-sqlite3-error result)
+ (progn
+ (free-foreign-object (gethash stmt *stmt-pointers*))
+ (remhash stmt *stmt-pointers*)
+ t))))
+
+(declaim (inline sqlite3-column-name))
+(defun sqlite3-column-name (stmt n)
+ (declare (type sqlite3-stmt-type stmt) (type fixnum n))
+ (convert-from-cstring (%column-name stmt n)))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sqlite3-loader.lisp
+;;;; Purpose: Sqlite3 library loader using UFFI
+;;;; Programmer: Aurelio Bignoli
+;;;; Date Started: Oct 2004
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 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-sqlite3)
+
+(defvar *sqlite3-supporting-libraries* '("c")
+ "Used only by CMU. List of library flags needed to be passed to ld
+to load the Sqlite3 library succesfully. If this differs at your site,
+set to the right path before compiling or loading the system.")
+
+(defvar *sqlite3-library-loaded* nil
+ "T if foreign library was able to be loaded successfully")
+
+(defmethod database-type-library-loaded ((database-type (eql :sqlite3)))
+ "T if foreign library was able to be loaded successfully. "
+ *sqlite3-library-loaded*)
+
+(defmethod database-type-load-foreign ((database-type (eql :sqlite3)))
+ (let ((libpath (uffi:find-foreign-library
+ '("libsqlite3" "sqlite3")
+ '(#+64bit "/usr/lib64/"
+ "/usr/lib/" "/usr/local/lib/" "/bin/")
+ :drive-letters '("C" "D" "E"))))
+ (if (uffi:load-foreign-library libpath
+ :module "sqlite3"
+ :supporting-libraries
+ *sqlite3-supporting-libraries*)
+ (setq *sqlite3-library-loaded* t)
+ (warn "Can't load Sqlite3 library ~A" libpath))))
+
+(clsql-sys:database-type-load-foreign :sqlite3)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sqlite-package.lisp
+;;;; Purpose: Package definition for low-level SQLite3 interface
+;;;; Programmer: Aurelio Bignoli
+;;;; Date Started: Oct 2004
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 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-sqlite3
+ (:use #:common-lisp #:clsql-sys)
+ (:export #:sqlite3-database))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sqlite-sql.lisp
+;;;; Purpose: High-level SQLite3 interface
+;;;; Authors: Aurelio Bignoli
+;;;; Created: Oct 2004
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2004 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-sqlite3)
+
+(defclass sqlite3-database (database)
+ ((sqlite3-db :initarg :sqlite3-db :accessor sqlite3-db)))
+
+(defmethod database-type ((database sqlite3-database))
+ :sqlite3)
+
+(defmethod database-initialize-database-type ((database-type (eql :sqlite3)))
+ t)
+
+(defun check-sqlite3-connection-spec (connection-spec)
+ (check-connection-spec connection-spec :sqlite3 (name &optional init-foreign-func)))
+
+(defmethod database-name-from-spec (connection-spec
+ (database-type (eql :sqlite3)))
+ (check-sqlite3-connection-spec connection-spec)
+ (first connection-spec))
+
+(defmethod database-connect (connection-spec (database-type (eql :sqlite3)))
+ (check-sqlite3-connection-spec connection-spec)
+ (handler-case
+ (let ((db (sqlite3:sqlite3-open (first connection-spec)))
+ (init-foreign-func (second connection-spec)))
+ (declare (type sqlite3:sqlite3-db-type db))
+ (when init-foreign-func
+ (handler-case
+ (funcall init-foreign-func db)
+ (condition (c)
+ (progn
+ (sqlite3:sqlite3-close db)
+ (error c)))))
+ (make-instance 'sqlite3-database
+ :name (database-name-from-spec connection-spec :sqlite3)
+ :database-type :sqlite3
+ :connection-spec connection-spec
+ :sqlite3-db db))
+ (sqlite3:sqlite3-error (err)
+ (error 'sql-connection-error
+ :database-type database-type
+ :connection-spec connection-spec
+ :error-id (sqlite3:sqlite3-error-code err)
+ :message (sqlite3:sqlite3-error-message err)))))
+
+(defmethod database-disconnect ((database sqlite3-database))
+ (sqlite3:sqlite3-close (sqlite3-db database))
+ (setf (sqlite3-db database) nil)
+ t)
+
+(defmethod database-execute-command (sql-expression (database sqlite3-database))
+ (handler-case
+ (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) sql-expression)))
+ (declare (type sqlite3:sqlite3-stmt-type stmt))
+ (when stmt
+ (unwind-protect
+ (sqlite3:sqlite3-step stmt)
+ (sqlite3:sqlite3-finalize stmt))))
+ (sqlite3:sqlite3-error (err)
+ (error 'sql-database-data-error
+ :database database
+ :expression sql-expression
+ :error-id (sqlite3:sqlite3-error-code err)
+ :message (sqlite3:sqlite3-error-message err))))
+ t)
+
+(defstruct sqlite3-result-set
+ (stmt sqlite3:null-stmt
+ :type sqlite3:sqlite3-stmt-type)
+ (n-col 0 :type fixnum)
+ (col-names '())
+ (result-types '()))
+
+(declaim (ftype (function (sqlite3:sqlite3-stmt-type fixnum t) list) get-result-types))
+(defun get-result-types (stmt n-col result-types)
+ (declare (type sqlite3:sqlite3-stmt-type stmt) (type fixnum n-col))
+ (if (eq :auto result-types)
+ (loop for n from 0 below n-col
+ collect (let ((column-type (sqlite3:sqlite3-column-type stmt n)))
+ (cond
+ ((= column-type sqlite3:SQLITE-INTEGER) :int64)
+ ((= column-type sqlite3:SQLITE-FLOAT) :double)
+ ((= column-type sqlite3:SQLITE-TEXT) :string)
+ ((= column-type sqlite3:SQLITE-BLOB) :blob)
+ ((= column-type sqlite3:SQLITE-NULL) :string)
+ (t :string))))
+ (loop for type in result-types
+ collect (case type
+ ((:int :integer :tinyint :long) :int32)
+ (:bigint :int64)
+ ((:float :double) :double)
+ ((:numeric) :number)
+ (otherwise :string)))))
+
+(defmethod database-query-result-set ((query-expression string)
+ (database sqlite3-database)
+ &key result-types full-set)
+ (let ((stmt sqlite3:null-stmt))
+ (declare (type sqlite3:sqlite3-stmt-type stmt))
+ (handler-case
+ (progn
+ (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database)
+ query-expression))
+ (let* ((n-col (if (sqlite3:sqlite3-step stmt)
+ ;; Non empty result set.
+ (sqlite3:sqlite3-column-count stmt)
+ ;; Empty result set.
+ 0))
+ (result-set (make-sqlite3-result-set
+ :stmt stmt
+ :n-col n-col
+ :col-names (loop for n from 0 below n-col
+ collect (sqlite3:sqlite3-column-name stmt n))
+ :result-types (when (> n-col 0)
+ (get-result-types stmt n-col result-types)))))
+ (if full-set
+ (values result-set n-col nil)
+ (values result-set n-col))))
+ (sqlite3:sqlite3-error (err)
+ (progn
+ (unless (eq stmt sqlite3:null-stmt)
+ (ignore-errors
+ (sqlite3:sqlite3-finalize stmt)))
+ (error 'sql-database-data-error
+ :database database
+ :expression query-expression
+ :error-id (sqlite3:sqlite3-error-code err)
+ :message (sqlite3:sqlite3-error-message err)))))))
+
+(defmethod database-dump-result-set (result-set (database sqlite3-database))
+ (handler-case
+ (sqlite3:sqlite3-finalize (sqlite3-result-set-stmt result-set))
+ (sqlite3:sqlite3-error (err)
+ (error 'sql-database-error
+ :message
+ (format nil "Error finalizing SQLite3 statement: ~A"
+ (sqlite3:sqlite3-error-message err))))))
+
+(defmethod database-store-next-row (result-set (database sqlite3-database) list)
+ (let ((n-col (sqlite3-result-set-n-col result-set)))
+ (if (= n-col 0)
+ ;; empty result set.
+ nil
+ ;; Non-empty set.
+ (let ((stmt (sqlite3-result-set-stmt result-set)))
+ (declare (type sqlite3:sqlite3-stmt-type stmt))
+ ;; Store row in list.
+ (loop for i = 0 then (1+ i)
+ for rest on list
+ for types = (sqlite3-result-set-result-types result-set) then (rest types)
+ do (setf (car rest)
+ (if (eq (first types) :blob)
+ (clsql-uffi:convert-raw-field
+ (sqlite3:sqlite3-column-blob stmt i)
+ types 0
+ (sqlite3:sqlite3-column-bytes stmt i))
+ (clsql-uffi:convert-raw-field
+ (sqlite3:sqlite3-column-text stmt i)
+ types 0))))
+ ;; Advance result set cursor.
+ (handler-case
+ (unless (sqlite3:sqlite3-step stmt)
+ (setf (sqlite3-result-set-n-col result-set) 0))
+ (sqlite3:sqlite3-error (err)
+ (error 'sql-database-error
+ :message "Error in sqlite3-step: ~A"
+ (sqlite3:sqlite3-error-message err))))
+ t))))
+
+
+(defmethod database-query (query-expression (database sqlite3-database) result-types field-names)
+ (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
+ (handler-case
+ (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database)
+ query-expression))
+ (rows '())
+ (col-names '()))
+ (declare (type sqlite3:sqlite3-stmt-type stmt))
+ (unwind-protect
+ (when (sqlite3:sqlite3-step stmt)
+ (let ((n-col (sqlite3:sqlite3-column-count stmt)))
+ (flet ((extract-row-data ()
+ (loop for i from 0 below n-col
+ for types = (get-result-types stmt n-col result-types) then (rest types)
+ collect (if (eq (first types) :blob)
+ (clsql-uffi:convert-raw-field
+ (sqlite3:sqlite3-column-blob stmt i)
+ types 0
+ (sqlite3:sqlite3-column-bytes stmt i))
+ (clsql-uffi:convert-raw-field
+ (sqlite3:sqlite3-column-text stmt i)
+ types 0)))))
+ (when field-names
+ (setf col-names (loop for n from 0 below n-col
+ collect (sqlite3:sqlite3-column-name stmt n))))
+ (push (extract-row-data) rows)
+ (do* () (nil)
+ (if (sqlite3:sqlite3-step stmt)
+ (push (extract-row-data) rows)
+ (return))))))
+ (sqlite3:sqlite3-finalize stmt))
+ (values (nreverse rows) col-names))
+ (sqlite3:sqlite3-error (err)
+ (error 'sql-database-data-error
+ :database database
+ :expression query-expression
+ :error-id (sqlite3:sqlite3-error-code err)
+ :message (sqlite3:sqlite3-error-message err)))))
+
+;;; Object listing
+
+(defmethod database-list-tables-and-sequences ((database sqlite3-database) &key owner)
+ (declare (ignore owner))
+ ;; Query is copied from .table command of sqlite3 command 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 nil nil)))
+
+(defmethod database-list-tables ((database sqlite3-database) &key owner)
+ (remove-if #'(lambda (s)
+ (and (>= (length s) 11)
+ (string-equal (subseq s 0 11) "_CLSQL_SEQ_")))
+ (database-list-tables-and-sequences database :owner owner)))
+
+(defmethod database-list-views ((database sqlite3-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (mapcar #'car (database-query
+ "SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name"
+ database nil nil)))
+
+(defmethod database-list-indexes ((database sqlite3-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (mapcar #'car (database-query
+ "SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name"
+ database nil nil)))
+
+(defmethod database-list-table-indexes (table (database sqlite3-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (let ((*print-circle* nil))
+ (mapcar #'car
+ (database-query
+ (format
+ nil
+ "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name"
+ table table)
+ database nil nil))))
+
+(declaim (inline sqlite3-table-info))
+(defun sqlite3-table-info (table database)
+ (database-query (format nil "PRAGMA table_info('~A')" table)
+ database nil nil))
+
+(defmethod database-list-attributes (table (database sqlite3-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (mapcar #'(lambda (table-info) (second table-info))
+ (sqlite3-table-info table database)))
+
+(defmethod database-attribute-type (attribute table
+ (database sqlite3-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (loop for field-info in (sqlite3-table-info table database)
+ when (string= attribute (second field-info))
+ return
+ (let* ((raw-type (third field-info))
+ (start-length (position #\( raw-type))
+ (type (if start-length
+ (subseq raw-type 0 start-length)
+ raw-type))
+ (length (if start-length
+ (parse-integer (subseq raw-type (1+ start-length))
+ :junk-allowed t)
+ nil)))
+ (values (when type (ensure-keyword type))
+ length
+ nil
+ (if (string-equal (fourth field-info) "0")
+ 1 0)))))
+
+(defmethod database-create (connection-spec (type (eql :sqlite3)))
+ (declare (ignore connection-spec))
+ ;; databases are created automatically by Sqlite3
+ t)
+
+(defmethod database-destroy (connection-spec (type (eql :sqlite3)))
+ (destructuring-bind (name) connection-spec
+ (if (probe-file name)
+ (delete-file name)
+ nil)))
+
+(defmethod database-probe (connection-spec (type (eql :sqlite3)))
+ (destructuring-bind (name) connection-spec
+ ;; TODO: Add a test that this file is a real sqlite3 database
+ (or (string-equal ":memory:" name)
+ (and (probe-file name) t))))
+
+;;; Database capabilities
+
+(defmethod db-type-has-boolean-where? ((db-type (eql :sqlite3)))
+ nil)
:fdml/select/21 :fdml/select/32
:fdml/select/33))
(push (cons test "not supported by sqlite") skip-tests))
+ ((and (eql *test-database-type* :sqlite3)
+ (clsql-sys:in test :fddl/view/4 :fdml/select/10
+ :fdml/select/21 :fdml/select/32
+ :fdml/select/33))
+ (push (cons test "not supported by sqlite3") skip-tests))
((and (not (clsql-sys:db-type-has-bigint? db-type))
(clsql-sys:in test :basic/bigint/1))
(push (cons test "bigint not supported") skip-tests))
:type "config"))
(defvar +all-db-types+
- '(:postgresql :postgresql-socket :mysql :sqlite :odbc :oracle
+ '(:postgresql :postgresql-socket :mysql :sqlite :sqlite3 :odbc :oracle
#+allegro :aodbc))
(defclass conn-specs ()
(postgresql :accessor postgresql-spec :initform nil)
(postgresql-socket :accessor postgresql-socket-spec :initform nil)
(sqlite :accessor sqlite-spec :initform nil)
+ (sqlite3 :accessor sqlite3-spec :initform nil)
(odbc :accessor odbc-spec :initform nil)
(oracle :accessor oracle-spec :initform nil))
(:documentation "Connection specs for CLSQL testing"))
projects / clsql.git / commitdiff