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 (in-package #:cl-user)
  20
  21 (defpackage #:sqlite
  22   (:use #:common-lisp #:uffi)
  23     (:export
  24            ;;; Conditions
  25            #:sqlite-error
  26            #:sqlite-error-code
  27            #:sqlite-error-message
  28
  29            ;;; Core API.
  30            #:sqlite-open
  31            #:sqlite-close
  32
  33            ;;; New API.
  34            #:sqlite-compile
  35            #:sqlite-step
  36            #:sqlite-finalize
  37
  38            ;;; Extended API.
  39            #:sqlite-get-table
  40            #:sqlite-free-table
  41            #:sqlite-version             ; Defined as constant.
  42            #:sqlite-encoding            ; Defined as constant.
  43            #:sqlite-last-insert-rowid
  44
  45            ;;; Utility functions.
  46            #:make-null-row
  47            #:make-null-vm
  48            #:null-row-p
  49            #:sqlite-aref
  50            #:sqlite-free-row
  51
  52            ;;; Types.
  53            #:sqlite-row
  54            #:sqlite-row-pointer
  55            #:sqlite-vm-pointer))
  56
  57 (in-package #:sqlite)
  58
  59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60 ;;;;
  61 ;;;; Return values for sqlite_exec() and sqlite_step()
  62 ;;;;
  63 (defconstant SQLITE-OK            0  "Successful result")
  64 (defconstant SQLITE-ERROR         1  "SQL error or missing database")
  65 (defconstant SQLITE-ROW         100  "sqlite_step() has another row ready")
  66 (defconstant SQLITE-DONE        101  "sqlite_step() has finished executing")
  67
  68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69 ;;;;
  70 ;;;; Conditions.
  71 ;;;;
  72 (define-condition sqlite-error ()
  73   ((message :initarg :message :reader sqlite-error-message :initform "")
  74    (code :initarg :code :reader sqlite-error-code))
  75   (:report (lambda (condition stream)
  76              (let ((code (sqlite-error-code condition)))
  77                (format stream "SQLite error [~A]: ~A"
  78                        code (sqlite-error-message condition))))))
  79
  80 (defun signal-sqlite-error (code &optional message)
  81   (let ((condition
  82          (make-condition 'sqlite-error
  83                          :code code
  84                          :message (if message
  85                                       message
  86                                       (sqlite-error-string code)))))
  87     (unless (signal condition)
  88       (invoke-debugger condition))))
  89
  90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91 ;;;;
  92 ;;;; Foreign types definitions.
  93 ;;;;
  94 (def-foreign-type errmsg (* :char))
  95 (def-foreign-type sqlite-db :pointer-void)
  96 (def-foreign-type sqlite-vm :pointer-void)
  97 (def-foreign-type string-pointer (* (* :char)))
  98
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100 ;;;
 101 ;;; Lisp types used in declarations.
 102 ;;;;
 103 (def-type sqlite-db sqlite-db)
 104 (def-type sqlite-row string-pointer)
 105 (def-type sqlite-row-pointer (* string-pointer))
 106 (def-type sqlite-vm-pointer (* sqlite-vm))
 107
 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109 ;;;;
 110 ;;;; Library functions.
 111 ;;;;
 112 (defmacro def-sqlite-function (name args &key (returning :void))
 113   `(def-function ,name ,args
 114     :module "sqlite"
 115     :returning ,returning))
 116
 117 (def-sqlite-function
 118     "sqlite_error_string"
 119     ((error-code :int))
 120   :returning :cstring)
 121
 122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 123 ;;;;
 124 ;;;; Core API.
 125 ;;;;
 126 (declaim (inline %open))
 127 (def-sqlite-function
 128     ("sqlite_open" %open)
 129     ((dbname :cstring)
 130      (mode :int)
 131      (error-message (* errmsg)))
 132   :returning sqlite-db)
 133
 134 (declaim (inline sqlite-close))
 135 (def-sqlite-function
 136     "sqlite_close"
 137     ((db sqlite-db)))
 138
 139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 140 ;;;;
 141 ;;;; New API.
 142 ;;;;
 143 (declaim (inline %compile))
 144 (def-sqlite-function
 145     ("sqlite_compile" %compile)
 146     ((db sqlite-db)
 147      (sql :cstring)
 148      (sql-tail (* (* :char)))
 149      (vm (* sqlite-vm))
 150      (error-message (* errmsg)))
 151   :returning :int)
 152
 153 (declaim (inline %step))
 154 (def-sqlite-function
 155     ("sqlite_step" %step)
 156     ((vm sqlite-vm)
 157      (cols-n (* :int))
 158      (cols (* (* (* :char))))
 159      (col-names (* (* (* :char)))))
 160   :returning :int)
 161
 162 (declaim (inline %finalize))
 163 (def-sqlite-function
 164     ("sqlite_finalize" %finalize)
 165     ((vm sqlite-vm)
 166      (error-message (* errmsg)))
 167   :returning :int)
 168
 169 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 170 ;;;;
 171 ;;;; Extended API.
 172 ;;;;
 173 (declaim (inline sqlite-last-insert-rowid))
 174 (def-sqlite-function
 175     "sqlite_last_insert_rowid"
 176     ((db sqlite-db))
 177   :returning :int)
 178
 179 (declaim (inline %get-table))
 180 (def-sqlite-function
 181     ("sqlite_get_table" %get-table)
 182     ((db sqlite-db)
 183      (sql :cstring)
 184      (result (* (* (* :char))))
 185      (rows-n (* :int))
 186      (cols-n (* :int))
 187      (error-message (* errmsg)))
 188   :returning :int)
 189
 190 (declaim (inline %free-table))
 191 (def-sqlite-function
 192     ("sqlite_free_table" %free-table)
 193     ((rows :pointer-void)))
 194
 195 (declaim (inline sqlite-libversion))
 196 (def-sqlite-function
 197     "sqlite_libversion"
 198     ()
 199   :returning :cstring)
 200
 201 (declaim (inline sqlite-libencoding))
 202 (def-sqlite-function
 203     "sqlite_libencoding"
 204     ()
 205   :returning :cstring)
 206
 207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 208 ;;;;
 209 ;;;; Wrapper functions.
 210 ;;;;
 211 (defparameter sqlite-version (sqlite-libversion))
 212 (defparameter sqlite-encoding (sqlite-libencoding))
 213
 214 (defun sqlite-open (db-name &optional (mode 0))
 215   (with-cstring (db-name-native db-name)
 216     (let ((db (%open db-name-native mode nil)))
 217       (if (null-pointer-p db)
 218           (signal-sqlite-error SQLITE-ERROR
 219                                (format nil "unable to open ~A" db-name))
 220           db))))
 221
 222 (defun sqlite-compile (db sql)
 223   (with-cstring (sql-native sql)
 224     (let ((vm (allocate-foreign-object 'sqlite-vm)))
 225       (with-foreign-object (sql-tail '(* :char))
 226         (let ((result (%compile db sql-native sql-tail vm nil)))
 227           (if (= result SQLITE-OK)
 228               vm
 229               (progn
 230                 (free-foreign-object vm)
 231                 (signal-sqlite-error result))))))))
 232
 233 (defun sqlite-step (vm)
 234   (declare (type sqlite-vm-pointer vm))
 235   (with-foreign-object (cols-n :int)
 236     (let ((cols (allocate-foreign-object '(* (* :char))))
 237           (col-names (allocate-foreign-object '(* (* :char)))))
 238       (declare (type sqlite-row-pointer cols col-names))
 239       (let ((result (%step (deref-pointer vm 'sqlite-vm)
 240                            cols-n cols col-names)))
 241         (cond
 242           ((= result SQLITE-ROW)
 243            (let ((n (deref-pointer cols-n :int)))
 244              (values n cols col-names)))
 245           ((= result SQLITE-DONE)
 246            (free-foreign-object cols)
 247            (free-foreign-object col-names)
 248            (values 0 (make-null-pointer 'string-pointer)
 249                    (make-null-pointer 'string-pointer)))
 250           (t
 251            (free-foreign-object cols)
 252            (free-foreign-object col-names)
 253            (signal-sqlite-error result)))))))
 254
 255 (defun sqlite-finalize (vm)
 256   (declare (type sqlite-vm-pointer vm))
 257   (let ((result (%finalize (deref-pointer vm 'sqlite-vm) nil)))
 258     (if (= result SQLITE-OK)
 259         (progn
 260           (free-foreign-object vm)
 261           t)
 262         (signal-sqlite-error result))))
 263
 264 (defun sqlite-get-table (db sql)
 265   (declare (type sqlite-db db))
 266   (with-cstring (sql-native sql)
 267     (let ((rows (allocate-foreign-object '(* (* :char)))))
 268       (declare (type sqlite-row-pointer rows))
 269       (with-foreign-object (rows-n :int)
 270         (with-foreign-object (cols-n :int)
 271           (let ((result (%get-table db sql-native rows rows-n cols-n nil)))
 272             (if (= result SQLITE-OK)
 273                 (let ((cn (deref-pointer cols-n :int))
 274                       (rn (deref-pointer rows-n :int)))
 275                   (values rows rn cn))
 276                 (progn
 277                   (free-foreign-object rows)
 278                   (signal-sqlite-error result)))))))))
 279
 280 (declaim (inline sqlite-free-table))
 281 (defun sqlite-free-table (table)
 282   (declare (type sqlite-row-pointer table))
 283   (%free-table (deref-pointer table 'sqlite-row-pointer)))
 284
 285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 286 ;;;;
 287 ;;;; Utility functions.
 288 ;;;;
 289 (declaim (inline make-null-row))
 290 (defun make-null-row ()
 291   (uffi:make-null-pointer 'string-pointer))
 292
 293 (declaim (inline make-null-vm))
 294 (defun make-null-vm ()
 295   (uffi:make-null-pointer 'sqlite-vm))
 296
 297 (declaim (inline null-row-p))
 298 (defun null-row-p (row)
 299   (null-pointer-p row))
 300
 301 (declaim (inline sqlite-aref))
 302 (defun sqlite-aref (a n)
 303   (declare (type sqlite-row-pointer a))
 304   (convert-from-foreign-string (deref-array  (deref-pointer a 'sqlite-row-pointer) '(:array :char) n)))
 305
 306 (declaim (inline sqlite-free-row))
 307 (defun sqlite-free-row (row)
 308   (declare (type sqlite-row-pointer row))
 309   (free-foreign-object row))