db-sqlite/sqlite-api-uffi.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sqlite-api-uffi.lisp
   6 ;;;; Purpose:       Low-level SQLite interface using UFFI
   7 ;;;; Programmers:   Aurelio Bignoli and Kevin Rosenberg
   8 ;;;; Date Started:  Nov 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2003 by Aurelio Bignoli
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19
  20 ;;; NOTE: Upon reviewing the code, I found this is not UFFI compatible.
  21 ;;; it appears to work on CMUCL, but does not work correctly on Lispworks
  22 ;;; and Allegro. Mostly, the processing of return strings is still incorrect
  23 ;;; UFFI code.
  24 ;;; To fix this will require reading the SQLite API and reworking the
  25 ;;; code below.
  26 ;;; - Kevin Rosenberg
  27
  28 (in-package #:cl-user)
  29
  30 (defpackage #:sqlite
  31   (:use #:common-lisp #:uffi)
  32     (:export
  33            ;;; Conditions
  34            #:sqlite-error
  35            #:sqlite-error-code
  36            #:sqlite-error-message
  37
  38            ;;; Core API.
  39            #:sqlite-open
  40            #:sqlite-close
  41
  42            ;;; New API.
  43            #:sqlite-compile
  44            #:sqlite-step
  45            #:sqlite-finalize
  46
  47            ;;; Extended API.
  48            #:sqlite-get-table
  49            #:sqlite-free-table
  50            #:sqlite-version             ; Defined as constant.
  51            #:sqlite-encoding            ; Defined as constant.
  52            #:sqlite-last-insert-rowid
  53
  54            ;;; Utility functions.
  55            #:make-null-row
  56            #:make-null-vm
  57            #:null-row-p
  58            #:sqlite-aref
  59            #:sqlite-free-row
  60
  61            ;;; Types.
  62            #:sqlite-row
  63            #:sqlite-row-pointer
  64            #:sqlite-vm-pointer))
  65
  66 (in-package #:sqlite)
  67
  68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69 ;;;;
  70 ;;;; Return values for sqlite_exec() and sqlite_step()
  71 ;;;;
  72 (defconstant SQLITE-OK            0  "Successful result")
  73 (defconstant SQLITE-ERROR         1  "SQL error or missing database")
  74 (defconstant SQLITE-ROW         100  "sqlite_step() has another row ready")
  75 (defconstant SQLITE-DONE        101  "sqlite_step() has finished executing")
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;;;;
  79 ;;;; Conditions.
  80 ;;;;
  81 (define-condition sqlite-error ()
  82   ((message :initarg :message :reader sqlite-error-message :initform "")
  83    (code :initarg :code :reader sqlite-error-code))
  84   (:report (lambda (condition stream)
  85              (let ((code (sqlite-error-code condition)))
  86                (format stream "SQLite error [~A]: ~A"
  87                        code (sqlite-error-message condition))))))
  88
  89 (defun signal-sqlite-error (code &optional message)
  90   (let ((condition
  91          (make-condition 'sqlite-error
  92                          :code code
  93                          :message (if message
  94                                       message
  95                                       (sqlite-error-string code)))))
  96     (unless (signal condition)
  97       (invoke-debugger condition))))
  98
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100 ;;;;
 101 ;;;; Foreign types definitions.
 102 ;;;;
 103 (def-foreign-type sqlite-db :pointer-void)
 104 (def-foreign-type sqlite-vm :pointer-void)
 105 (def-foreign-type errmsg :cstring)
 106
 107 (def-array-pointer string-array-pointer :cstring)
 108
 109 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 110 ;;;
 111 ;;; Lisp types used in declarations.
 112 ;;;;
 113 (def-type sqlite-db-pointer (* sqlite-db))
 114 (def-type sqlite-int-pointer (* :int))
 115 (def-type sqlite-row string-array-pointer)
 116 (def-type sqlite-row-pointer (* string-array-pointer))
 117 (def-type sqlite-vm-pointer (* sqlite-vm))
 118
 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 120 ;;;;
 121 ;;;; Library functions.
 122 ;;;;
 123 (defmacro def-sqlite-function (name args &key (returning :void))
 124   `(def-function ,name ,args
 125     :module "sqlite"
 126     :returning ,returning))
 127
 128 (def-sqlite-function
 129     "sqlite_error_string"
 130     ((error-code :int))
 131   :returning :cstring)
 132
 133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 134 ;;;;
 135 ;;;; Core API.
 136 ;;;;
 137 (declaim (inline %open))
 138 (def-sqlite-function
 139     ("sqlite_open" %open)
 140     ((dbname :cstring)
 141      (mode :int)
 142      (error-message (* errmsg)))
 143   :returning sqlite-db)
 144
 145 (declaim (inline sqlite-close))
 146 (def-sqlite-function
 147     "sqlite_close"
 148     ((db sqlite-db)))
 149
 150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 151 ;;;;
 152 ;;;; New API.
 153 ;;;;
 154 (declaim (inline %compile))
 155 (def-sqlite-function
 156     ("sqlite_compile" %compile)
 157     ((db sqlite-db)
 158      (sql :cstring)
 159      (sql-tail (* (* :char)))
 160      (vm (* sqlite-vm))
 161      (error-message (* errmsg)))
 162   :returning :int)
 163
 164 (declaim (inline %step))
 165 (def-sqlite-function
 166     ("sqlite_step" %step)
 167     ((vm sqlite-vm)
 168      (cols-n (* :int))
 169      (cols (* (* :char)))
 170      (col-names (* (* :char))))
 171   :returning :int)
 172
 173 (declaim (inline %finalize))
 174 (def-sqlite-function
 175     ("sqlite_finalize" %finalize)
 176     ((vm sqlite-vm)
 177      (error-message (* errmsg)))
 178   :returning :int)
 179
 180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 181 ;;;;
 182 ;;;; Extended API.
 183 ;;;;
 184 (declaim (inline sqlite-last-insert-rowid))
 185 (def-sqlite-function
 186     "sqlite_last_insert_rowid"
 187     ((db sqlite-db))
 188   :returning :int)
 189
 190 (declaim (inline %get-table))
 191 (def-sqlite-function
 192     ("sqlite_get_table" %get-table)
 193     ((db sqlite-db)
 194      (sql :cstring)
 195      (result (* (* :char)))
 196      (rows-n (* :int))
 197      (cols-n (* :int))
 198      (error-message (* errmsg)))
 199   :returning :int)
 200
 201 (declaim (inline %free-table))
 202 (def-sqlite-function
 203     ("sqlite_free_table" %free-table)
 204     ((rows :pointer-void)))
 205
 206 (declaim (inline sqlite-libversion))
 207 (def-sqlite-function
 208     "sqlite_libversion"
 209     ()
 210   :returning :cstring)
 211
 212 (declaim (inline sqlite-libencoding))
 213 (def-sqlite-function
 214     "sqlite_libencoding"
 215     ()
 216   :returning :cstring)
 217
 218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 219 ;;;;
 220 ;;;; Wrapper functions.
 221 ;;;;
 222 (defparameter sqlite-version (sqlite-libversion))
 223 (defparameter sqlite-encoding (sqlite-libencoding))
 224
 225 (def-type sqlite-db-pointer-type sqlite-db-pointer)
 226 (def-type sqlite-vm-pointer-type sqlite-vm-pointer)
 227
 228 (defun sqlite-open (db-name &optional (mode 0))
 229   (let ((db (%open db-name mode nil)))
 230     (if (null-pointer-p db)
 231         (signal-sqlite-error SQLITE-ERROR
 232                              (format nil "unable to open ~A" db-name))
 233         db)))
 234
 235 (defun sqlite-compile (db sql)
 236   (let ((vm (allocate-foreign-object 'sqlite-vm)))
 237     (with-foreign-object (sql-tail '(* :char))
 238       (let ((result (%compile db sql sql-tail vm nil)))
 239         (if (= result SQLITE-OK)
 240             vm
 241             (progn
 242               (free-foreign-object vm)
 243               (signal-sqlite-error result)))))))
 244
 245 (defun sqlite-step (vm)
 246   (declare (type sqlite-vm-pointer-type vm))
 247   (with-foreign-object (cols-n :int)
 248     (let ((cols (allocate-foreign-object '(* :char)))
 249           (col-names (allocate-foreign-object '(* :char))))
 250       (declare (type sqlite-row-pointer cols col-names))
 251       (let ((result (%step (deref-pointer vm 'sqlite-vm)
 252                            cols-n cols col-names)))
 253         (cond
 254           ((= result SQLITE-ROW)
 255            (let ((n (deref-pointer cols-n :int)))
 256              (values n cols col-names)))
 257           ((= result SQLITE-DONE)
 258            (free-foreign-object cols)
 259            (free-foreign-object col-names)
 260            (values 0 (make-null-pointer 'string-array-pointer)
 261                    (make-null-pointer 'string-array-pointer)))
 262           (t
 263            (free-foreign-object cols)
 264            (free-foreign-object col-names)
 265            (signal-sqlite-error result)))))))
 266
 267 (defun sqlite-finalize (vm)
 268   (declare (type sqlite-vm-pointer vm))
 269   (let ((result (%finalize (deref-pointer vm 'sqlite-vm) nil)))
 270     (if (= result SQLITE-OK)
 271         (progn
 272           (free-foreign-object vm)
 273           t)
 274         (signal-sqlite-error result))))
 275
 276 (defun sqlite-get-table (db sql)
 277   (declare (type sqlite-db-pointer db))
 278   (let ((rows (allocate-foreign-object '(* :char))))
 279     (with-foreign-object (rows-n :int)
 280       (with-foreign-object (cols-n :int)
 281         (declare (type sqlite-row-pointer rows))
 282         (let ((result (%get-table db sql rows rows-n cols-n nil)))
 283           (if (= result SQLITE-OK)
 284               (let ((cn (deref-pointer cols-n :int))
 285                     (rn (deref-pointer rows-n :int)))
 286                 (values rows rn cn))
 287               (progn
 288                 (free-foreign-object rows)
 289                 (signal-sqlite-error result))))))))
 290
 291 (declaim (inline sqlite-free-table))
 292 (defun sqlite-free-table (table)
 293   (declare (type sqlite-row-pointer table))
 294   (%free-table (deref-pointer table 'sqlite-row-pointer)))
 295
 296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 297 ;;;;
 298 ;;;; Utility functions.
 299 ;;;;
 300 (declaim (inline make-null-row))
 301 (defun make-null-row ()
 302   (uffi:make-null-pointer 'string-array-pointer))
 303
 304 (declaim (inline make-null-vm))
 305 (defun make-null-vm ()
 306   (uffi:make-null-pointer 'sqlite-vm))
 307
 308 (declaim (inline null-row-p))
 309 (defun null-row-p (row)
 310   (null-pointer-p row))
 311
 312 (declaim (inline sqlite-aref))
 313 (defun sqlite-aref (a n)
 314   (declare (type sqlite-row-pointer a))
 315   (deref-array  (deref-pointer a 'sqlite-row-pointer) '(:array :char) n))
 316
 317 (declaim (inline sqlite-free-row))
 318 (defun sqlite-free-row (row)
 319   (declare (type sqlite-row-pointer row))
 320   (free-foreign-object row))