;; 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: