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