+++ /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$
-
-(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)
-
-\f
-;;;; Local Variables:
-;;;; Mode: lisp
-;;;; Syntax: ANSI-Common-Lisp
-;;;; Package: sqlite
-;;;; End:
projects / clsql.git / blobdiff