--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sqlite-api-uffi.lisp
+;;;; Purpose: Low-level SQLite interface using UFFI
+;;;; Authors: Aurelio Bignoli and Kevin Rosenberg
+;;;; Created: Nov 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
+;;;; and Copyright (c) 2003-2004 by Kevin Rosenberg
+;;;;
+;;;; 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 #: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-row-pointer-type
+ #: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
+ (uffi:convert-from-cstring
+ (sqlite-error-string code))))))
+ (unless (signal condition)
+ (invoke-debugger condition))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Foreign types definitions.
+;;;;
+(def-foreign-type errmsg (* :unsigned-char))
+(def-foreign-type sqlite-db :pointer-void)
+(def-foreign-type sqlite-vm :pointer-void)
+(def-foreign-type string-pointer (* (* :unsigned-char)))
+(def-foreign-type sqlite-row-pointer (* (* :unsigned-char)))
+
+(defvar +null-errmsg-pointer+ (make-null-pointer 'errmsg))
+(defvar +null-string-pointer-pointer+ (make-null-pointer 'string-pointer))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Lisp types used in declarations.
+;;;;
+(def-type sqlite-db-type sqlite-db)
+(def-type sqlite-row string-pointer)
+(def-type sqlite-row-pointer-type (* string-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 (* (* :unsigned-char)))
+ (vm (* sqlite-vm))
+ (error-message (* errmsg)))
+ :returning :int)
+
+(declaim (inline %step))
+(def-sqlite-function
+ ("sqlite_step" %step)
+ ((vm sqlite-vm)
+ (cols-n (* :int))
+ (cols (* (* (* :unsigned-char))))
+ (col-names (* (* (* :unsigned-char)))))
+ :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 (* (* (* :unsigned-char))))
+ (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))
+ (with-cstring (db-name-native db-name)
+ (let ((db (%open db-name-native mode +null-errmsg-pointer+)))
+ (if (null-pointer-p db)
+ (signal-sqlite-error SQLITE-ERROR
+ (format nil "unable to open ~A" db-name))
+ db))))
+
+(defun sqlite-compile (db sql)
+ (with-cstring (sql-native sql)
+ (let ((vm (allocate-foreign-object 'sqlite-vm)))
+ (with-foreign-object (sql-tail '(* :unsigned-char))
+ (let ((result (%compile db sql-native sql-tail vm +null-errmsg-pointer+)))
+ (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 '(* (* :unsigned-char))))
+ (col-names (allocate-foreign-object '(* (* :unsigned-char)))))
+ (declare (type sqlite-row-pointer-type 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 +null-string-pointer-pointer+ +null-string-pointer-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) +null-errmsg-pointer+)))
+ (if (= result SQLITE-OK)
+ (progn
+ (free-foreign-object vm)
+ t)
+ (signal-sqlite-error result))))
+
+(defun sqlite-get-table (db sql)
+ (declare (type sqlite-db-type db))
+ (with-cstring (sql-native sql)
+ (let ((rows (allocate-foreign-object '(* (* :unsigned-char)))))
+ (declare (type sqlite-row-pointer-type rows))
+ (with-foreign-object (rows-n :int)
+ (with-foreign-object (cols-n :int)
+ (let ((result (%get-table db sql-native rows rows-n cols-n +null-errmsg-pointer+)))
+ (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-type table))
+ (%free-table (deref-pointer table 'sqlite-row-pointer)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Utility functions.
+;;;;
+(declaim (inline make-null-row))
+(defun make-null-row ()
+ +null-string-pointer-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-type a))
+ (convert-from-foreign-string
+ (deref-array (deref-pointer a 'sqlite-row-pointer) '(:array (* :unsigned-char)) n)))
+
+(declaim (inline sqlite-free-row))
+(defun sqlite-free-row (row)
+ (declare (type sqlite-row-pointer-type row))
+ (free-foreign-object row))
projects / clsql.git / blobdiff