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