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