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